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/>.
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."
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
61 (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
62 (stop-color . ,(cdr stop)))))
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."
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."
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."
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."
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."
122 `((points . ,(mapconcat (lambda (pair)
123 (format "%s %s" (car pair) (cdr pair)))
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."
135 `((points . ,(mapconcat (lambda (pair)
136 (format "%s %s" (car pair) (cdr pair)))
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."
150 `((xlink:href . ,(svg--image-data image image-type datap))
151 ,@(svg--arguments svg args)))))
153 (defun svg-text (svg text &rest args)
159 `(,@(svg--arguments svg args))
162 (defun svg--append (svg node)
163 (let ((old (and (dom-attr node 'id)
165 (concat "\\`" (regexp-quote (dom-attr node 'id))
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)
174 (set-buffer-multibyte nil)
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,")
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))
191 (push (cons 'stroke-width stroke-width) attr))
193 (push (cons 'stroke stroke-color) attr))
195 (push (cons 'fill fill-color) attr))
196 (when (plist-get args :gradient)
199 ;; We need a way to specify the gradient direction here...
204 (fill . ,(format "url(#%s)"
205 (plist-get args :gradient))))
207 (cl-loop for (key value) on args by #'cddr
208 unless (memq key '(:stroke-color :stroke-width :gradient
210 ;; Drop the leading colon.
211 do (push (cons (intern (substring (symbol-name key) 1) obarray)
216 (defun svg--def (svg def)
218 (or (dom-by-tag svg 'defs)
219 (let ((node (dom-node 'defs)))
220 (dom-add-child-before svg node)
225 (defun svg-image (svg)
226 "Return an image object from SVG."
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)))
239 (dom-set-attribute svg :image marker)))
241 (defun svg-possibly-update-image (svg)
242 (let ((marker (dom-attr svg :image)))
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."
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)))))
258 (dolist (elem (nthcdr 2 dom))
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)
269 (dom-remove-node svg node)))