unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
blob 45870e0bfe899b397a50d16afc47b005c2119cba 15550 bytes (raw)
name: lisp/svg.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
 
;;; svg.el --- SVG image creation functions -*- lexical-binding: t -*-

;; Copyright (C) 2014-2020 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;;         Felix E. Klee <felix.klee@inka.de>
;; Keywords: image
;; Version: 1.0
;; Package-Requires: ((emacs "25"))

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This package allows creating SVG images in Emacs.  SVG images are
;; vector-based XML files, really, so you could create them directly
;; as XML.  However, that's really tedious, as there are some fiddly
;; bits.

;; In addition, the `svg-insert-image' function allows inserting an
;; SVG image into a buffer that's updated "on the fly" as you
;; add/alter elements to the image, which is useful when composing the
;; images.

;; Here are some usage examples:

;; Create the base image structure, add a gradient spec, and insert it
;; into the buffer:
;;
;;     (setq svg (svg-create 800 800 :stroke "orange" :stroke-width 5))
;;     (svg-gradient svg "gradient" 'linear '(0 . "red") '(100 . "blue"))
;;     (save-excursion (goto-char (point-max)) (svg-insert-image svg))

;; Then add various elements to the structure:
;;
;;     (svg-rectangle svg 100 100 500 500 :gradient "gradient" :id "rec1")
;;     (svg-circle svg 500 500 100 :id "circle1")
;;     (svg-ellipse svg 100 100 50 90 :stroke "red" :id "ellipse1")
;;     (svg-line svg 100 190 50 100 :id "line1" :stroke "yellow")
;;     (svg-polyline svg '((200 . 100) (500 . 450) (80 . 100))
;;                   :stroke "green" :id "poly1")
;;     (svg-polygon svg '((100 . 100) (200 . 150) (150 . 90))
;;                  :stroke "blue" :fill "red" :id "gon1")

;;; Code:

(require 'cl-lib)
(require 'xml)
(require 'dom)

(defun svg-create (width height &rest args)
  "Create a new, empty SVG image with dimensions WIDTH x HEIGHT.
ARGS can be used to provide `stroke' and `stroke-width' parameters to
any further elements added."
  (dom-node 'svg
	    `((width . ,width)
	      (height . ,height)
	      (version . "1.1")
	      (xmlns . "http://www.w3.org/2000/svg")
              ,@(unless (plist-get args :xmlns:xlink)
                  '((xmlns:xlink . "http://www.w3.org/1999/xlink")))
              ,@(svg--arguments nil args))))

(defun svg-gradient (svg id type stops)
  "Add a gradient with ID to SVG.
TYPE is `linear' or `radial'.
STOPS is a list of percentage/color pairs."
  (svg--def
   svg
   (apply
    'dom-node
    (if (eq type 'linear)
	'linearGradient
      'radialGradient)
    `((id . ,id)
      (x1 . 0)
      (x2 . 0)
      (y1 . 0)
      (y2 . 1))
    (mapcar
     (lambda (stop)
       (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
			 (stop-color . ,(cdr stop)))))
     stops))))

(defun svg-rectangle (svg x y width height &rest args)
  "Create a rectangle on SVG, starting at position X/Y, of WIDTH/HEIGHT.
ARGS is a plist of modifiers.  Possible values are

:stroke-width PIXELS   The line width.
:stroke-color COLOR    The line color.
:gradient ID           The gradient ID to use."
  (svg--append
   svg
   (dom-node 'rect
	     `((width . ,width)
	       (height . ,height)
	       (x . ,x)
	       (y . ,y)
	       ,@(svg--arguments svg args)))))

(defun svg-circle (svg x y radius &rest args)
  "Create a circle of RADIUS on SVG.
X/Y denote the center of the circle."
  (svg--append
   svg
   (dom-node 'circle
	     `((cx . ,x)
	       (cy . ,y)
	       (r . ,radius)
	       ,@(svg--arguments svg args)))))

(defun svg-ellipse (svg x y x-radius y-radius &rest args)
  "Create an ellipse of X-RADIUS/Y-RADIUS on SVG.
X/Y denote the center of the ellipse."
  (svg--append
   svg
   (dom-node 'ellipse
	     `((cx . ,x)
	       (cy . ,y)
	       (rx . ,x-radius)
	       (ry . ,y-radius)
	       ,@(svg--arguments svg args)))))

(defun svg-line (svg x1 y1 x2 y2 &rest args)
  "Create a line starting in X1/Y1, ending at X2/Y2 on SVG."
  (svg--append
   svg
   (dom-node 'line
	     `((x1 . ,x1)
	       (x2 . ,x2)
	       (y1 . ,y1)
	       (y2 . ,y2)
	       ,@(svg--arguments svg args)))))

(defun svg-polyline (svg points &rest args)
  "Create a polyline going through POINTS on SVG.
POINTS is a list of x/y pairs."
  (svg--append
   svg
   (dom-node
    'polyline
    `((points . ,(mapconcat (lambda (pair)
			      (format "%s,%s" (car pair) (cdr pair)))
			    points
			    " "))
      ,@(svg--arguments svg args)))))

(defun svg-polygon (svg points &rest args)
  "Create a polygon going through POINTS on SVG.
POINTS is a list of x/y pairs."
  (svg--append
   svg
   (dom-node
    'polygon
    `((points . ,(mapconcat (lambda (pair)
			      (format "%s %s" (car pair) (cdr pair)))
			    points
			    ", "))
      ,@(svg--arguments svg args)))))

(defun svg-embed (svg image image-type datap &rest args)
  "Insert IMAGE into the SVG structure.
IMAGE should be a file name if DATAP is nil, and a binary string
otherwise.  IMAGE-TYPE should be a MIME image type, like
\"image/jpeg\" or the like."
  (svg--append
   svg
   (dom-node
    'image
    `((xlink:href . ,(svg--image-data image image-type datap))
      ,@(svg--arguments svg args)))))

(defun svg-text (svg text &rest args)
  "Add TEXT to SVG."
  (svg--append
   svg
   (dom-node
    'text
    `(,@(svg--arguments svg args))
    (svg--encode-text text))))

(defun svg--encode-text (text)
  ;; Apparently the SVG renderer needs to have all non-ASCII
  ;; characters encoded, and only certain special characters.
  (with-temp-buffer
    (insert text)
    (dolist (substitution '(("&" . "&amp;")
			    ("<" . "&lt;")
			    (">" . "&gt;")))
      (goto-char (point-min))
      (while (search-forward (car substitution) nil t)
	(replace-match (cdr substitution) t t nil)))
    (goto-char (point-min))
    (while (not (eobp))
      (let ((char (following-char)))
        (if (< char 128)
            (forward-char 1)
          (delete-char 1)
          (insert "&#" (format "%d" char) ";"))))
    (buffer-string)))

(defun svg--append (svg node)
  ;; id is expected to be unique.
  (let ((old (and (dom-attr node 'id)
		  (dom-by-id svg
                             (concat "\\`" (regexp-quote (dom-attr node 'id))
                                     "\\'")))))
    (if old
        ;; Remove old node. New node might be a different type.
        (mapc (lambda (a)
                  (dom-remove-node svg a))
                old))
    (dom-append-child svg node))
  (svg-possibly-update-image svg))

