lisp/svg.el

   1 ;;; svg.el --- SVG image creation functions -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2016-2018 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 <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'cl-lib)
  28 (require 'xml)
  29 (require 'dom)
  30 (eval-when-compile (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 . ,x2)
 111                (y1 . ,y1)
 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     (svg--encode-text text))))
 161
 162 (defun svg--encode-text (text)
 163   ;; Apparently the SVG renderer needs to have all non-ASCII
 164   ;; characters encoded, and only certain special characters.
 165   (with-temp-buffer
 166     (insert text)
 167     (dolist (substitution '(("&" . "&amp;")
 168                             ("<" . "&lt;")
 169                             (">" . "&gt;")))
 170       (goto-char (point-min))
 171       (while (search-forward (car substitution) nil t)
 172         (replace-match (cdr substitution) t t nil)))
 173     (goto-char (point-min))
 174     (while (not (eobp))
 175       (let ((char (following-char)))
 176         (if (< char 128)
 177             (forward-char 1)
 178           (delete-char 1)
 179           (insert "&#" (format "%d" char) ";"))))
 180     (buffer-string)))
 181
 182 (defun svg--append (svg node)
 183   (let ((old (and (dom-attr node 'id)
 184                   (dom-by-id svg
 185                              (concat "\\`" (regexp-quote (dom-attr node 'id))
 186                                      "\\'")))))
 187     (if old
 188         (setcdr (car old) (cdr node))
 189       (dom-append-child svg node)))
 190   (svg-possibly-update-image svg))
 191
 192 (defun svg--image-data (image image-type datap)
 193   (with-temp-buffer
 194     (set-buffer-multibyte nil)
 195     (if datap
 196         (insert image)
 197       (insert-file-contents image))
 198     (base64-encode-region (point-min) (point-max) t)
 199     (goto-char (point-min))
 200     (insert "data:" image-type ";base64,")
 201     (buffer-string)))
 202
 203 (defun svg--arguments (svg args)
 204   (let ((stroke-width (or (plist-get args :stroke-width)
 205                           (dom-attr svg 'stroke-width)))
 206         (stroke-color (or (plist-get args :stroke-color)
 207                           (dom-attr svg 'stroke-color)))
 208         (fill-color (plist-get args :fill-color))
 209         attr)
 210     (when stroke-width
 211       (push (cons 'stroke-width stroke-width) attr))
 212     (when stroke-color
 213       (push (cons 'stroke stroke-color) attr))
 214     (when fill-color
 215       (push (cons 'fill fill-color) attr))
 216     (when (plist-get args :gradient)
 217       (setq attr
 218             (append
 219              ;; We need a way to specify the gradient direction here...
 220              `((x1 . 0)
 221                (x2 . 0)
 222                (y1 . 0)
 223                (y2 . 1)
 224                (fill . ,(format "url(#%s)"
 225                                 (plist-get args :gradient))))
 226              attr)))
 227     (cl-loop for (key value) on args by #'cddr
 228              unless (memq key '(:stroke-color :stroke-width :gradient
 229                                               :fill-color))
 230              ;; Drop the leading colon.
 231              do (push (cons (intern (substring (symbol-name key) 1) obarray)
 232                             value)
 233                       attr))
 234     attr))
 235
 236 (defun svg--def (svg def)
 237   (dom-append-child
 238    (or (dom-by-tag svg 'defs)
 239        (let ((node (dom-node 'defs)))
 240          (dom-add-child-before svg node)
 241          node))
 242    def)
 243   svg)
 244
 245 (defun svg-image (svg &rest props)
 246   "Return an image object from SVG.
 247 PROPS is passed on to `create-image' as its PROPS list."
 248   (apply
 249    #'create-image
 250    (with-temp-buffer
 251      (svg-print svg)
 252      (buffer-string))
 253    'svg t props))
 254
 255 (defun svg-insert-image (svg)
 256   "Insert SVG as an image at point.
 257 If the SVG is later changed, the image will also be updated."
 258   (let ((image (svg-image svg))
 259         (marker (point-marker)))
 260     (insert-image image)
 261     (dom-set-attribute svg :image marker)))
 262
 263 (defun svg-possibly-update-image (svg)
 264   (let ((marker (dom-attr svg :image)))
 265     (when (and marker
 266                (buffer-live-p (marker-buffer marker)))
 267       (with-current-buffer (marker-buffer marker)
 268         (put-text-property marker (1+ marker) 'display (svg-image svg))))))
 269
 270 (defun svg-print (dom)
 271   "Convert DOM into a string containing the xml representation."
 272   (if (stringp dom)
 273       (insert dom)
 274     (insert (format "<%s" (car dom)))
 275     (dolist (attr (nth 1 dom))
 276       ;; Ignore attributes that start with a colon.
 277       (unless (= (aref (format "%s" (car attr)) 0) ?:)
 278         (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
 279     (insert ">")
 280     (dolist (elem (nthcdr 2 dom))
 281       (insert " ")
 282       (svg-print elem))
 283     (insert (format "</%s>" (car dom)))))
 284
 285 (defun svg-remove (svg id)
 286   "Remove the element identified by ID from SVG."
 287   (when-let* ((node (car (dom-by-id
 288                           svg
 289                           (concat "\\`" (regexp-quote id)
 290                                   "\\'")))))
 291     (dom-remove-node svg node)))
 292
 293 (provide 'svg)
 294
 295 ;;; svg.el ends here