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--append (svg node)
 141   (let ((old (and (dom-attr node 'id)
 142                   (dom-by-id svg
 143                              (concat "\\`" (regexp-quote (dom-attr node 'id))
 144                                      "\\'")))))
 145     (if old
 146         (dom-set-attributes old (dom-attributes node))
 147       (dom-append-child svg node)))
 148   (svg-possibly-update-image svg))
 149
 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))
 156         attr)
 157     (when stroke-width
 158       (push (cons 'stroke-width stroke-width) attr))
 159     (when stroke-color
 160       (push (cons 'stroke stroke-color) attr))
 161     (when fill-color
 162       (push (cons 'fill fill-color) attr))
 163     (when (plist-get args :gradient)
 164       (setq attr
 165             (append
 166              ;; We need a way to specify the gradient direction here...
 167              `((x1 . 0)
 168                (x2 . 0)
 169                (y1 . 0)
 170                (y2 . 1)
 171                (fill . ,(format "url(#%s)"
 172                                 (plist-get args :gradient))))
 173              attr)))
 174     (cl-loop for (key value) on args by #'cddr
 175              unless (memq key '(:stroke-color :stroke-width :gradient
 176                                               :fill-color))
 177              ;; Drop the leading colon.
 178              do (push (cons (intern (substring (symbol-name key) 1) obarray)
 179                             value)
 180                       attr))
 181     attr))
 182
 183 (defun svg--def (svg def)
 184   (dom-append-child
 185    (or (dom-by-tag svg 'defs)
 186        (let ((node (dom-node 'defs)))
 187          (dom-add-child-before svg node)
 188          node))
 189    def)
 190   svg)
 191
 192 (defun svg-image (svg)
 193   "Return an image object from SVG."
 194   (create-image
 195    (with-temp-buffer
 196      (svg-print svg)
 197      (buffer-string))
 198    'svg t))
 199
 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)))
 205     (insert-image image)
 206     (dom-set-attribute svg :image marker)))
 207
 208 (defun svg-possibly-update-image (svg)
 209   (let ((marker (dom-attr svg :image)))
 210     (when (and marker
 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))))))
 214
 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)))))
 222   (insert ">")
 223   (dolist (elem (nthcdr 2 dom))
 224     (insert " ")
 225     (svg-print elem))
 226   (insert (format "</%s>" (car dom))))
 227
 228 (provide 'svg)
 229
 230 ;;; svg.el ends here