code.delx.au - gnu-emacs-elpa/blob - packages/svg/svg.el

   1 ;;; svg.el --- svg image creation functions
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: image
   7 ;; Version: 0.1
   8 ;; Package-Requires: ((emacs "25"))
   9
  10 ;; This program 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 ;; This program 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 ;; This pacakge allows creating SVG images in Emacs.  SVG images are
  26 ;; vector-based XML files, really, so you could create them directly
  27 ;; as XML.  However, that's really tedious, as there are some fiddly
  28 ;; bits.
  29
  30 ;; In addition, the `svg-insert-image' function allows inserting an
  31 ;; SVG image into a buffer that's updated "on the fly" as you
  32 ;; add/alter elements to the image, which is useful when composing the
  33 ;; images.
  34
  35 ;; Here are some usage examples:
  36
  37 ;; Create the base image structure, add a gradient spec, and insert it
  38 ;; into the buffer:
  39 ;; (setq svg (svg-create 800 800 :stroke "orange" :stroke-width 5))
  40 ;; (svg-gradient svg "gradient" 'linear '(0 . "red") '(100 . "blue"))
  41 ;; (save-excursion (goto-char (point-max)) (svg-insert-image svg))
  42
  43 ;; Then add various elements to the structure:
  44 ;; (svg-rectangle svg 100 100 500 500 :gradient "gradient" :id "rec1")
  45 ;; (svg-circle svg 500 500 100 :id "circle1")
  46 ;; (svg-ellipse svg 100 100 50 90 :stroke "red" :id "ellipse1")
  47 ;; (svg-line svg 100 190 50 100 :id "line1" :stroke "yellow")
  48 ;; (svg-polyline svg '((200 . 100) (500 . 450) (80 . 100))
  49 ;;            :stroke "green" :id "poly1")
  50 ;; (svg-polygon svg '((100 . 100) (200 . 150) (150 . 90))
  51 ;;           :stroke "blue" :fill "red" :id "gon1")
  52
  53 ;;; Code:
  54
  55 (require 'cl-lib)
  56 (require 'xml)
  57 (require 'dom)
  58
  59 (defun svg-create (width height &rest args)
  60   "Create a new, empty SVG image with dimentions WIDTHxHEIGHT.
  61 ARGS can be used to provide `stroke' and `stroke-width' parameters to
  62 any further elements added."
  63   (dom-node 'svg
  64             `((width . ,width)
  65               (height . ,height)
  66               (version . "1.1")
  67               (xmlsn . "http://www.w3.org/2000/svg")
  68               ,@(svg-arguments nil args))))
  69
  70 (defun svg-gradient (svg id type &rest stops)
  71   "Add a gradient with ID to SVG.
  72 TYPE is `linear' or `gradient'.  STOPS is a list of percentage/color
  73 pairs."
  74   (svg-def
  75    svg
  76    (apply
  77     'dom-node
  78     (if (eq type 'linear)
  79         'linearGradient
  80       'radialGradient)
  81     `((id . ,id)
  82       (x1 . 0)
  83       (x2 . 0)
  84       (y1 . 0)
  85       (y2 . 1))
  86     (mapcar
  87      (lambda (stop)
  88        (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
  89                          (stop-color . ,(cdr stop)))))
  90      stops))))
  91
  92 (defun svg-rectangle (svg x y width height &rest args)
  93   "Create a rectangle on SVG."
  94   (svg-append
  95    svg
  96    (dom-node 'rect
  97              `((width . ,width)
  98                (height . ,height)
  99                (x . ,x)
 100                (y . ,y)
 101                ,@(svg-arguments svg args)))))
 102
 103 (defun svg-circle (svg x y radius &rest args)
 104   "Create a circle of RADIUS on SVG.
 105 X/Y denote the center of the circle."
 106   (svg-append
 107    svg
 108    (dom-node 'circle
 109              `((cx . ,x)
 110                (cy . ,y)
 111                (r . ,radius)
 112                ,@(svg-arguments svg args)))))
 113
 114 (defun svg-ellipse (svg x y x-radius y-radius &rest args)
 115   "Create an ellipse of X-RADIUS/Y-RADIUS on SVG.
 116 X/Y denote the center of the ellipse."
 117   (svg-append
 118    svg
 119    (dom-node 'ellipse
 120              `((cx . ,x)
 121                (cy . ,y)
 122                (rx . ,x-radius)
 123                (ry . ,y-radius)
 124                ,@(svg-arguments svg args)))))
 125
 126 (defun svg-line (svg x1 y1 x2 y2 &rest args)
 127   "Create a line of starting in X1/Y1, ending at X2/Y2 on SVG."
 128   (svg-append
 129    svg
 130    (dom-node 'line
 131              `((x1 . ,x1)
 132                (y1 . ,y1)
 133                (x2 . ,x2)
 134                (y2 . ,y2)
 135                ,@(svg-arguments svg args)))))
 136
 137 (defun svg-polyline (svg points &rest args)
 138   "Create a polyline going through POINTS on SVG.
 139 POINTS is a list of x/y pairs."
 140   (svg-append
 141    svg
 142    (dom-node
 143     'polyline
 144     `((points . ,(mapconcat (lambda (pair)
 145                               (format "%s %s" (car pair) (cdr pair)))
 146                             points
 147                             ", "))
 148       ,@(svg-arguments svg args)))))
 149
 150 (defun svg-polygon (svg points &rest args)
 151   "Create a polygon going through POINTS on SVG.
 152 POINTS is a list of x/y pairs."
 153   (svg-append
 154    svg
 155    (dom-node
 156     'polygon
 157     `((points . ,(mapconcat (lambda (pair)
 158                               (format "%s %s" (car pair) (cdr pair)))
 159                             points
 160                             ", "))
 161       ,@(svg-arguments svg args)))))
 162
 163 (defun svg-append (svg node)
 164   (let ((old (and (dom-attr node 'id)
 165                   (dom-by-id svg (concat "\\`" (regexp-quote (dom-attr node 'id))
 166                                          "\\'")))))
 167     (if old
 168         (dom-set-attributes old (dom-attributes node))
 169       (dom-append-child svg node)))
 170   (svg-possibly-update-image svg))
 171
 172 (defun svg-arguments (svg args)
 173   (let ((stroke-width (or (plist-get args :stroke-width)
 174                           (dom-attr svg 'stroke-width)))
 175         (stroke (or (plist-get args :stroke)
 176                     (dom-attr svg 'stroke)))
 177         attr)
 178     (when stroke-width
 179       (push (cons 'stroke-width stroke-width) attr))
 180     (when stroke
 181       (push (cons 'stroke stroke) attr))
 182     (when (plist-get args :gradient)
 183       (setq attr
 184             (append
 185              ;; We need a way to specify the gradient direction here...
 186              `((x1 . 0)
 187                (x2 . 0)
 188                (y1 . 0)
 189                (y2 . 1)
 190                (fill . ,(format "url(#%s)"
 191                                 (plist-get args :gradient))))
 192              attr)))
 193     (cl-loop for (key value) on args by #'cddr
 194              unless (memq key '(:stroke :stroke-width :gradient))
 195              ;; Drop the leading colon.
 196              do (push (cons (intern (substring (symbol-name key) 1) obarray)
 197                             value)
 198                       attr))
 199     attr))
 200
 201 (defun svg-def (svg def)
 202   (dom-append-child
 203    (or (dom-by-tag svg 'defs)
 204        (let ((node (dom-node 'defs)))
 205          (dom-add-child-before svg node)
 206          node))
 207    def)
 208   svg)
 209
 210 (defun svg-image (svg)
 211   "Return an image object from SVG."
 212   (create-image
 213    (with-temp-buffer
 214      (svg-print svg)
 215      (buffer-string))
 216    'svg t))
 217
 218 (defun svg-insert-image (svg)
 219   "Insert SVG as an image at point.
 220 If the SVG is later changed, the image will also be updated."
 221   (let ((image (svg-image svg))
 222         (marker (point-marker)))
 223     (insert-image image)
 224     (dom-set-attribute svg :image marker)))
 225
 226 (defun svg-possibly-update-image (svg)
 227   (let ((marker (dom-attr svg :image)))
 228     (when (and marker
 229                (buffer-live-p (marker-buffer marker)))
 230       (with-current-buffer (marker-buffer marker)
 231         (put-text-property marker (1+ marker) 'display (svg-image svg))))))
 232
 233 (defun svg-print (dom)
 234   "Convert DOM into a string containing the xml representation."
 235   (insert (format "<%s" (car dom)))
 236   (dolist (attr (nth 1 dom))
 237     ;; Ignore attributes that start with a colon.
 238     (unless (= (aref (format "%s" (car attr)) 0) ?:)
 239       (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
 240   (insert ">")
 241   (dolist (elem (nthcdr 2 dom))
 242     (insert " ")
 243     (svg-print elem))
 244   (insert (format "</%s>" (car dom))))
 245
 246 (provide 'svg)
 247
 248 ;;; svg.el ends here