lisp/svg.el

   1 ;;; svg.el --- SVG image creation functions -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: image
   7
   8 ;; This file is part of GNU Emacs.
   9
  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.
  14
  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.
  19
  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/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'cl-lib)
  28 (require 'xml)
  29 (require 'dom)
  30 (require 'subr-x)
  31
  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))))
  42
  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))))
  64
  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
  68
  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)))))
  80
  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)))))
  91
  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)))))
 103
 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
 107    svg
 108    (dom-node 'line
 109              `((x1 . ,x1)
 110                (x2 . ,y1)
 111                (y1 . ,x2)
 112                (y2 . ,y2)
 113                ,@(svg--arguments svg args)))))
 114
 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
 119    svg
 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)))))
 127
 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
 132    svg
 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)))))
 140
 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
 147    svg
 148    (dom-node
 149     'image
 150     `((xlink:href . ,(svg--image-data image image-type datap))
 151       ,@(svg--arguments svg args)))))
 152
 153 (defun svg-text (svg text &rest args)
 154   "Add TEXT to SVG."
 155   (svg--append
 156    svg
 157    (dom-node
 158     'text
 159     `(,@(svg--arguments svg args))
 160     text)))
 161
 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))
 171
 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)))
 182
 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))
 215
 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)
 224
 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))
 232
 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)))
 240
 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))))))
 247
 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)))))
 262
 263 (defun svg-remove (svg id)
 264   "Remove the element identified by ID from SVG."
 265   (when-let ((node (car (dom-by-id
 266                          svg
 267                          (concat "\\`" (regexp-quote id)
 268                                  "\\'")))))
 269     (dom-remove-node svg node)))
 270
 271 (provide 'svg)
 272
 273 ;;; svg.el ends here