Merge from origin/emacs-25
[emacs.git] / lisp / svg.el
bloba92c6dfb61006e11e8ef199a969e1fb24441e67f
1 ;;; svg.el --- SVG image creation functions -*- lexical-binding: t -*-
3 ;; Copyright (C) 2016 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: image
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;;; Code:
27 (require 'cl-lib)
28 (require 'xml)
29 (require 'dom)
30 (require 'subr-x)
32 (defun svg-create (width height &rest args)
33 "Create a new, empty SVG image with dimensions WIDTHxHEIGHT.
34 ARGS can be used to provide `stroke' and `stroke-width' parameters to
35 any further elements added."
36 (dom-node 'svg
37 `((width . ,width)
38 (height . ,height)
39 (version . "1.1")
40 (xmlns . "http://www.w3.org/2000/svg")
41 ,@(svg--arguments nil args))))
43 (defun svg-gradient (svg id type stops)
44 "Add a gradient with ID to SVG.
45 TYPE is `linear' or `radial'. STOPS is a list of percentage/color
46 pairs."
47 (svg--def
48 svg
49 (apply
50 'dom-node
51 (if (eq type 'linear)
52 'linearGradient
53 'radialGradient)
54 `((id . ,id)
55 (x1 . 0)
56 (x2 . 0)
57 (y1 . 0)
58 (y2 . 1))
59 (mapcar
60 (lambda (stop)
61 (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
62 (stop-color . ,(cdr stop)))))
63 stops))))
65 (defun svg-rectangle (svg x y width height &rest args)
66 "Create a rectangle on SVG, starting at position X/Y, of WIDTH/HEIGHT.
67 ARGS is a plist of modifiers. Possible values are
69 :stroke-width PIXELS. The line width.
70 :stroke-color COLOR. The line color.
71 :gradient ID. The gradient ID to use."
72 (svg--append
73 svg
74 (dom-node 'rect
75 `((width . ,width)
76 (height . ,height)
77 (x . ,x)
78 (y . ,y)
79 ,@(svg--arguments svg args)))))
81 (defun svg-circle (svg x y radius &rest args)
82 "Create a circle of RADIUS on SVG.
83 X/Y denote the center of the circle."
84 (svg--append
85 svg
86 (dom-node 'circle
87 `((cx . ,x)
88 (cy . ,y)
89 (r . ,radius)
90 ,@(svg--arguments svg args)))))
92 (defun svg-ellipse (svg x y x-radius y-radius &rest args)
93 "Create an ellipse of X-RADIUS/Y-RADIUS on SVG.
94 X/Y denote the center of the ellipse."
95 (svg--append
96 svg
97 (dom-node 'ellipse
98 `((cx . ,x)
99 (cy . ,y)
100 (rx . ,x-radius)
101 (ry . ,y-radius)
102 ,@(svg--arguments svg args)))))
104 (defun svg-line (svg x1 y1 x2 y2 &rest args)
105 "Create a line of starting in X1/Y1, ending at X2/Y2 in SVG."
106 (svg--append
108 (dom-node 'line
109 `((x1 . ,x1)
110 (x2 . ,y1)
111 (y1 . ,x2)
112 (y2 . ,y2)
113 ,@(svg--arguments svg args)))))
115 (defun svg-polyline (svg points &rest args)
116 "Create a polyline going through POINTS on SVG.
117 POINTS is a list of x/y pairs."
118 (svg--append
120 (dom-node
121 'polyline
122 `((points . ,(mapconcat (lambda (pair)
123 (format "%s %s" (car pair) (cdr pair)))
124 points
125 ", "))
126 ,@(svg--arguments svg args)))))
128 (defun svg-polygon (svg points &rest args)
129 "Create a polygon going through POINTS on SVG.
130 POINTS is a list of x/y pairs."
131 (svg--append
133 (dom-node
134 'polygon
135 `((points . ,(mapconcat (lambda (pair)
136 (format "%s %s" (car pair) (cdr pair)))
137 points
138 ", "))
139 ,@(svg--arguments svg args)))))
141 (defun svg-embed (svg image image-type datap &rest args)
142 "Insert IMAGE into the SVG structure.
143 IMAGE should be a file name if DATAP is nil, and a binary string
144 otherwise. IMAGE-TYPE should be a MIME image type, like
145 \"image/jpeg\" or the like."
146 (svg--append
148 (dom-node
149 'image
150 `((xlink:href . ,(svg--image-data image image-type datap))
151 ,@(svg--arguments svg args)))))
153 (defun svg-text (svg text &rest args)
154 "Add TEXT to SVG."
155 (svg--append
157 (dom-node
158 'text
159 `(,@(svg--arguments svg args))
160 text)))
162 (defun svg--append (svg node)
163 (let ((old (and (dom-attr node 'id)
164 (dom-by-id svg
165 (concat "\\`" (regexp-quote (dom-attr node 'id))
166 "\\'")))))
167 (if old
168 (setcdr (car old) (cdr node))
169 (dom-append-child svg node)))
170 (svg-possibly-update-image svg))
172 (defun svg--image-data (image image-type datap)
173 (with-temp-buffer
174 (set-buffer-multibyte nil)
175 (if datap
176 (insert image)
177 (insert-file-contents image))
178 (base64-encode-region (point-min) (point-max) t)
179 (goto-char (point-min))
180 (insert "data:" image-type ";base64,")
181 (buffer-string)))
183 (defun svg--arguments (svg args)
184 (let ((stroke-width (or (plist-get args :stroke-width)
185 (dom-attr svg 'stroke-width)))
186 (stroke-color (or (plist-get args :stroke-color)
187 (dom-attr svg 'stroke-color)))
188 (fill-color (plist-get args :fill-color))
189 attr)
190 (when stroke-width
191 (push (cons 'stroke-width stroke-width) attr))
192 (when stroke-color
193 (push (cons 'stroke stroke-color) attr))
194 (when fill-color
195 (push (cons 'fill fill-color) attr))
196 (when (plist-get args :gradient)
197 (setq attr
198 (append
199 ;; We need a way to specify the gradient direction here...
200 `((x1 . 0)
201 (x2 . 0)
202 (y1 . 0)
203 (y2 . 1)
204 (fill . ,(format "url(#%s)"
205 (plist-get args :gradient))))
206 attr)))
207 (cl-loop for (key value) on args by #'cddr
208 unless (memq key '(:stroke-color :stroke-width :gradient
209 :fill-color))
210 ;; Drop the leading colon.
211 do (push (cons (intern (substring (symbol-name key) 1) obarray)
212 value)
213 attr))
214 attr))
216 (defun svg--def (svg def)
217 (dom-append-child
218 (or (dom-by-tag svg 'defs)
219 (let ((node (dom-node 'defs)))
220 (dom-add-child-before svg node)
221 node))
222 def)
223 svg)
225 (defun svg-image (svg)
226 "Return an image object from SVG."
227 (create-image
228 (with-temp-buffer
229 (svg-print svg)
230 (buffer-string))
231 'svg t))
233 (defun svg-insert-image (svg)
234 "Insert SVG as an image at point.
235 If the SVG is later changed, the image will also be updated."
236 (let ((image (svg-image svg))
237 (marker (point-marker)))
238 (insert-image image)
239 (dom-set-attribute svg :image marker)))
241 (defun svg-possibly-update-image (svg)
242 (let ((marker (dom-attr svg :image)))
243 (when (and marker
244 (buffer-live-p (marker-buffer marker)))
245 (with-current-buffer (marker-buffer marker)
246 (put-text-property marker (1+ marker) 'display (svg-image svg))))))
248 (defun svg-print (dom)
249 "Convert DOM into a string containing the xml representation."
250 (if (stringp dom)
251 (insert dom)
252 (insert (format "<%s" (car dom)))
253 (dolist (attr (nth 1 dom))
254 ;; Ignore attributes that start with a colon.
255 (unless (= (aref (format "%s" (car attr)) 0) ?:)
256 (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
257 (insert ">")
258 (dolist (elem (nthcdr 2 dom))
259 (insert " ")
260 (svg-print elem))
261 (insert (format "</%s>" (car dom)))))
263 (defun svg-remove (svg id)
264 "Remove the element identified by ID from SVG."
265 (when-let ((node (car (dom-by-id
267 (concat "\\`" (regexp-quote id)
268 "\\'")))))
269 (dom-remove-node svg node)))
271 (provide 'svg)
273 ;;; svg.el ends here