code.delx.au - gnu-emacs/blob - 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
  31 (defun svg-create (width height &rest args)
  32   "Create a new, empty SVG image with dimensions WIDTHxHEIGHT.
  33 ARGS can be used to provide `stroke' and `stroke-width' parameters to
  34 any further elements added."
  35   (dom-node 'svg
  36             `((width . ,width)
  37               (height . ,height)
  38               (version . "1.1")
  39               (xmlns . "http://www.w3.org/2000/svg")
  40               ,@(svg--arguments nil args))))
  41
  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
  45 pairs."
  46   (svg--def
  47    svg
  48    (apply
  49     'dom-node
  50     (if (eq type 'linear)
  51         'linearGradient
  52       'radialGradient)
  53     `((id . ,id)
  54       (x1 . 0)
  55       (x2 . 0)
  56       (y1 . 0)
  57       (y2 . 1))
  58     (mapcar
  59      (lambda (stop)
  60        (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
  61                          (stop-color . ,(cdr stop)))))
  62      stops))))
  63
  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
  67
  68 :stroke-width PIXELS.  The line width.
  69 :stroke-color COLOR.  The line color.
  70 :gradient ID.  The gradient ID to use."
  71   (svg--append
  72    svg
  73    (dom-node 'rect
  74              `((width . ,width)
  75                (height . ,height)
  76                (x . ,x)
  77                (y . ,y)
  78                ,@(svg--arguments svg args)))))
  79
  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."
  83   (svg--append
  84    svg
  85    (dom-node 'circle
  86              `((cx . ,x)
  87                (cy . ,y)
  88                (r . ,radius)
  89                ,@(svg--arguments svg args)))))
  90
  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."
  94   (svg--append
  95    svg
  96    (dom-node 'ellipse
  97              `((cx . ,x)
  98                (cy . ,y)
  99                (rx . ,x-radius)
 100                (ry . ,y-radius)
 101                ,@(svg--arguments svg args)))))
 102
 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."
 105   (svg--append
 106    svg
 107    (dom-node 'line
 108              `((x1 . ,x1)
 109                (x2 . ,y1)
 110                (y1 . ,x2)
 111                (y2 . ,y2)
 112                ,@(svg--arguments svg args)))))
 113
 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."
 117   (svg--append
 118    svg
 119    (dom-node
 120     'polyline
 121     `((points . ,(mapconcat (lambda (pair)
 122                               (format "%s %s" (car pair) (cdr pair)))
 123                             points
 124                             ", "))
 125       ,@(svg--arguments svg args)))))
 126
 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."
 130   (svg--append
 131    svg
 132    (dom-node
 133     'polygon
 134     `((points . ,(mapconcat (lambda (pair)
 135                               (format "%s %s" (car pair) (cdr pair)))
 136                             points
 137                             ", "))
 138       ,@(svg--arguments svg args)))))
 139
 140 (defun svg-embed (svg image image-type datap &rest args)
 141   "Insert IMAGE into the SVG structure.
 142 IMAGE should be a file name if DATAP is nil, and a binary string
 143 otherwise.  IMAGE-TYPE should be a MIME image type, like
 144 \"image/jpeg\" or the like."
 145   (svg--append
 146    svg
 147    (dom-node
 148     'image
 149     `((xlink:href . ,(svg--image-data image image-type datap))
 150       ,@(svg--arguments svg args)))))
 151
 152 (defun svg--append (svg node)
 153   (let ((old (and (dom-attr node 'id)
 154                   (dom-by-id svg
 155                              (concat "\\`" (regexp-quote (dom-attr node 'id))
 156                                      "\\'")))))
 157     (if old
 158         (dom-set-attributes old (dom-attributes node))
 159       (dom-append-child svg node)))
 160   (svg-possibly-update-image svg))
 161
 162 (defun svg--image-data (image image-type datap)
 163   (with-temp-buffer
 164     (set-buffer-multibyte nil)
 165     (if datap
 166         (insert image)
 167       (insert-file-contents image))
 168     (base64-encode-region (point-min) (point-max) t)
 169     (goto-char (point-min))
 170     (insert "data:" image-type ";base64,")
 171     (buffer-string)))
 172
 173 (defun svg--arguments (svg args)
 174   (let ((stroke-width (or (plist-get args :stroke-width)
 175                           (dom-attr svg 'stroke-width)))
 176         (stroke-color (or (plist-get args :stroke-color)
 177                           (dom-attr svg 'stroke-color)))
 178         (fill-color (plist-get args :fill-color))
 179         attr)
 180     (when stroke-width
 181       (push (cons 'stroke-width stroke-width) attr))
 182     (when stroke-color
 183       (push (cons 'stroke stroke-color) attr))
 184     (when fill-color
 185       (push (cons 'fill fill-color) attr))
 186     (when (plist-get args :gradient)
 187       (setq attr
 188             (append
 189              ;; We need a way to specify the gradient direction here...
 190              `((x1 . 0)
 191                (x2 . 0)
 192                (y1 . 0)
 193                (y2 . 1)
 194                (fill . ,(format "url(#%s)"
 195                                 (plist-get args :gradient))))
 196              attr)))
 197     (cl-loop for (key value) on args by #'cddr
 198              unless (memq key '(:stroke-color :stroke-width :gradient
 199                                               :fill-color))
 200              ;; Drop the leading colon.
 201              do (push (cons (intern (substring (symbol-name key) 1) obarray)
 202                             value)
 203                       attr))
 204     attr))
 205
 206 (defun svg--def (svg def)
 207   (dom-append-child
 208    (or (dom-by-tag svg 'defs)
 209        (let ((node (dom-node 'defs)))
 210          (dom-add-child-before svg node)
 211          node))
 212    def)
 213   svg)
 214
 215 (defun svg-image (svg)
 216   "Return an image object from SVG."
 217   (create-image
 218    (with-temp-buffer
 219      (svg-print svg)
 220      (buffer-string))
 221    'svg t))
 222
 223 (defun svg-insert-image (svg)
 224   "Insert SVG as an image at point.
 225 If the SVG is later changed, the image will also be updated."
 226   (let ((image (svg-image svg))
 227         (marker (point-marker)))
 228     (insert-image image)
 229     (dom-set-attribute svg :image marker)))
 230
 231 (defun svg-possibly-update-image (svg)
 232   (let ((marker (dom-attr svg :image)))
 233     (when (and marker
 234                (buffer-live-p (marker-buffer marker)))
 235       (with-current-buffer (marker-buffer marker)
 236         (put-text-property marker (1+ marker) 'display (svg-image svg))))))
 237
 238 (defun svg-print (dom)
 239   "Convert DOM into a string containing the xml representation."
 240   (insert (format "<%s" (car dom)))
 241   (dolist (attr (nth 1 dom))
 242     ;; Ignore attributes that start with a colon.
 243     (unless (= (aref (format "%s" (car attr)) 0) ?:)
 244       (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
 245   (insert ">")
 246   (dolist (elem (nthcdr 2 dom))
 247     (insert " ")
 248     (svg-print elem))
 249   (insert (format "</%s>" (car dom))))
 250
 251 (provide 'svg)
 252
 253 ;;; svg.el ends here