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 dimentions WIDTHxHEIGHT.
33 ARGS can be used to provide `stroke' and `stroke-width' parameters to
34 any further elements added."
39 (xmlsn . "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--append (svg node)
141 (let ((old (and (dom-attr node 'id)
143 (concat "\\`" (regexp-quote (dom-attr node 'id))
146 (dom-set-attributes old (dom-attributes node))
147 (dom-append-child svg node)))
148 (svg-possibly-update-image svg))
150 (defun svg--arguments (svg args)
151 (let ((stroke-width (or (plist-get args :stroke-width)
152 (dom-attr svg 'stroke-width)))
153 (stroke-color (or (plist-get args :stroke-color)
154 (dom-attr svg 'stroke-color)))
155 (fill-color (plist-get args :fill-color))
158 (push (cons 'stroke-width stroke-width) attr))
160 (push (cons 'stroke stroke-color) attr))
162 (push (cons 'fill fill-color) attr))
163 (when (plist-get args :gradient)
166 ;; We need a way to specify the gradient direction here...
171 (fill . ,(format "url(#%s)"
172 (plist-get args :gradient))))
174 (cl-loop for (key value) on args by #'cddr
175 unless (memq key '(:stroke-color :stroke-width :gradient
177 ;; Drop the leading colon.
178 do (push (cons (intern (substring (symbol-name key) 1) obarray)
183 (defun svg--def (svg def)
185 (or (dom-by-tag svg 'defs)
186 (let ((node (dom-node 'defs)))
187 (dom-add-child-before svg node)
192 (defun svg-image (svg)
193 "Return an image object from SVG."
200 (defun svg-insert-image (svg)
201 "Insert SVG as an image at point.
202 If the SVG is later changed, the image will also be updated."
203 (let ((image (svg-image svg))
204 (marker (point-marker)))
206 (dom-set-attribute svg :image marker)))
208 (defun svg-possibly-update-image (svg)
209 (let ((marker (dom-attr svg :image)))
211 (buffer-live-p (marker-buffer marker)))
212 (with-current-buffer (marker-buffer marker)
213 (put-text-property marker (1+ marker) 'display (svg-image svg))))))
215 (defun svg-print (dom)
216 "Convert DOM into a string containing the xml representation."
217 (insert (format "<%s" (car dom)))
218 (dolist (attr (nth 1 dom))
219 ;; Ignore attributes that start with a colon.
220 (unless (= (aref (format "%s" (car attr)) 0) ?:)
221 (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
223 (dolist (elem (nthcdr 2 dom))
226 (insert (format "</%s>" (car dom))))