From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.ciao.gmane.io!not-for-mail From: Po Lu via "Emacs development discussions." Newsgroups: gmane.emacs.devel Subject: Emacs canvas support Date: Wed, 29 Apr 2020 14:34:09 +0800 Message-ID: <875zdikdge.fsf@yahoo.com> References: <875zdikdge.fsf.ref@yahoo.com> Reply-To: Po Lu Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="ciao.gmane.io:159.69.161.202"; logging-data="116404"; mail-complaints-to="usenet@ciao.gmane.io" To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Wed Apr 29 08:35:09 2020 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1jTgJI-000U1L-5m for ged-emacs-devel@m.gmane-mx.org; Wed, 29 Apr 2020 08:35:08 +0200 Original-Received: from localhost ([::1]:34380 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jTgJH-0001Lc-85 for ged-emacs-devel@m.gmane-mx.org; Wed, 29 Apr 2020 02:35:07 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:41904) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jTgIa-0000Rr-BN for emacs-devel@gnu.org; Wed, 29 Apr 2020 02:34:27 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.90_1) (envelope-from ) id 1jTgIX-0004gR-E2 for emacs-devel@gnu.org; Wed, 29 Apr 2020 02:34:24 -0400 Original-Received: from sonic301-30.consmr.mail.ne1.yahoo.com ([66.163.184.199]:46513) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jTgIW-0004g1-Mz for emacs-devel@gnu.org; Wed, 29 Apr 2020 02:34:21 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=yahoo.com; s=s2048; t=1588142059; bh=1QA0RJU+2nTEf74HAZ+z6g/Um8KubJATyKlMMgNQnDo=; h=From:To:Subject:Date:References:From:Subject; b=EQYk0OWLZ/hqvVVFfdeqd3NZriL2NmqCIFyEBAljIk1EIHZtIn+BPVkg6lucCRYM9u442VedX42CyItzweM3WyrTfTqiTWwKsOM5Z2+n01EckSvddwoy6kbl/KN+gsuDMOeH5vrStIB2ol/MsaG1MsS5btlKAXu9TqNF5XdSE1/itlYEARIrf3LAEtdg1HM6LPNr9lHgYx/RY4pr8DQvw+S+84Apiz+hqNlqTC3GjujXnIEazhvjm0wHXKnLMcBnSLOEFsUJ/l078Xjobl8SkwcYpv6pmP0+1WsXdgYzwmwXrLIqQU0kb6O8HTEVQto1/GhQ0rPDkpv+s3UJcEM/dA== X-YMail-OSG: JKdjfaoVM1lNJLD3iRWxTsAT7J85hCYQSyslLCOMrhhxJFq.F.8yOzowGOfpgnD B1UBE90HN1OFO5Ph4wnB3t0knwhqTs8dfKKDShhIRSPPik53XNhvV_shyDNS.vvYA_UW_LQF831Q bCV6SPq21FyEV.nvRWP0EOjiWvFnuOK2j5nT7mBF4fUAx2XyazuYrA0VUxpgS5OIpcgwWxTHhMf8 L2_6iNhRMKNscwtA02FCmKKsiIPZdp2.hlQVd_9RCncdJEcDDCbyelH3_O0nKcg4PbOgL9slKN4M ldCWp_ru5AAkDUeL7Pc1GAMVqzBQ.SULHYo.DZcum95QPFv0dH5T6u_5oAmFv0O0nfPgfkaHjD2t QMPOv7phGjzZ0NRpdLAEpH36hSoMwSFxAqNKihCaoTHPTPfBvXHmSkN.fIyOh6ZO6hYaZshpvTa0 4bkq94YHhVUkIUSY.8mnQC5qTEe9EragalHNLZHA28_w32Pr.qPqezRteNhFyFJSajfDKQP7tmnL J4qYWF0QHCIPGqJO3QwMyMzTg6Thyi8owO2B..6Q161Sho3Rg.mgvdfv4Zq6o17zoE3GZLLP8ev_ iW_MkIIc5.58XAzvEjA3KJ_3Fv9YlhE8DY_eIe9FA7rq280F_fN5.m0RY4.Bs2wEZsZQf58.0bl5 IDGHF8vgqOHlO.lMnwMyTjloQqGXw4FPUeGYQ07qrfd8jte0fFPf2jlGzZFpyV5i6x3JoQiijHg0 hFEPpY2wtNDYyfIlm7rinbVcbOl3u7v4iLsV_TztbPAvjXwi1wjDdL.1clfeglyZGx8okLUHNp4q 5k3Fwbqg7ELVY50os9rfv_o1_FTuQ_Btnc5zteGh14 Original-Received: from sonic.gate.mail.ne1.yahoo.com by sonic301.consmr.mail.ne1.yahoo.com with HTTP; Wed, 29 Apr 2020 06:34:19 +0000 Original-Received: by smtp419.mail.sg3.yahoo.com (VZM Hermes SMTP Server) with ESMTPA ID d9677d12b69b32835f749b78441e3e1c; Wed, 29 Apr 2020 06:34:11 +0000 (UTC) X-Mailer: WebService/1.1.15756 hermes Apache-HttpAsyncClient/4.1.4 (Java/11.0.6) Received-SPF: pass client-ip=66.163.184.199; envelope-from=luangruo@yahoo.com; helo=sonic301-30.consmr.mail.ne1.yahoo.com X-detected-operating-system: by eggs.gnu.org: First seen = 2020/04/29 01:08:55 X-ACL-Warn: Detected OS = Linux 3.1-3.10 X-Received-From: 66.163.184.199 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:248087 Archived-At: --=-=-= Content-Type: text/plain I'd appreciate some feedback on something I came up with during my spare time: Emacs canvas support. For now it only works on X11 + Cairo builds, and I haven't quite figured out how to make redisplay work reliably on canvases, but it already seems to be quite promising. A patch is attached below. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-emacs-canvas-patches.diff Content-Description: Canvas patche diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index e53f0e9f60..2a24576620 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -27,6 +27,7 @@ Display * Window Dividers:: Separating windows visually. * Display Property:: Images, margins, text size, etc. * Images:: Displaying images in Emacs buffers. +* Canvases:: Drawing areas inside Emacs buffers. * Xwidgets:: Displaying native widgets in Emacs buffers. * Buttons:: Adding clickable buttons to Emacs buffers. * Abstract Display:: Emacs's Widget for Object Collections. @@ -6509,6 +6510,152 @@ Image Cache debugging. @end defvar +@node Canvases +@cindex drawing canvases +@cindex drawing areas +@cindex canvases +@section Canvases + +This chapter describes canvases, objects that can store drawing operations +which are then displayed inside buffer text. + +@menu +* Creating Canvases:: How canvases can be created +* Operating on Canvases:: How canvases can be used +* Displaying Canvases:: How canvases can be displayed +@end menu + +@node Creating Canvases +@cindex creating Canvases +@pindex make-canvas + + This section describes how canvases can be created. +To create a canvas, call the function @code{make-canvas}. + +@defun make-canvas width height +This function takes 2 arguments @code{width}, and @code{height}, +and creates a canvas @code{width} wide and @code{height} tall. +@end defun + +@defun canvas-from-image image &optional width height +This function creates a canvas from the image descriptor +@code{image}. The created canvas will be @code{width} wide, +and @code{height} tall, if specified. +@end defun + +@node Operating on Canvases +@cindex operating on Canvases +@pindex canvas-rectangle + + This section describes how canvases can be drawn to, +and manipulated. + +@defun canvasp canvas +Return whether @code{canvas} is a canvas or not. +@end defun + +@defun canvas-dimensions canvas +Return the dimensions of @code{canvas} as a pair. +@end defun + +@defun canvas-ellipse canvas x y width height &optional color + hollow opacity +Draw an ellipse centred upon @code{x}, @code{y} onto the canvas +@code{canvas}. The drawn ellipse will be colored @code{color}, +or the current frame's foreground color if @code{color} is not +specified or nil. The opacity of the drawn item will be +@code{opacity}, and the item will be hollow if @code{hollow} is +non-nil. +@end defun + +@defun canvas-rectangle canvas x y width height &optional color + hollow opacity +Draw a rectangle at @code{x}, and @code{y} onto the canvas +@code{canvas}. The rectangle will be colored @code{color}, +or the current frame's foreground color if @code{color} is nil. +The opacity of the drawn item will be @code{opacity}, and the item +will be hollow if @code{hollow} is non-nil. +@end defun + +@defun canvas-fill-pixel canvas x y color opacity +Fill the pixel at @code{x}, @code{y} inside @code{canvas} +to @code{color}, with the opacity @code{opacity}. +@end defun + +@defun canvas-draw-string canvas x y string + &optional color opacity family size +Draw the string @code{string} to @code{x}, @code{y} +inside the canvas @code{canvas}. The font family used +will be @code{family}, the color @code{color}, the opacity +@code{opacity}, and the size @code{size}. + +@code{family} can either be a string, or a list in which +the first element should be the family as a string, the +second element should be whether the font should be italic, +and an optional third argument describing whether or not +the font should be bold. +@end defun + +@defun canvas-draw-image canvas image-spec x y + &optional width height frame opacity +Paint @code{image-spec} into @code{canvas} at @code{x}, +@code{y}. If @code{width} or @code{height} +is set and the image is wider than @code{width} or @code{height} respectively, +the image will be cropped to fit. The alpha channel of @code{image-spec} +will be set to @code{opacity}. +@end defun + +@defun canvas-measure-string canvas string &optional family size +Return a cons pair containing the width and height of @code{string}, +when rendered onto @code{canvas}, with the font @code{family} at +@code{size}. +@end defun + +@defun canvas-rounded-rectangle canvas x y width height radius + &optional color hollow opacity +Draw a rounded rectangle at @code{x}, @code{y} onto @code{canvas}. +The opacity of the rectangle will be @code{opacity}. +The radius of the rectangle will be @code{radius}. +@end defun + +@defun canvas-pixel-at canvas x y +Return the pixel at @code{x}, @code{y} inside @code{canvas}, +as an ARGB list. +@end defun + +@defun canvas-draw-canvas canvas canvas2 x y &optional width height opacity +Draw @code{canvas2} onto @code{canvas} at @code{x}, @code{y}. +@code{canvas2}'s alpha channel will be set to @code{opacity}, +if specified. +@code{canvas2} will not be taller than @code{height} or wider than +@code{width}, if specified. +@end defun + +@defun canvas-width canvas +Return the width of @code{canvas}. +@end defun + +@defun canvas-height canvas +Return the height of @code{canvas}. +@end defun + +@defun canvas-region canvas x y width height +Return a subsection of @code{canvas} at @code{x}, +@code{y}, that is @code{width} wide and @code{height} tall. +@end defun + +@defun canvas-arc canvas x y radius angle1 angle2 &optional color opacity +Draw an arc at @code{x}, @code{y}, with a radius of @code{radius}, +and the angles @code{angle1}, @code{angle2}. +@end defun + +@node Displaying Canvases +@cindex displaying Canvases + + Canvases can be displayed by setting them as the +@code{display} property of a string. + + @node Xwidgets @section Embedded Native Widgets @cindex xwidget diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index bba1b63115..d995ec4606 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -1430,6 +1430,7 @@ Top * Window Dividers:: Separating windows visually. * Display Property:: Enabling special display features. * Images:: Displaying images in Emacs buffers. +* Canvases:: Drawing areas inside Emacs buffers. * Buttons:: Adding clickable buttons to Emacs buffers. * Abstract Display:: Emacs's Widget for Object Collections. * Blinking:: How Emacs shows the matching open parenthesis. diff --git a/lisp/canvas.el b/lisp/canvas.el new file mode 100644 index 0000000000..d60d3efa4f --- /dev/null +++ b/lisp/canvas.el @@ -0,0 +1,49 @@ +;;; canvas.el --- Canvas support for GNU Emacs + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; These are several utlity functions for canvas operations that can +;;; be implemented in Lisp code. + + +;;; Code: + +(defun canvas-fill-pixel (canvas x y color opacity) + "Set the pixel at X, Y inside CANVAS to COLOR, with the opacity OPACITY." + (canvas-rectangle canvas x y 1 1 color opacity)) + +(defun canvas-from-image (image &optional width height) + "Create a canvas from IMAGE. +The canvas will be no wider than WIDTH (if specified), +and no taller than HEIGHT (if specified)." + (let ((canvas (make-canvas (or width (car (image-size image t))) + (or height (cdr (image-size image t)))))) + (prog1 canvas (canvas-draw-image canvas image 0 0)))) + +(defun canvas-width (canvas) + "Return the width of CANVAS." + (car (canvas-dimensions canvas))) + +(defun canvas-height (canvas) + "Return the height of CANVAS." + (cdr (canvas-dimensions canvas))) + +(provide 'canvas) +;;; canvas.el ends here diff --git a/lisp/loadup.el b/lisp/loadup.el index 97525b2708..1a9b1c7410 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -285,6 +285,8 @@ (load "emacs-lisp/tabulated-list") (load "buff-menu") +(load "canvas") + (if (fboundp 'x-create-frame) (progn (load "fringe") diff --git a/src/Makefile.in b/src/Makefile.in index 552dd2e50a..0d70c68b04 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -407,6 +407,7 @@ .m.o: ## be dumped as pure by dump-emacs. base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ charset.o coding.o category.o ccl.o character.o chartab.o bidi.o \ + common-canvas.o \ $(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \ emacs.o keyboard.o macros.o keymap.o sysdep.o \ bignum.o buffer.o filelock.o insdel.o marker.o \ diff --git a/src/alloc.c b/src/alloc.c index cc9ba8dbf5..acce0109e1 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -47,6 +47,7 @@ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2020 Free Software #include "blockinput.h" #include "pdumper.h" #include "termhooks.h" /* For struct terminal. */ +#include "canvas.h" #ifdef HAVE_WINDOW_SYSTEM #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ @@ -3114,6 +3115,11 @@ cleanup_vector (struct Lisp_Vector *vector) module_finalize_function (function); } #endif + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CANVAS)) + { + struct canvas *cnvs = (struct canvas *) vector; + destroy_canvas_contents (cnvs->canvas); + } } /* Reclaim space used by unmarked vectors. */ diff --git a/src/canvas.h b/src/canvas.h new file mode 100644 index 0000000000..c42a15e6fd --- /dev/null +++ b/src/canvas.h @@ -0,0 +1,83 @@ +/* Canvas support for GNU Emacs. + Copyright (C) 2020 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "frame.h" +#include "window.h" + +#ifdef USE_CAIRO +#include +typedef cairo_surface_t *canvas_contents_t; +#else +typedef void *canvas_contents_t; +#endif + +struct canvas +{ + union vectorlike_header header; + Lisp_Object cnvs_objects; + Lisp_Object window; + Lisp_Object object; + + canvas_contents_t canvas; + int width, height; + bool multiple_objects_seen; + bool changed_since_last_redisplay; +} GCALIGNED_STRUCT; + +/* Test for xwidget pseudovector. */ +#define CANVASP(x) PSEUDOVECTORP (x, PVEC_CANVAS) +#define XCANVAS(a) \ + (eassert (CANVASP (a)), XUNTAG (a, Lisp_Vectorlike, struct canvas)) + +#define CHECK_CANVAS(x) CHECK_TYPE (CANVASP (x), Qcanvasp, x) + +#define MARK_CANVAS_CHANGED(x) \ + (((x)->changed_since_last_redisplay = true), \ + (windows_or_buffers_changed = 2), (redisplay ())); \ + do \ + { \ + if ((x)->multiple_objects_seen || !EQ (selected_window, (x)->window)) \ + { \ + Lisp_Object tail, head; \ + FOR_EACH_FRAME (tail, head) \ + { \ + struct frame *f = XFRAME (head); \ + SET_FRAME_GARBAGED (f); \ + } \ + } \ + } \ + while (false) + +extern Lisp_Object +make_canvas (int width, int height); + +extern canvas_contents_t +make_canvas_contents (int width, int height); + +extern void +destroy_canvas_contents (canvas_contents_t contents); + +extern void +syms_of_canvas (void); + +extern void +canvas_end_redisplay (struct window *w, + struct glyph_matrix *matrix); diff --git a/src/common-canvas.c b/src/common-canvas.c new file mode 100644 index 0000000000..501f4930f7 --- /dev/null +++ b/src/common-canvas.c @@ -0,0 +1,856 @@ +/* Canvas support for GNU Emacs. + Copyright (C) 2020 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include "canvas.h" +#include "coding.h" + +#include + +Lisp_Object +make_canvas (int width, int height) +{ +#ifndef USE_CAIRO + error ("Canvases are not supported without cairo.") +#endif + struct canvas *canvas = ALLOCATE_PSEUDOVECTOR + (struct canvas, object, PVEC_CANVAS); + canvas->width = width; + canvas->height = height; + canvas->object = Qnil; + canvas->multiple_objects_seen = false; + canvas->canvas = make_canvas_contents (width, height); + canvas->changed_since_last_redisplay = true; + + Lisp_Object cnvs; + XSETCANVAS (cnvs, canvas); + return cnvs; +} + +void +destroy_canvas_contents (canvas_contents_t contents) +{ +#ifdef USE_CAIRO + cairo_surface_destroy (contents); +#else + error ("Not implemented"); +#endif +} + +canvas_contents_t +make_canvas_contents (int width, int height) +{ +#ifdef USE_CAIRO + cairo_surface_t *crs = + cairo_image_surface_create (CAIRO_FORMAT_ARGB32, width, height); + return crs; +#else + error ("Not implemented"); +#endif +} + +void +canvas_end_redisplay (struct window *w, + struct glyph_matrix *matrix) +{ + int i; + int area; + + for (i = 0; i < matrix->nrows; ++i) + { + struct glyph_row *row; + row = MATRIX_ROW (matrix, i); + if (row->enabled_p) + for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area) + { + struct glyph *glyph = row->glyphs[area]; + struct glyph *glyph_end = glyph + row->used[area]; + for (; glyph < glyph_end; ++glyph) + if (glyph->type == CANVAS_GLYPH && + glyph->u.canvas->changed_since_last_redisplay) + { + canvas_update_glyph + (w, i, row, area, row->glyphs[area] - + glyph, 1 + row->glyphs[area] - glyph, + glyph); + } + } + } +} + +DEFUN ("make-canvas", Fmake_canvas, Smake_canvas, 2, 2, 0, + doc: /* Create a canvas, WIDTH pixels wide, and HEIGHT pixels tall. */) + (Lisp_Object width, Lisp_Object height) +{ + check_integer_range (height, 0, INT_MAX); + check_integer_range (width, 0, INT_MAX); + + return make_canvas (XFIXNUM (width), XFIXNUM (height)); +} + +DEFUN ("canvas-ellipse", Fcanvas_ellipse, Scanvas_ellipse, 5, 8, 0, + doc: /* Draw a WIDTH wide and HEIGHT tall ellipse centred at X, Y in CANVAS. +The color of the ellipse will be COLOR (or the foreground color of COLOR is nil). +The ellipse will be hollow if HOLLOW is non-nil. +The opacity of the circle will be OPACITY, which should be a floating-point +number between 1 and 0. */) + (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, + Lisp_Object width, Lisp_Object height, Lisp_Object color, + Lisp_Object hollow, Lisp_Object opacity) +{ + if (NILP (opacity)) + opacity = make_float (1.0); + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + check_integer_range (width, 0, INT_MAX); + check_integer_range (height, 0, INT_MAX); + CHECK_NUMBER (opacity); +#ifdef USE_CAIRO + if (NILP (color)) + color = Qunspecified; + Lisp_Object color_values = call1 (Qcolor_values, color); + if (!NILP (color_values)) + CHECK_LIST (color_values); + double r, g, b; + if (NILP (color_values)) + { + Emacs_Color col; + col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame)); + FRAME_TERMINAL (XFRAME (selected_frame))->query_colors + (XFRAME (selected_frame), &col, 1); + r = col.red / 65535.0; + g = col.green / 65535.0; + b = col.blue / 65535.0; + } + else + { + Lisp_Object lr = Fnth (make_fixnum (0), color_values), + lg = Fnth (make_fixnum (1), color_values), + lb = Fnth (make_fixnum (2), color_values); + + check_integer_range (lr, 0, 65535); + check_integer_range (lg, 0, 65535); + check_integer_range (lb, 0, 65535); + + r = XFIXNUM (lr) / 65535.0; + g = XFIXNUM (lg) / 65535.0; + b = XFIXNUM (lb) / 65535.0; + } + struct canvas *cv = XCANVAS (canvas); + cairo_t *cr = cairo_create (cv->canvas); + cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity)); + cairo_matrix_t save_matrix; + cairo_get_matrix (cr, &save_matrix); + cairo_translate (cr, XFIXNUM (x), XFIXNUM (y)); + cairo_scale (cr, 1, 1); + cairo_new_path (cr); + cairo_arc (cr, 0, 0, + XFIXNUM (width) / 2.0, 0, 2 * M_PI); + cairo_set_matrix (cr, &save_matrix); + + cairo_set_line_width (cr, canvas_stroke_width); + if (!NILP (hollow)) + cairo_stroke (cr); + else + cairo_fill (cr); + + cairo_destroy (cr); + MARK_CANVAS_CHANGED (cv); +#endif + return Qnil; +} + +DEFUN ("canvasp", Fcanvasp, Scanvasp, 1, 1, 0, + doc: /* Return t if CANVAS is a canvas, else nil. */) + (Lisp_Object canvas) +{ + return CANVASP (canvas) ? Qt : Qnil; +} + +DEFUN ("canvas-rectangle", Fcanvas_rectangle, Scanvas_rectangle, 5, 8, 0, + doc: /* Draw a WIDTH wide and HEIGHT tall rectangle at X, Y in CANVAS. +The color of the rectangle will be COLOR (or the foreground color of COLOR is nil). +The rectangle will be hollow if HOLLOW is non-nil. +The opacity of the circle will be OPACITY, which should be a floating-point +number between 1 and 0. */) + (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, + Lisp_Object width, Lisp_Object height, Lisp_Object color, + Lisp_Object hollow, Lisp_Object opacity) +{ + if (NILP (opacity)) + opacity = make_float (1.0); + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + check_integer_range (width, 0, INT_MAX); + check_integer_range (height, 0, INT_MAX); + CHECK_NUMBER (opacity); +#ifdef USE_CAIRO + if (NILP (color)) + color = Qunspecified; + Lisp_Object color_values = call1 (Qcolor_values, color); + if (!NILP (color_values)) + CHECK_LIST (color_values); + double r, g, b; + if (NILP (color_values)) + { + Emacs_Color col; + col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame)); + FRAME_TERMINAL (XFRAME (selected_frame))->query_colors + (XFRAME (selected_frame), &col, 1); + r = col.red / 65535.0; + g = col.green / 65535.0; + b = col.blue / 65535.0; + } + else + { + Lisp_Object lr = Fnth (make_fixnum (0), color_values), + lg = Fnth (make_fixnum (1), color_values), + lb = Fnth (make_fixnum (2), color_values); + + check_integer_range (lr, 0, 65535); + check_integer_range (lg, 0, 65535); + check_integer_range (lb, 0, 65535); + + r = XFIXNUM (lr) / 65535.0; + g = XFIXNUM (lg) / 65535.0; + b = XFIXNUM (lb) / 65535.0; + } + struct canvas *cv = XCANVAS (canvas); + cairo_t *cr = cairo_create (cv->canvas); + cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity)); + if (NILP (hollow)) + { + cairo_rectangle (cr, XFIXNUM (x), XFIXNUM (y), XFIXNUM (width), + XFIXNUM (height)); + cairo_fill (cr); + } + else + { + cairo_rectangle (cr, XFIXNUM (x), XFIXNUM (y), XFIXNUM (width), + XFIXNUM (height)); + cairo_stroke (cr); + } + cairo_destroy (cr); + MARK_CANVAS_CHANGED (cv); + return Qnil; +#else + error ("Not implemented"); +#endif +} + +DEFUN ("canvas-rounded-rectangle", Fcanvas_rounded_rectangle, Scanvas_rounded_rectangle, 6, MANY, 0, + doc: /* Draw a WIDTH wide and HEIGHT tall rectangle at X, Y in CANVAS. +The color of the rectangle will be COLOR (or the foreground color of COLOR is nil). +The rectangle will be hollow if HOLLOW is non-nil. +The opacity of the circle will be OPACITY, which should be a floating-point +number between 1 and 0. +usage: (canvas-rounded-rectangle canvas x y width height radius &optional color hollow opacity) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + Lisp_Object canvas, x, y, width, height, radius, color, hollow, opacity; + canvas = args[0]; + x = args[1]; + y = args[2]; + width = args[3]; + height = args[4]; + radius = args[5]; + color = Qnil; + hollow = Qnil; + opacity = Qnil; + + if (nargs > 6) + color = args[6]; + if (nargs > 7) + hollow = args[7]; + if (nargs > 8) + opacity = args[8]; + if (nargs > 9) + xsignal2 (Qwrong_number_of_arguments, + Qcanvas_rounded_rectangle, + make_fixnum (nargs)); + if (NILP (opacity)) + opacity = make_float (1.0); + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + check_integer_range (width, 0, INT_MAX); + check_integer_range (height, 0, INT_MAX); + CHECK_NUMBER (opacity); +#ifdef USE_CAIRO + if (NILP (color)) + color = Qunspecified; + Lisp_Object color_values = call1 (Qcolor_values, color); + if (!NILP (color_values)) + CHECK_LIST (color_values); + double r, g, b; + if (NILP (color_values)) + { + Emacs_Color col; + col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame)); + FRAME_TERMINAL (XFRAME (selected_frame))->query_colors + (XFRAME (selected_frame), &col, 1); + r = col.red / 65535.0; + g = col.green / 65535.0; + b = col.blue / 65535.0; + } + else + { + Lisp_Object lr = Fnth (make_fixnum (0), color_values), + lg = Fnth (make_fixnum (1), color_values), + lb = Fnth (make_fixnum (2), color_values); + + check_integer_range (lr, 0, 65535); + check_integer_range (lg, 0, 65535); + check_integer_range (lb, 0, 65535); + + r = XFIXNUM (lr) / 65535.0; + g = XFIXNUM (lg) / 65535.0; + b = XFIXNUM (lb) / 65535.0; + } + struct canvas *cv = XCANVAS (canvas); + cairo_t *cr = cairo_create (cv->canvas); + cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity)); + { +#define radius XFLOATINT (radius) + double degrees = M_PI / 180.0; +#define width XFIXNUM (width) +#define height XFIXNUM (height) +#define x XFIXNUM (x) +#define y XFIXNUM (y) + cairo_new_sub_path (cr); + cairo_arc (cr, x + width - radius, y + radius, radius, -90 * degrees, 0 * degrees); + cairo_arc (cr, x + width - radius, y + height - radius, radius, 0 * degrees, 90 * degrees); + cairo_arc (cr, x + radius, y + height - radius, radius, 90 * degrees, 180 * degrees); + cairo_arc (cr, x + radius, y + radius, radius, 180 * degrees, 270 * degrees); + cairo_close_path (cr); +#undef radius +#undef y +#undef x +#undef height +#undef width + } +#undef radius + cairo_set_line_width (cr, canvas_stroke_width); + if (NILP (hollow)) + cairo_fill (cr); + else + cairo_stroke (cr); + cairo_destroy (cr); + MARK_CANVAS_CHANGED (cv); + return Qnil; +#else + error ("Not implemented"); +#endif +} + +DEFUN ("canvas-draw-string", Fcanvas_draw_string, Scanvas_draw_string, 4, 8, 0, + doc: /* Draw the string STRING onto the canvas CANVAS at X, Y. +The opacity of the drawn text will be OPACITY, and the color of the drawn text will be COLOR. +The font-family used will be FAMILY, which can be a string or a list of +the font-family as a string, whether or not the the text should be italic, +and whether or not the text should be bold. +The size of the text will be SIZE, or the default text size if nil. */) + (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, Lisp_Object string, + Lisp_Object color, Lisp_Object opacity, Lisp_Object family, Lisp_Object size) +{ + if (noninteractive) + error ("`canvas-draw-string' cannot be called when running in batch mode."); + if (NILP (opacity)) + opacity = make_float (1.0); + if (NILP (size)) + size = make_fixnum (FRAME_TEXT_HEIGHT (XFRAME (selected_frame))); + if (NILP (family)) + family = build_string ("monospace"); + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + CHECK_NUMBER (opacity); + if (!Flistp (family)) + CHECK_STRING (family); + CHECK_STRING (string); +#ifdef USE_CAIRO + if (NILP (color)) + color = Qunspecified; + Lisp_Object color_values = call1 (Qcolor_values, color); + if (!NILP (color_values)) + CHECK_LIST (color_values); + double r, g, b; + if (NILP (color_values)) + { + Emacs_Color col; + col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame)); + FRAME_TERMINAL (XFRAME (selected_frame))->query_colors + (XFRAME (selected_frame), &col, 1); + r = col.red / 65535.0; + g = col.green / 65535.0; + b = col.blue / 65535.0; + } + else + { + Lisp_Object lr = Fnth (make_fixnum (0), color_values), + lg = Fnth (make_fixnum (1), color_values), + lb = Fnth (make_fixnum (2), color_values); + + check_integer_range (lr, 0, 65535); + check_integer_range (lg, 0, 65535); + check_integer_range (lb, 0, 65535); + + r = XFIXNUM (lr) / 65535.0; + g = XFIXNUM (lg) / 65535.0; + b = XFIXNUM (lb) / 65535.0; + } + struct canvas *c = XCANVAS (canvas); + cairo_t *cr = cairo_create (c->canvas); + cairo_font_slant_t slant_flags = CAIRO_FONT_SLANT_NORMAL; + cairo_font_weight_t weight_flags = CAIRO_FONT_WEIGHT_NORMAL; + const char *family_utf8; + if (!NILP (Flistp (family))) + { + if (!NILP (CALLN (Flss, Flength (family), make_fixnum (2)))) + error ("Invalid font spec"); + else + { + int length = XFIXNUM (Flength (family)); + if (length > 3) + error ("Invalid font spec"); + Lisp_Object italic, bold; + CHECK_STRING_CAR (family); + family_utf8 = SSDATA (ENCODE_UTF_8 (XCAR (family))); + if (length == 3) + bold = XCAR (XCDR (XCDR (family))); + else + bold = Qnil; + italic = XCAR (XCDR (family)); + if (!NILP (italic)) + slant_flags = CAIRO_FONT_SLANT_ITALIC; + if (!NILP (bold)) + weight_flags = CAIRO_FONT_WEIGHT_BOLD; + } + } + else + { + family_utf8 = SSDATA (ENCODE_UTF_8 (family)); + } + cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity)); + cairo_select_font_face (cr, family_utf8, + slant_flags, + weight_flags); + cairo_set_font_size (cr, XFIXNUM (size)); + cairo_move_to (cr, XFIXNUM (x), XFIXNUM (y) + XFIXNUM (size)); + cairo_show_text (cr, SSDATA (ENCODE_UTF_8 (string))); + cairo_destroy (cr); + MARK_CANVAS_CHANGED (c); + return Qnil; +#else + return Qnil; +#endif +} + +DEFUN ("canvas-measure-string", Fcanvas_measure_string, Scanvas_measure_string, 2, 4, 0, + doc: /* Return a pair containing the width and height of STRING, +if drawn on CANVAS with the family FAMILY at SIZE. */) +(Lisp_Object canvas, Lisp_Object string, Lisp_Object family, Lisp_Object size) +{ + if (noninteractive) + error ("`canvas-draw-string' cannot be called when running in batch mode."); + if (NILP (size)) + size = make_fixnum (FRAME_TEXT_HEIGHT (XFRAME (selected_frame))); + if (NILP (family)) + family = build_string ("cairo:monospace"); + CHECK_CANVAS (canvas); + + if (!Flistp (family)) + CHECK_STRING (family); + CHECK_STRING (string); +#ifdef USE_CAIRO + struct canvas *c = XCANVAS (canvas); + cairo_t *cr = cairo_create (c->canvas); + cairo_font_slant_t slant_flags = CAIRO_FONT_SLANT_NORMAL; + cairo_font_weight_t weight_flags = CAIRO_FONT_WEIGHT_NORMAL; + const char *family_utf8; + if (!NILP (Flistp (family))) + { + if (!NILP (CALLN (Flss, Flength (family), make_fixnum (2)))) + error ("Invalid font spec"); + else + { + int length = XFIXNUM (Flength (family)); + if (length > 3) + error ("Invalid font spec"); + Lisp_Object italic, bold; + CHECK_STRING_CAR (family); + family_utf8 = SSDATA (ENCODE_UTF_8 (XCAR (family))); + if (length == 3) + bold = XCAR (XCDR (XCDR (family))); + else + bold = Qnil; + italic = XCAR (XCDR (family)); + if (!NILP (italic)) + slant_flags = CAIRO_FONT_SLANT_ITALIC; + if (!NILP (bold)) + weight_flags = CAIRO_FONT_WEIGHT_BOLD; + } + } + else + { + family_utf8 = SSDATA (ENCODE_UTF_8 (family)); + } + cairo_select_font_face (cr, family_utf8, + slant_flags, + weight_flags); + cairo_set_font_size (cr, XFIXNUM (size)); + cairo_text_extents_t extents; + cairo_text_extents (cr, SSDATA (ENCODE_UTF_8 (string)), &extents); + cairo_destroy (cr); + return Fcons (make_fixnum (extents.width), + make_fixnum (extents.height)); +#else + return Qnil; +#endif +} + +DEFUN ("canvas-draw-image", Fcanvas_draw_image, Scanvas_draw_image, 4, 8, + 0, doc: /* Paint IMAGE_SPEC onto CANVAS, at X, Y. +If WIDTH or HEIGHT is set, and IMAGE is wider than WIDTH or taller than HEIGHT, +IMAGE_SPEC will be cropped to fit WIDTH and/or HEIGHT respectively. +FRAME should be a live frame. +The opacity of the drawn image will be OPACITY. */) + (Lisp_Object canvas, Lisp_Object image_spec, + Lisp_Object x, Lisp_Object y, + Lisp_Object width, Lisp_Object height, + Lisp_Object frame, Lisp_Object opacity) +{ + if (valid_image_p (image_spec)) + { + if (NILP (frame)) + frame = selected_frame; + struct frame *f = decode_window_system_frame (frame); + ptrdiff_t id = lookup_image (f, image_spec); + struct image *img = IMAGE_FROM_ID (f, id); + if (!img) + return Qnil; + if (img->load_failed_p) + return Qnil; + int iwidth = img->width + 2 * img->hmargin; + int iheight = img->height + 2 * img->vmargin; + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + if (NILP (width)) + width = make_fixnum (iwidth); + check_integer_range (width, 0, INT_MAX); + if (NILP (height)) + height = make_fixnum (iheight); + check_integer_range (height, 0, INT_MAX); + if (NILP (width)) + width = make_fixnum (iwidth); + if (NILP (opacity)) + opacity = make_fixnum (1); + CHECK_NUMBER (opacity); +#ifdef USE_CAIRO + cairo_surface_t *crs + = cairo_image_surface_create_for_data ((unsigned char *) + img->pixmap->data, + (img->pixmap->bits_per_pixel + == 32 + ? CAIRO_FORMAT_RGB24 + : CAIRO_FORMAT_A8), + img->pixmap->width, + img->pixmap->height, + img->pixmap->bytes_per_line); + struct canvas *cv = XCANVAS (canvas); + cairo_t *cr = cairo_create (cv->canvas); + cairo_save (cr); + cairo_translate (cr, XFIXNUM (x), XFIXNUM (y)); + cairo_rectangle (cr, 0, 0, + XFIXNUM (width), XFIXNUM (height)); + cairo_clip (cr); + cairo_set_source_surface (cr, crs, 0, 0); + cairo_paint_with_alpha (cr, XFLOATINT (opacity)); + cairo_restore (cr); + cairo_destroy (cr); + cairo_surface_destroy (crs); + MARK_CANVAS_CHANGED (cv); +#endif + } + else + error ("Invalid image specification"); + return Qnil; +} + +DEFUN ("canvas-arc", Fcanvas_arc, Scanvas_arc, 6, 8, 0, + doc: /* Draw an arc on CANVAS starting from XC, YC, +with a radius of RADIUS and 2 angles angle1 and angle2. +Use the color COLOR with the alpha channel set to OPACITY, if specified. */) + (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, Lisp_Object radius, + Lisp_Object angle1, Lisp_Object angle2, Lisp_Object color, Lisp_Object opacity) +{ + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + CHECK_NUMBER (angle1); + CHECK_NUMBER (angle2); + CHECK_NUMBER (radius); + + if (NILP (opacity)) + opacity = make_fixnum (1.0); + CHECK_NUMBER (opacity); + +#ifdef USE_CAIRO + if (NILP (color)) + color = Qunspecified; + Lisp_Object color_values = call1 (Qcolor_values, color); + if (!NILP (color_values)) + CHECK_LIST (color_values); + double r, g, b; + if (NILP (color_values)) + { + Emacs_Color col; + col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame)); + FRAME_TERMINAL (XFRAME (selected_frame)) + ->query_colors (XFRAME (selected_frame), &col, 1); + r = col.red / 65535.0; + g = col.green / 65535.0; + b = col.blue / 65535.0; + } + else + { + Lisp_Object lr = Fnth (make_fixnum (0), color_values), + lg = Fnth (make_fixnum (1), color_values), + lb = Fnth (make_fixnum (2), color_values); + + check_integer_range (lr, 0, 65535); + check_integer_range (lg, 0, 65535); + check_integer_range (lb, 0, 65535); + + r = XFIXNUM (lr) / 65535.0; + g = XFIXNUM (lg) / 65535.0; + b = XFIXNUM (lb) / 65535.0; + } + cairo_t *cr = cairo_create (XCANVAS (canvas)->canvas); + cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity)); + cairo_arc (cr, XFLOATINT (x), XFLOATINT (y), XFLOATINT (radius), + XFLOATINT (angle1), XFLOATINT (angle2)); + cairo_stroke (cr); + cairo_destroy (cr); + MARK_CANVAS_CHANGED (XCANVAS (canvas)); +#else +#endif + return Qnil; +} + +DEFUN ("canvas-filled-arc", Fcanvas_filled_arc, Scanvas_filled_arc, 6, 8, 0, + doc: /* Draw a filled arc on CANVAS starting from XC, YC, +with a radius of RADIUS and 2 angles angle1 and angle2. +Use the color COLOR with the alpha channel set to OPACITY, if specified. */) + (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, Lisp_Object radius, + Lisp_Object angle1, Lisp_Object angle2, Lisp_Object color, Lisp_Object opacity) +{ + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + CHECK_NUMBER (angle1); + CHECK_NUMBER (angle2); + CHECK_NUMBER (radius); + + if (NILP (opacity)) + opacity = make_fixnum (1.0); + CHECK_NUMBER (opacity); + +#ifdef USE_CAIRO + if (NILP (color)) + color = Qunspecified; + Lisp_Object color_values = call1 (Qcolor_values, color); + if (!NILP (color_values)) + CHECK_LIST (color_values); + double r, g, b; + if (NILP (color_values)) + { + Emacs_Color col; + col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame)); + FRAME_TERMINAL (XFRAME (selected_frame)) + ->query_colors (XFRAME (selected_frame), &col, 1); + r = col.red / 65535.0; + g = col.green / 65535.0; + b = col.blue / 65535.0; + } + else + { + Lisp_Object lr = Fnth (make_fixnum (0), color_values), + lg = Fnth (make_fixnum (1), color_values), + lb = Fnth (make_fixnum (2), color_values); + + check_integer_range (lr, 0, 65535); + check_integer_range (lg, 0, 65535); + check_integer_range (lb, 0, 65535); + + r = XFIXNUM (lr) / 65535.0; + g = XFIXNUM (lg) / 65535.0; + b = XFIXNUM (lb) / 65535.0; + } + cairo_t *cr = cairo_create (XCANVAS (canvas)->canvas); + cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity)); + cairo_arc (cr, XFLOATINT (x), XFLOATINT (y), XFLOATINT (radius), + XFLOATINT (angle1), XFLOATINT (angle2)); + cairo_fill (cr); + cairo_destroy (cr); + MARK_CANVAS_CHANGED (XCANVAS (canvas)); +#else +#endif + return Qnil; +} + +DEFUN ("canvas-region", Fcanvas_region, Scanvas_region, 5, 5, 0, + doc: /* Return a canvas containing a WIDTH wide and HEIGHT tall +subsection of CANVAS at X, Y */) + (Lisp_Object canvas, Lisp_Object x, + Lisp_Object y, Lisp_Object width, Lisp_Object height) +{ + CHECK_CANVAS (canvas); + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + check_integer_range (width, 0, INT_MAX); + check_integer_range (height, 0, INT_MAX); + +#ifdef USE_CAIRO + int ix = XFIXNUM (x), + iy = XFIXNUM (y), + iw = XFIXNUM (width), + ih = XFIXNUM (height); + cairo_surface_t *s = cairo_surface_create_for_rectangle + (XCANVAS (canvas)->canvas, ix, iy, iw, ih); + Lisp_Object newcvs = make_canvas (iw, ih); + struct canvas *target = XCANVAS (newcvs); + cairo_t *t = cairo_create (target->canvas); + cairo_set_source_surface (t, s, 0, 0); + cairo_paint (t); + cairo_destroy (t); + cairo_surface_destroy (s); + return newcvs; +#else + error ("Not implemented.") +#endif +} + + +DEFUN ("canvas-draw-canvas", Fcanvas_draw_canvas, Scanvas_draw_canvas, 4, 7, + 0, doc: /* Paint CANVAS2 onto CANVAS, at X, Y. +If WIDTH or HEIGHT is set, and IMAGE is wider than WIDTH or taller than HEIGHT, +IMAGE_SPEC will be cropped to fit WIDTH and/or HEIGHT respectively. +The opacity of the drawn image will be OPACITY. */) + (Lisp_Object canvas, Lisp_Object canvas2, + Lisp_Object x, Lisp_Object y, + Lisp_Object width, Lisp_Object height, Lisp_Object opacity) +{ + CHECK_CANVAS (canvas); + CHECK_CANVAS (canvas2); + int iwidth = XCANVAS (canvas2)->width; + int iheight = XCANVAS (canvas2)->height; + check_integer_range (x, 0, INT_MAX); + check_integer_range (y, 0, INT_MAX); + if (NILP (width)) + width = make_fixnum (iwidth); + check_integer_range (width, 0, INT_MAX); + if (NILP (height)) + height = make_fixnum (iheight); + check_integer_range (height, 0, INT_MAX); + if (NILP (width)) + width = make_fixnum (iwidth); + if (NILP (opacity)) + opacity = make_fixnum (1); + CHECK_NUMBER (opacity); + +#ifdef USE_CAIRO + cairo_surface_t *crs = XCANVAS (canvas2)->canvas; + struct canvas *cv = XCANVAS (canvas); + cairo_t *cr = cairo_create (cv->canvas); + cairo_save (cr); + cairo_translate (cr, XFIXNUM (x), XFIXNUM (y)); + cairo_rectangle (cr, 0, 0, XFIXNUM (width), XFIXNUM (height)); + cairo_clip (cr); + cairo_set_source_surface (cr, crs, 0, 0); + cairo_paint_with_alpha (cr, XFLOATINT (opacity)); + cairo_restore (cr); + cairo_destroy (cr); + MARK_CANVAS_CHANGED (cv); +#endif + return Qnil; +} + +DEFUN ("canvas-pixel-at", Fcanvas_pixel_at, Scanvas_pixel_at, 3, 3, 0, + doc: /* Return the color of the pixel at X, Y inside CANVAS as an ARGB list. */) + (Lisp_Object canvas, Lisp_Object x, Lisp_Object y) +{ +#ifndef USE_CAIRO + error ("Not implemented."); +#else + CHECK_CANVAS (canvas); + check_integer_range (x, 0, XCANVAS (canvas)->width); + check_integer_range (y, 0, XCANVAS (canvas)->height); + struct { +#ifdef WORDS_BIGENDIAN + uint8_t a, r, g, b; +#else + uint8_t b, g, r, a; +#endif + } *argb32 = + (void *) cairo_image_surface_get_data (XCANVAS (canvas)->canvas); + typeof (*argb32) res = argb32 [XFIXNUM (y) * XCANVAS (canvas)->width + + XFIXNUM (x)]; + return CALLN (Flist, make_fixnum (res.a), + make_fixnum (res.r), + make_fixnum (res.g), + make_fixnum (res.b)); +#endif +} + +DEFUN ("canvas-dimensions", Fcanvas_dimensions, Scanvas_dimensions, 1, 1, 0, + doc: /* Return a cons pair containing the width and height of CANVAS. */) + (Lisp_Object canvas) +{ + CHECK_CANVAS (canvas); + return Fcons (make_fixnum (XCANVAS (canvas)->width), + make_fixnum (XCANVAS (canvas)->height)); +} + +void +syms_of_canvas (void) +{ + defsubr (&Smake_canvas); + defsubr (&Scanvas_rectangle); + defsubr (&Scanvas_ellipse); + defsubr (&Scanvas_rectangle); + defsubr (&Scanvas_draw_string); + defsubr (&Scanvas_draw_image); + defsubr (&Scanvas_draw_canvas); + defsubr (&Scanvas_measure_string); + defsubr (&Scanvas_dimensions); + defsubr (&Scanvas_region); + defsubr (&Scanvas_pixel_at); + defsubr (&Scanvas_arc); + defsubr (&Scanvasp); + defsubr (&Scanvas_filled_arc); + defsubr (&Scanvas_rounded_rectangle); + DEFSYM (Qcanvas_rounded_rectangle, "canvas-rounded-rectangle"); + DEFSYM (Qcanvasp, "canvasp"); + DEFSYM (Qcolor_values, "color-values"); + DEFVAR_INT ("canvas-stroke-width", canvas_stroke_width, + doc: /* The stroke width to be used in canvases. */); + canvas_stroke_width = 4; +} diff --git a/src/data.c b/src/data.c index bce2e53cfb..aefd6d7e70 100644 --- a/src/data.c +++ b/src/data.c @@ -263,6 +263,8 @@ DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0, return Qxwidget; case PVEC_XWIDGET_VIEW: return Qxwidget_view; + case PVEC_CANVAS: + return Qcanvas; /* "Impossible" cases. */ case PVEC_MISC_PTR: case PVEC_OTHER: @@ -3859,6 +3861,7 @@ #define PUT_ERROR(sym, tail, msg) \ DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); + DEFSYM (Qcanvas, "canvas"); DEFSYM (Qthread, "thread"); DEFSYM (Qmutex, "mutex"); DEFSYM (Qcondition_variable, "condition-variable"); diff --git a/src/dispextern.h b/src/dispextern.h index 0b1f3d14ae..d33b87c3df 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -382,7 +382,10 @@ #define SET_GLYPH_FROM_GLYPH_CODE(glyph, gc) \ STRETCH_GLYPH, /* Glyph is an external widget drawn by the GUI toolkit. */ - XWIDGET_GLYPH + XWIDGET_GLYPH, + + /* Glyph is a canvas. */ + CANVAS_GLYPH }; @@ -540,6 +543,9 @@ #define FACE_ID_BITS 20 struct xwidget *xwidget; #endif + /* Canvas reference (type == CANVAS_GLYPH). */ + struct canvas *canvas; + /* Sub-structure for type == STRETCH_GLYPH. */ struct { @@ -1405,6 +1411,9 @@ #define OVERLAPS_ERASED_CURSOR (1 << 2) /* Xwidget. */ struct xwidget *xwidget; + /* Canvas. */ + struct canvas *canvas; + /* Slice */ struct glyph_slice slice; @@ -2158,7 +2167,10 @@ #define MAX_FRINGE_BITMAPS (1<current_matrix); + canvas_end_redisplay (w, w->current_matrix); clear_glyph_matrix (desired_matrix); return paused_p; @@ -3782,6 +3784,7 @@ gui_update_window_end (struct window *w, bool cursor_on_p, FRAME_RIF (f)->update_window_end_hook (w, cursor_on_p, mouse_face_overwritten_p); + canvas_end_redisplay (w, w->current_matrix); } #endif /* HAVE_WINDOW_SYSTEM */ @@ -4371,6 +4374,11 @@ scrolling_window (struct window *w, int tab_line_p) return 0; #endif + /* We need this to fix canvas movement detection in a reliable way. + FIXME. */ + if (w->have_canvas_p) + return 0; + /* Give up if some rows in the desired matrix are not enabled. */ if (! MATRIX_ROW_ENABLED_P (desired_matrix, i)) return -1; @@ -5565,6 +5573,10 @@ mode_line_string (struct window *w, enum window_part part, y0 -= row->ascent - glyph->ascent; } #endif + if (glyph->type == CANVAS_GLYPH) + { + y0 -= row->ascent - glyph->ascent; + } } else { @@ -5654,6 +5666,10 @@ marginal_area_string (struct window *w, enum window_part part, y0 += glyph->slice.img.y; } #endif + if (glyph->type == CANVAS_GLYPH) + { + y0 -= row->ascent - glyph->ascent; + } } else { diff --git a/src/emacs.c b/src/emacs.c index ea9c4cd79d..c16af2c14c 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -94,6 +94,8 @@ #define MAIN_PROGRAM #include "getpagesize.h" #include "gnutls.h" +#include "canvas.h" + #ifdef PROFILING # include extern void moncontrol (int mode); @@ -1567,6 +1569,8 @@ main (int argc, char **argv) /* Before init_window_once, because it sets up the Vcoding_system_hash_table. */ syms_of_coding (); /* This should be after syms_of_fileio. */ + + syms_of_canvas (); init_frame_once (); /* Before init_window_once. */ init_window_once (); /* Init the window system. */ #ifdef HAVE_WINDOW_SYSTEM diff --git a/src/lisp.h b/src/lisp.h index b4ac017dcf..f463399dad 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1103,6 +1103,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) PVEC_MUTEX, PVEC_CONDVAR, PVEC_MODULE_FUNCTION, + PVEC_CANVAS, /* These should be last, for internal_equal and sxhash_obj. */ PVEC_COMPILED, @@ -1349,6 +1350,7 @@ #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) #define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) #define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) #define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)) +#define XSETCANVAS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CANVAS)) /* Efficiently convert a pointer to a Lisp object and back. The pointer is represented as a fixnum, so the garbage collector diff --git a/src/pdumper.c b/src/pdumper.c index 63424c5734..33c527c7d8 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3036,6 +3036,8 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "condvar"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); + case PVEC_CANVAS: + error_unsupported_dump_object (ctx, lv, "canvas"); default: error_unsupported_dump_object(ctx, lv, "weird pseudovector"); } diff --git a/src/print.c b/src/print.c index bd1769144e..28a620fd20 100644 --- a/src/print.c +++ b/src/print.c @@ -34,6 +34,7 @@ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2020 Free Software #include "blockinput.h" #include "xwidget.h" #include "dynlib.h" +#include "canvas.h" #include #include @@ -1833,6 +1834,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } break; #endif + case PVEC_CANVAS: + { + print_c_string ("#width), printcharfun, false); + printchar ('x', printcharfun); + print_object (make_fixnum (canvas->height), printcharfun, false); + print_c_string (">", printcharfun); + } + break; default: emacs_abort (); diff --git a/src/window.c b/src/window.c index e2dea8b70e..5e0ed1ab94 100644 --- a/src/window.c +++ b/src/window.c @@ -4289,6 +4289,7 @@ make_window (void) w->scroll_bar_width = -1; w->scroll_bar_height = -1; w->column_number_displayed = -1; + w->have_canvas_p = false; /* Reset window_list. */ Vwindow_list = Qnil; /* Return window. */ diff --git a/src/window.h b/src/window.h index 167d1be7ab..67c7417007 100644 --- a/src/window.h +++ b/src/window.h @@ -445,6 +445,9 @@ #define WINDOW_H_INCLUDED window. */ bool_bf suspend_auto_hscroll : 1; + /* True if we think a canvas is being displayed in this window. */ + bool_bf have_canvas_p : 1; + /* Amount by which lines of this window are scrolled in y-direction (smooth scrolling). */ int vscroll; diff --git a/src/xdisp.c b/src/xdisp.c index 140d134572..e63c497100 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -462,6 +462,7 @@ Copyright (C) 1985-1988, 1993-1995, 1997-2020 Free Software Foundation, #include "fontset.h" #include "blockinput.h" #include "xwidget.h" +#include "canvas.h" #ifdef HAVE_WINDOW_SYSTEM #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ @@ -1055,6 +1056,7 @@ #define THIN_SPACE_WIDTH 1 static bool next_element_from_image (struct it *); static bool next_element_from_stretch (struct it *); static bool next_element_from_xwidget (struct it *); +static bool next_element_from_canvas (struct it *); static void load_overlay_strings (struct it *, ptrdiff_t); static bool get_next_display_element (struct it *); static enum move_it_result @@ -2688,7 +2690,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect) if (g < end) { - if (g->type == IMAGE_GLYPH) + if (g->type == IMAGE_GLYPH || g->type == CANVAS_GLYPH) { /* Don't remember when mouse is over image, as image may have hot-spots. */ @@ -5589,7 +5591,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, /* After this point, VALUE is the property after any margin prefix has been stripped. It must be a string, - an image specification, or `(space ...)'. + an image specification, a canvas, or `(space ...)'. LOCATION specifies where to display: `left-margin', `right-margin' or nil. */ @@ -5601,7 +5603,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, #endif /* not HAVE_WINDOW_SYSTEM */ || (CONSP (value) && EQ (XCAR (value), Qspace)) || ((it ? FRAME_WINDOW_P (it->f) : frame_window_p) - && valid_xwidget_spec_p (value))); + && valid_xwidget_spec_p (value))) || CANVASP (value); if (valid_p && display_replaced == 0) { @@ -5686,6 +5688,22 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, *position = start_pos; it->xwidget = lookup_xwidget (value); } + else if (CANVASP (value)) + { + it->what = IT_CANVAS; + it->method = GET_FROM_CANVAS; + it->position = start_pos; + it->object = NILP (object) ? it->w->contents : object; + *position = start_pos; + it->canvas = XCANVAS (value); + if ((!NILP (it->canvas->object) && + !EQ (it->canvas->object, it->object)) || + (!NILP (it->canvas->window) && + XWINDOW (it->canvas->window) != it->w)) + it->canvas->multiple_objects_seen = true; + it->canvas->object = it->object; + XSETWINDOW (it->canvas->window, it->w); + } #ifdef HAVE_WINDOW_SYSTEM else { @@ -6446,6 +6464,9 @@ push_it (struct it *it, struct text_pos *position) case GET_FROM_XWIDGET: p->u.xwidget.object = it->object; break; + case GET_FROM_CANVAS: + p->u.canvas.object = it->object; + break; case GET_FROM_BUFFER: case GET_FROM_DISPLAY_VECTOR: case GET_FROM_STRING: @@ -6550,6 +6571,9 @@ pop_it (struct it *it) case GET_FROM_XWIDGET: it->object = p->u.xwidget.object; break; + case GET_FROM_CANVAS: + it->object = p->u.canvas.object; + break; case GET_FROM_STRETCH: it->object = p->u.stretch.object; break; @@ -7236,6 +7260,7 @@ reseat_to_string (struct it *it, const char *s, Lisp_Object string, next_element_from_image, next_element_from_stretch, next_element_from_xwidget, + next_element_from_canvas, }; #define GET_NEXT_DISPLAY_ELEMENT(it) (*get_next_element[(it)->method]) (it) @@ -8151,6 +8176,7 @@ set_iterator_to_next (struct it *it, bool reseat_p) case GET_FROM_IMAGE: case GET_FROM_STRETCH: case GET_FROM_XWIDGET: + case GET_FROM_CANVAS: /* The position etc with which we have to proceed are on the stack. The position may be at the end of a string, @@ -8619,6 +8645,12 @@ next_element_from_xwidget (struct it *it) return true; } +static bool +next_element_from_canvas (struct it *it) +{ + it->what = IT_CANVAS; + return true; +} /* Fill iterator IT with next display element from a stretch glyph property. IT->object is the value of the text property. Value is @@ -27810,6 +27842,19 @@ fill_xwidget_glyph_string (struct glyph_string *s) s->xwidget = s->first_glyph->u.xwidget; } #endif + +static void +fill_canvas_glyph_string (struct glyph_string *s) +{ + eassert (s->first_glyph->type == CANVAS_GLYPH); + s->w->have_canvas_p = true; + s->face = FACE_FROM_ID (s->f, s->first_glyph->face_id); + s->font = s->face->font; + s->width = s->first_glyph->pixel_width; + s->ybase += s->first_glyph->voffset; + s->canvas = s->first_glyph->u.canvas; + s->canvas->changed_since_last_redisplay = false; +} /* Fill glyph string S from a sequence of stretch glyphs. START is the index of the first glyph to consider, @@ -28227,6 +28272,18 @@ #define BUILD_IMAGE_GLYPH_STRING(START, END, HEAD, TAIL, HL, X, LAST_X) \ while (false) #endif +#define BUILD_CANVAS_GLYPH_STRING(START, END, HEAD, TAIL, HL, X, LAST_X) \ + do \ + { \ + s = alloca (sizeof *s); \ + INIT_GLYPH_STRING (s, NULL, w, row, area, START, HL); \ + append_glyph_string (&(HEAD), &(TAIL), s); \ + ++(START); \ + s->x = (X); \ + fill_canvas_glyph_string (s); \ + } \ + while (false) + /* Add a glyph string for a sequence of character glyphs to the list of strings between HEAD and TAIL. START is the index of the first glyph in row area AREA of glyph row ROW that is part of the new @@ -28378,7 +28435,11 @@ #define BUILD_GLYPH_STRINGS_1(START, END, HEAD, TAIL, HL, X, LAST_X) \ case IMAGE_GLYPH: \ BUILD_IMAGE_GLYPH_STRING (START, END, HEAD, TAIL, \ HL, X, LAST_X); \ - break; + break; \ + case CANVAS_GLYPH: \ + BUILD_CANVAS_GLYPH_STRING (START, END, HEAD, TAIL, \ + HL, X, LAST_X); \ + break; \ #define BUILD_GLYPH_STRINGS_XW(START, END, HEAD, TAIL, HL, X, LAST_X) \ case XWIDGET_GLYPH: \ @@ -29086,6 +29147,116 @@ produce_image_glyph (struct it *it) } } +static void +produce_canvas_glyph (struct it *it) +{ + struct canvas *canvas; + int glyph_ascent, crop; + + eassert (it->what == IT_CANVAS); + + struct face *face = FACE_FROM_ID (it->f, it->face_id); + prepare_face_for_display (it->f, face); + + canvas = it->canvas; + it->ascent = it->phys_ascent = glyph_ascent = canvas->height / 2; + it->descent = it->phys_descent = canvas->height / 2; + it->pixel_width = canvas->width; + + if (it->descent < 0) + it->descent = 0; + + it->nglyphs = 1; + + if (face->box != FACE_NO_BOX) + { + if (face->box_horizontal_line_width > 0) + { + it->ascent += face->box_horizontal_line_width; + it->descent += face->box_horizontal_line_width; + } + + if (face->box_vertical_line_width > 0) + { + if (it->start_of_box_run_p) + it->pixel_width += face->box_vertical_line_width; + it->pixel_width += face->box_vertical_line_width; + } + } + + take_vertical_position_into_account (it); + + /* Automatically crop wide image glyphs at right edge so we can + draw the cursor on same display row. */ + crop = it->pixel_width - (it->last_visible_x - it->current_x); + if (crop > 0 && (it->hpos == 0 || it->pixel_width > it->last_visible_x / 4)) + it->pixel_width -= crop; + + if (it->glyph_row) + { + enum glyph_row_area area = it->area; + struct glyph *glyph + = it->glyph_row->glyphs[area] + it->glyph_row->used[area]; + + if (it->glyph_row->reversed_p) + { + struct glyph *g; + + /* Make room for the new glyph. */ + for (g = glyph - 1; g >= it->glyph_row->glyphs[it->area]; g--) + g[1] = *g; + glyph = it->glyph_row->glyphs[it->area]; + } + if (glyph < it->glyph_row->glyphs[area + 1]) + { + glyph->charpos = CHARPOS (it->position); + glyph->object = it->object; + glyph->pixel_width = clip_to_bounds (-1, it->pixel_width, SHRT_MAX); + glyph->ascent = glyph_ascent; + glyph->descent = it->descent; + glyph->voffset = it->voffset; + glyph->type = CANVAS_GLYPH; + glyph->avoid_cursor_p = it->avoid_cursor_p; + glyph->multibyte_p = it->multibyte_p; + glyph->u.canvas = it->canvas; + if (it->glyph_row->reversed_p && area == TEXT_AREA) + { + /* In R2L rows, the left and the right box edges need to be + drawn in reverse direction. */ + glyph->right_box_line_p = it->start_of_box_run_p; + glyph->left_box_line_p = it->end_of_box_run_p; + } + else + { + glyph->left_box_line_p = it->start_of_box_run_p; + glyph->right_box_line_p = it->end_of_box_run_p; + } + glyph->overlaps_vertically_p = 0; + glyph->padding_p = 0; + glyph->glyph_not_available_p = 0; + glyph->face_id = it->face_id; + glyph->font_type = FONT_TYPE_UNKNOWN; + if (it->bidi_p) + { + glyph->resolved_level = it->bidi_it.resolved_level; + eassert ((it->bidi_it.type & 7) == it->bidi_it.type); + glyph->bidi_type = it->bidi_it.type; + } + ++it->glyph_row->used[area]; + } + else + IT_EXPAND_MATRIX_WIDTH (it, area); + } +} + +void +canvas_update_glyph (struct window *w, int x, struct glyph_row *row, + enum glyph_row_area area, ptrdiff_t start, ptrdiff_t end, + struct glyph *glyph) +{ + draw_glyphs (w, x, row, area, start, end, DRAW_NORMAL_TEXT, 0); +} + static void produce_xwidget_glyph (struct it *it) { @@ -30608,6 +30779,8 @@ gui_produce_glyphs (struct it *it) produce_stretch_glyph (it); else if (it->what == IT_XWIDGET) produce_xwidget_glyph (it); + else if (it->what == IT_CANVAS) + produce_canvas_glyph (it); done: /* Accumulate dimensions. Note: can't assume that it->descent > 0 @@ -31008,6 +31181,10 @@ get_window_cursor_type (struct window *w, struct glyph *glyph, int *width, cursor_type = HOLLOW_BOX_CURSOR; } } + if (glyph != NULL && glyph->type == CANVAS_GLYPH) + { + cursor_type = HOLLOW_BOX_CURSOR; + } return cursor_type; } diff --git a/src/xterm.c b/src/xterm.c index 7989cecec7..716ed0ef97 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -75,6 +75,7 @@ Copyright (C) 1989, 1993-2020 Free Software Foundation, Inc. #include "sysselect.h" #include "menu.h" #include "pdumper.h" +#include "canvas.h" #ifdef USE_X_TOOLKIT #include @@ -2066,6 +2067,30 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) } } +static void +x_draw_canvas_glyph_string_foreground (struct glyph_string *s) +{ + eassert (s->first_glyph->type == CANVAS_GLYPH); +#ifdef USE_CAIRO + cairo_t *cr = x_begin_cr_clip (s->f, s->gc); + int x = s->x; + int y = s->ybase - s->first_glyph->ascent; + + if (s->face->box != FACE_NO_BOX && + s->first_glyph->left_box_line_p) + x += max (s->face->box_vertical_line_width, 0); + + x_set_glyph_string_clipping (s); + x_clear_area (s->f, x, y, s->width, s->height); + cairo_set_source_surface (cr, s->canvas->canvas, + s->x, s->y); + cairo_paint (cr); + x_end_cr_clip (s->f); +#else + emacs_abort (); +#endif +} + #ifdef USE_X_TOOLKIT #ifdef USE_LUCID @@ -3811,6 +3836,11 @@ x_draw_glyph_string (struct glyph_string *s) x_draw_glyphless_glyph_string_foreground (s); break; + case CANVAS_GLYPH: + x_draw_glyph_string_background (s, true); + x_draw_canvas_glyph_string_foreground (s); + break; + default: emacs_abort (); } --=-=-=--