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>
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/>.
31 (defun svg-create (width height
&rest args
)
32 "Create a new, empty SVG image with dimensions WIDTHxHEIGHT.
33 ARGS can be used to provide `stroke' and `stroke-width' parameters to
34 any further elements added."
39 (xmlns .
"http://www.w3.org/2000/svg")
40 ,@(svg--arguments nil args
))))
42 (defun svg-gradient (svg id type stops
)
43 "Add a gradient with ID to SVG.
44 TYPE is `linear' or `radial'. STOPS is a list of percentage/color
60 (dom-node 'stop
`((offset .
,(format "%s%%" (car stop
)))
61 (stop-color .
,(cdr stop
)))))
64 (defun svg-rectangle (svg x y width height
&rest args
)
65 "Create a rectangle on SVG, starting at position X/Y, of WIDTH/HEIGHT.
66 ARGS is a plist of modifiers. Possible values are
68 :stroke-width PIXELS. The line width.
69 :stroke-color COLOR. The line color.
70 :gradient ID. The gradient ID to use."
78 ,@(svg--arguments svg args
)))))
80 (defun svg-circle (svg x y radius
&rest args
)
81 "Create a circle of RADIUS on SVG.
82 X/Y denote the center of the circle."
89 ,@(svg--arguments svg args
)))))
91 (defun svg-ellipse (svg x y x-radius y-radius
&rest args
)
92 "Create an ellipse of X-RADIUS/Y-RADIUS on SVG.
93 X/Y denote the center of the ellipse."
101 ,@(svg--arguments svg args
)))))
103 (defun svg-line (svg x1 y1 x2 y2
&rest args
)
104 "Create a line of starting in X1/Y1, ending at X2/Y2 in SVG."
112 ,@(svg--arguments svg args
)))))
114 (defun svg-polyline (svg points
&rest args
)
115 "Create a polyline going through POINTS on SVG.
116 POINTS is a list of x/y pairs."
121 `((points .
,(mapconcat (lambda (pair)
122 (format "%s %s" (car pair
) (cdr pair
)))
125 ,@(svg--arguments svg args
)))))
127 (defun svg-polygon (svg points
&rest args
)
128 "Create a polygon going through POINTS on SVG.
129 POINTS is a list of x/y pairs."
134 `((points .
,(mapconcat (lambda (pair)
135 (format "%s %s" (car pair
) (cdr pair
)))
138 ,@(svg--arguments svg args
)))))
140 (defun svg-embed (svg image image-type datap
&rest args
)
141 "Insert IMAGE into the SVG structure.
142 IMAGE should be a file name if DATAP is nil, and a binary string
143 otherwise. IMAGE-TYPE should be a MIME image type, like
144 \"image/jpeg\" or the like."
149 `((xlink:href .
,(svg--image-data image image-type datap
))
150 ,@(svg--arguments svg args
)))))
152 (defun svg--append (svg node
)
153 (let ((old (and (dom-attr node
'id
)
155 (concat "\\`" (regexp-quote (dom-attr node
'id
))
158 (dom-set-attributes old
(dom-attributes node
))
159 (dom-append-child svg node
)))
160 (svg-possibly-update-image svg
))
162 (defun svg--image-data (image image-type datap
)
164 (set-buffer-multibyte nil
)
167 (insert-file-contents image
))
168 (base64-encode-region (point-min) (point-max) t
)
169 (goto-char (point-min))
170 (insert "data:" image-type
";base64,")
173 (defun svg--arguments (svg args
)
174 (let ((stroke-width (or (plist-get args
:stroke-width
)
175 (dom-attr svg
'stroke-width
)))
176 (stroke-color (or (plist-get args
:stroke-color
)
177 (dom-attr svg
'stroke-color
)))
178 (fill-color (plist-get args
:fill-color
))
181 (push (cons 'stroke-width stroke-width
) attr
))
183 (push (cons 'stroke stroke-color
) attr
))
185 (push (cons 'fill fill-color
) attr
))
186 (when (plist-get args
:gradient
)
189 ;; We need a way to specify the gradient direction here...
194 (fill .
,(format "url(#%s)"
195 (plist-get args
:gradient
))))
197 (cl-loop for
(key value
) on args by
#'cddr
198 unless
(memq key
'(:stroke-color
:stroke-width
:gradient
200 ;; Drop the leading colon.
201 do
(push (cons (intern (substring (symbol-name key
) 1) obarray
)
206 (defun svg--def (svg def
)
208 (or (dom-by-tag svg
'defs
)
209 (let ((node (dom-node 'defs
)))
210 (dom-add-child-before svg node
)
215 (defun svg-image (svg)
216 "Return an image object from SVG."
223 (defun svg-insert-image (svg)
224 "Insert SVG as an image at point.
225 If the SVG is later changed, the image will also be updated."
226 (let ((image (svg-image svg
))
227 (marker (point-marker)))
229 (dom-set-attribute svg
:image marker
)))
231 (defun svg-possibly-update-image (svg)
232 (let ((marker (dom-attr svg
:image
)))
234 (buffer-live-p (marker-buffer marker
)))
235 (with-current-buffer (marker-buffer marker
)
236 (put-text-property marker
(1+ marker
) 'display
(svg-image svg
))))))
238 (defun svg-print (dom)
239 "Convert DOM into a string containing the xml representation."
240 (insert (format "<%s" (car dom
)))
241 (dolist (attr (nth 1 dom
))
242 ;; Ignore attributes that start with a colon.
243 (unless (= (aref (format "%s" (car attr
)) 0) ?
:)
244 (insert (format " %s=\"%s\"" (car attr
) (cdr attr
)))))
246 (dolist (elem (nthcdr 2 dom
))
249 (insert (format "</%s>" (car dom
))))