(defun svg--image-data (image image-type datap)
  (with-temp-buffer
    (set-buffer-multibyte nil)
    (if datap
        (insert image)
      (insert-file-contents image))
    (base64-encode-region (point-min) (point-max) t)
    (goto-char (point-min))
    (insert "data:" image-type ";base64,")
    (buffer-string)))

(defun svg--arguments (svg args)
  (let ((stroke-width (or (plist-get args :stroke-width)
			  (dom-attr svg 'stroke-width)))
	(stroke-color (or (plist-get args :stroke-color)
                          (dom-attr svg 'stroke-color)))
        (fill-color (plist-get args :fill-color))
	attr)
    (when stroke-width
      (push (cons 'stroke-width stroke-width) attr))
    (when stroke-color
      (push (cons 'stroke stroke-color) attr))
    (when fill-color
      (push (cons 'fill fill-color) attr))
    (when (plist-get args :gradient)
      (setq attr
	    (append
	     ;; We need a way to specify the gradient direction here...
	     `((x1 . 0)
	       (x2 . 0)
	       (y1 . 0)
	       (y2 . 1)
	       (fill . ,(format "url(#%s)"
				(plist-get args :gradient))))
	     attr)))
    (cl-loop for (key value) on args by #'cddr
	     unless (memq key '(:stroke-color :stroke-width :gradient
                                              :fill-color))
	     ;; Drop the leading colon.
	     do (push (cons (intern (substring (symbol-name key) 1) obarray)
			    value)
		      attr))
    attr))

(defun svg--def (svg def)
  (dom-append-child
   (or (dom-by-tag svg 'defs)
       (let ((node (dom-node 'defs)))
	 (dom-add-child-before svg node)
	 node))
   def)
  svg)

(defun svg-image (svg &rest props)
  "Return an image object from SVG.
PROPS is passed on to `create-image' as its PROPS list."
  (apply
   #'create-image
   (with-temp-buffer
     (svg-print svg)
     (buffer-string))
   'svg t props))

(defun svg-insert-image (svg)
  "Insert SVG as an image at point.
If the SVG is later changed, the image will also be updated."
  (let ((image (svg-image svg))
	(marker (point-marker)))
    (insert-image image)
    (dom-set-attribute svg :image marker)))

(defun svg-possibly-update-image (svg)
  (let ((marker (dom-attr svg :image)))
    (when (and marker
	       (buffer-live-p (marker-buffer marker)))
      (with-current-buffer (marker-buffer marker)
	(put-text-property marker (1+ marker) 'display (svg-image svg))))))

(defun svg-print (dom)
  "Convert DOM into a string containing the xml representation."
  (if (stringp dom)
      (insert dom)
    (insert (format "<%s" (car dom)))
    (dolist (attr (nth 1 dom))
      ;; Ignore attributes that start with a colon.
      (unless (or (= (aref (format "%s" (car attr)) 0) ?:)
                  (null (cdr attr)))
        (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
    (insert ">")
    (dolist (elem (nthcdr 2 dom))
      (insert " ")
      (svg-print elem))
    (insert (format "</%s>" (car dom)))))

(defun svg-remove (svg id)
  "Remove the element identified by ID from SVG."
  (let* ((node (car (dom-by-id
                     svg
                     (concat "\\`" (regexp-quote id)
                             "\\'")))))
    (when node (dom-remove-node svg node))))

;; Function body copied from `org-plist-delete' in Emacs 26.1.
(defun svg--plist-delete (plist property)
  "Delete PROPERTY from PLIST.
This is in contrast to merely setting it to 0."
  (let (p)
    (while plist
      (if (not (eq property (car plist)))
          (setq p (plist-put p (car plist) (nth 1 plist))))
      (setq plist (cddr plist)))
    p))

(defun svg--path-command-symbol (command-symbol command-args)
  (let ((char (symbol-name command-symbol))
        (relative (if (plist-member command-args :relative)
                      (plist-get command-args :relative)
                    (plist-get command-args :default-relative))))
    (intern (if relative (downcase char) (upcase char)))))

(defun svg--elliptical-arc-coordinates
    (rx ry x y &rest args)
  (list
   rx ry
   (or (plist-get args :x-axis-rotation) 0)
   (if (plist-get args :large-arc) 1 0)
   (if (plist-get args :sweep) 1 0)
   x y))

(defun svg--elliptical-arc-command (coordinates-list &rest args)
  (cons
   (svg--path-command-symbol 'a args)
   (apply 'append
          (mapcar
           (lambda (coordinates)
             (apply 'svg--elliptical-arc-coordinates
                    coordinates))
           coordinates-list))))

(defun svg--moveto-command (coordinates-list &rest args)
  (cons
   (svg--path-command-symbol 'm args)
   (apply 'append
          (mapcar
           (lambda (coordinates)
             (list (car coordinates) (cdr coordinates)))
           coordinates-list))))

(defun svg--closepath-command (&rest args)
  (list (svg--path-command-symbol 'z args)))

(defun svg--lineto-command (coordinates-list &rest args)
  (cons
   (svg--path-command-symbol 'l args)
   (apply 'append
          (mapcar
           (lambda (coordinates)
             (list (car coordinates) (cdr coordinates)))
           coordinates-list))))

(defun svg--horizontal-lineto-command (coordinate-list &rest args)
  (cons
   (svg--path-command-symbol 'h args)
   coordinate-list))

(defun svg--vertical-lineto-command (coordinate-list &rest args)
  (cons
   (svg--path-command-symbol 'v args)
   coordinate-list))

(defun svg--curveto-command (coordinates-list &rest args)
  (cons
   (svg--path-command-symbol 'c args)
   (apply 'append coordinates-list)))

(defun svg--smooth-curveto-command (coordinates-list &rest args)
  (cons
   (svg--path-command-symbol 's args)
   (apply 'append coordinates-list)))

(defun svg--quadratic-bezier-curveto-command (coordinates-list
                                              &rest args)
  (cons
   (svg--path-command-symbol 'q args)
   (apply 'append coordinates-list)))

(defun svg--smooth-quadratic-bezier-curveto-command (coordinates-list
                                                     &rest args)
  (cons
   (svg--path-command-symbol 't args)
   (apply 'append coordinates-list)))

(defun svg--eval-path-command (command default-relative)
  (cl-letf
      (((symbol-function 'moveto) #'svg--moveto-command)
       ((symbol-function 'closepath) #'svg--closepath-command)
       ((symbol-function 'lineto) #'svg--lineto-command)
       ((symbol-function 'horizontal-lineto)
        #'svg--horizontal-lineto-command)
       ((symbol-function 'vertical-lineto)
        #'svg--vertical-lineto-command)
       ((symbol-function 'curveto) #'svg--curveto-command)
       ((symbol-function 'smooth-curveto)
        #'svg--smooth-curveto-command)
       ((symbol-function 'quadratic-bezier-curveto)
        #'svg--quadratic-bezier-curveto-command)
       ((symbol-function 'smooth-quadratic-bezier-curveto)
        #'svg--smooth-quadratic-bezier-curveto-command)
       ((symbol-function 'elliptical-arc)
        #'svg--elliptical-arc-command)
       (extended-command (append command (list :default-relative
                                               default-relative))))
    (mapconcat 'prin1-to-string (apply extended-command) " ")))

(defun svg-path (svg commands &rest args)
  "Add the outline of a shape to SVG according to COMMANDS.
Coordinates by default are absolute.  ARGS is a plist of
modifiers.  If :relative is t, then coordinates are relative to
the last position, or -- initially -- to the origin."
  (let* ((default-relative (plist-get args :relative))
         (stripped-args (svg--plist-delete args :relative))
         (d (mapconcat 'identity
                       (mapcar
                        (lambda (command)
                          (svg--eval-path-command command
                                                  default-relative))
                        commands) " ")))
    (svg--append
     svg
     (dom-node 'path
               `((d . ,d)
                 ,@(svg--arguments svg stripped-args))))))

(defun svg-clip-path (svg &rest args)
  "Add a clipping path to SVG, where ARGS is a plist of modifiers.
If applied to a shape via the :clip-path property, parts of that
shape which lie outside of the clipping path are not drawn."
  (let ((new-dom-node (dom-node 'clipPath
                                `(,@(svg--arguments svg args)))))
    (svg--append svg new-dom-node)
    new-dom-node))

(defun svg-node (svg tag &rest args)
  "Add the custom node TAG to SVG."
  (let ((new-dom-node (dom-node tag
                                `(,@(svg--arguments svg args)))))
    (svg--append svg new-dom-node)
    new-dom-node))

(provide 'svg)

;;; svg.el ends here

debug log:

solving 45870e0bfe ...
found 45870e0bfe in https://yhetil.org/emacs-devel/CADm7Y4nWYswRR-uk5ACZ5YTvC94mGX-ZRRUOm=hB8LkOLEZNSg@mail.gmail.com/
found 7aadbc2359 in https://git.savannah.gnu.org/cgit/emacs.git
preparing index
index prepared:
100644 7aadbc23593a79ebad6518ff51967961ee764c45	lisp/svg.el

applying [1/1] https://yhetil.org/emacs-devel/CADm7Y4nWYswRR-uk5ACZ5YTvC94mGX-ZRRUOm=hB8LkOLEZNSg@mail.gmail.com/
diff --git a/lisp/svg.el b/lisp/svg.el
index 7aadbc2359..45870e0bfe 100644

Checking patch lisp/svg.el...
Applied patch lisp/svg.el cleanly.

index at:
100644 45870e0bfe899b397a50d16afc47b005c2119cba	lisp/svg.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).