1 ;;; svg.el --- svg image creation functions
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Maintainer: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; Package-Requires: ((emacs "25"))
10 ;; This program 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 ;; This program 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/>.
25 ;; This pacakge allows creating SVG images in Emacs. SVG images are
26 ;; vector-based XML files, really, so you could create them directly
27 ;; as XML. However, that's really tedious, as there are some fiddly
30 ;; In addition, the `svg-insert-image' function allows inserting an
31 ;; SVG image into a buffer that's updated "on the fly" as you
32 ;; add/alter elements to the image, which is useful when composing the
35 ;; Here are some usage examples:
37 ;; Create the base image structure, add a gradient spec, and insert it
39 ;; (setq svg (svg-create 800 800 :stroke "orange" :stroke-width 5))
40 ;; (svg-gradient svg "gradient" 'linear '(0 . "red") '(100 . "blue"))
41 ;; (save-excursion (goto-char (point-max)) (svg-insert-image svg))
43 ;; Then add various elements to the structure:
44 ;; (svg-rectangle svg 100 100 500 500 :gradient "gradient" :id "rec1")
45 ;; (svg-circle svg 500 500 100 :id "circle1")
46 ;; (svg-ellipse svg 100 100 50 90 :stroke "red" :id "ellipse1")
47 ;; (svg-line svg 100 190 50 100 :id "line1" :stroke "yellow")
48 ;; (svg-polyline svg '((200 . 100) (500 . 450) (80 . 100))
49 ;; :stroke "green" :id "poly1")
50 ;; (svg-polygon svg '((100 . 100) (200 . 150) (150 . 90))
51 ;; :stroke "blue" :fill "red" :id "gon1")
59 (defun svg-create (width height &rest args)
60 "Create a new, empty SVG image with dimentions WIDTHxHEIGHT.
61 ARGS can be used to provide `stroke' and `stroke-width' parameters to
62 any further elements added."
67 (xmlsn . "http://www.w3.org/2000/svg")
68 ,@(svg-arguments nil args))))
70 (defun svg-gradient (svg id type &rest stops)
71 "Add a gradient with ID to SVG.
72 TYPE is `linear' or `gradient'. STOPS is a list of percentage/color
88 (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
89 (stop-color . ,(cdr stop)))))
92 (defun svg-rectangle (svg x y width height &rest args)
93 "Create a rectangle on SVG."
101 ,@(svg-arguments svg args)))))
103 (defun svg-circle (svg x y radius &rest args)
104 "Create a circle of RADIUS on SVG.
105 X/Y denote the center of the circle."
112 ,@(svg-arguments svg args)))))
114 (defun svg-ellipse (svg x y x-radius y-radius &rest args)
115 "Create an ellipse of X-RADIUS/Y-RADIUS on SVG.
116 X/Y denote the center of the ellipse."
124 ,@(svg-arguments svg args)))))
126 (defun svg-line (svg x1 y1 x2 y2 &rest args)
127 "Create a line of starting in X1/Y1, ending at X2/Y2 on SVG."
135 ,@(svg-arguments svg args)))))
137 (defun svg-polyline (svg points &rest args)
138 "Create a polyline going through POINTS on SVG.
139 POINTS is a list of x/y pairs."
144 `((points . ,(mapconcat (lambda (pair)
145 (format "%s %s" (car pair) (cdr pair)))
148 ,@(svg-arguments svg args)))))
150 (defun svg-polygon (svg points &rest args)
151 "Create a polygon going through POINTS on SVG.
152 POINTS is a list of x/y pairs."
157 `((points . ,(mapconcat (lambda (pair)
158 (format "%s %s" (car pair) (cdr pair)))
161 ,@(svg-arguments svg args)))))
163 (defun svg-append (svg node)
164 (let ((old (and (dom-attr node 'id)
165 (dom-by-id svg (concat "\\`" (regexp-quote (dom-attr node 'id))
168 (dom-set-attributes old (dom-attributes node))
169 (dom-append-child svg node)))
170 (svg-possibly-update-image svg))
172 (defun svg-arguments (svg args)
173 (let ((stroke-width (or (plist-get args :stroke-width)
174 (dom-attr svg 'stroke-width)))
175 (stroke (or (plist-get args :stroke)
176 (dom-attr svg 'stroke)))
179 (push (cons 'stroke-width stroke-width) attr))
181 (push (cons 'stroke stroke) attr))
182 (when (plist-get args :gradient)
185 ;; We need a way to specify the gradient direction here...
190 (fill . ,(format "url(#%s)"
191 (plist-get args :gradient))))
193 (cl-loop for (key value) on args by #'cddr
194 unless (memq key '(:stroke :stroke-width :gradient))
195 ;; Drop the leading colon.
196 do (push (cons (intern (substring (symbol-name key) 1) obarray)
201 (defun svg-def (svg def)
203 (or (dom-by-tag svg 'defs)
204 (let ((node (dom-node 'defs)))
205 (dom-add-child-before svg node)
210 (defun svg-image (svg)
211 "Return an image object from SVG."
218 (defun svg-insert-image (svg)
219 "Insert SVG as an image at point.
220 If the SVG is later changed, the image will also be updated."
221 (let ((image (svg-image svg))
222 (marker (point-marker)))
224 (dom-set-attribute svg :image marker)))
226 (defun svg-possibly-update-image (svg)
227 (let ((marker (dom-attr svg :image)))
229 (buffer-live-p (marker-buffer marker)))
230 (with-current-buffer (marker-buffer marker)
231 (put-text-property marker (1+ marker) 'display (svg-image svg))))))
233 (defun svg-print (dom)
234 "Convert DOM into a string containing the xml representation."
235 (insert (format "<%s" (car dom)))
236 (dolist (attr (nth 1 dom))
237 ;; Ignore attributes that start with a colon.
238 (unless (= (aref (format "%s" (car attr)) 0) ?:)
239 (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
241 (dolist (elem (nthcdr 2 dom))
244 (insert (format "</%s>" (car dom))))