Add a library for creating and manipulating SVG images

* doc/lispref/display.texi (SVG Images): New section.

* lisp/svg.el: New file.

3 files changed, 357 insertions, 3 deletions

diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 26f3de40e91..17025cd1994 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -4761,6 +4761,7 @@ displayed (@pxref{Display Feature Testing}).
 * XPM Images::          Special features for XPM format.
 * PostScript Images::   Special features for PostScript format.
 * ImageMagick Images::  Special features available through ImageMagick.
+* SVG Images::          Creating and manipulating SVG images.
 * Other Image Types::   Various other formats are supported.
 * Defining Images::     Convenient ways to define an image for later use.
 * Showing Images::      Convenient ways to display an image once it is defined.
@@ -5220,6 +5221,128 @@ Specifies a rotation angle in degrees.
 @xref{Multi-Frame Images}.
 @end table
 
+@node SVG Images
+@subsection SVG Images
+@cindex SVG images
+
+SVG (Scalable Vector Graphics) is an XML format for specifying images.
+If you build Emacs with SVG support, you can create and manipulate
+these images with the following commands.
+
+@defun svg-create width height &rest args
+Create a new, empty SVG image with the specified dimensions.
+@var{args} is an argument plist with you can specify following:
+
+@table @code
+@item :stroke-width
+The default width (in pixels) of any lines created.
+
+@item :stroke
+The default stroke color on any lines created.
+@end table
+
+This function returns an SVG structure, and all the following commands
+work on that structure.
+@end defun
+
+@defun svg-gradient svg id type stops
+Create a gradient in @var{svg} with identifier @var{id}.  @var{type}
+specifies the gradient type, and can be either @code{linear} or
+@code{radial}.  @var{stops} is a list of percentage/color pairs.
+
+The following will create a linear gradient that goes from red at the
+start, to green 25% of the way, to blue at the end:
+
+@lisp
+(svg-gradient svg "gradient1" 'linear
+              '((0 . "red") (25 . "green") (100 . "blue")))
+@end lisp
+
+The gradient created (and inserted into the SVG object) can later be
+used by all functions that create shapes.
+@end defun
+
+All the following functions take an optional list of keyword
+parameters that alter the various attributes from their default
+values.  Valid attributes include:
+
+@table @code
+@item :stroke-width
+The width (in pixels) of lines drawn, and outlines around solid
+shapes.
+
+@item :stroke-color
+The color of lines drawn, and outlines around solid shapes.
+
+@item :fill-color
+The color used for solid shapes.
+
+@item :id
+The identified of the shape.
+
+@item :gradient
+If given, this should be the identifier of a previously defined
+gradient object.
+@end table
+
+@defun svg-rectangle svg x y width height &rest args
+Add a rectangle to @var{svg} where the upper left corner is at
+position @var{x}/@var{y} and is of size @var{width}/@var{height}.
+
+@lisp
+(svg-rectangle svg 100 100 500 500 :gradient "gradient1")
+@end lisp
+@end defun
+
+@defun svg-circle svg x y radius &rest args
+Add a circle to @var{svg} where the center is at @var{x}/@var{y}
+and the radius is @var{radius}.
+@end defun
+
+@defun svg-ellipse svg x y x-radius y-radius &rest args
+Add a circle to @var{svg} where the center is at @var{x}/@var{y} and
+the horizontal radius is @var{x-radius} and the vertical radius is
+@var{y-radius}.
+@end defun
+
+@defun svg-line svg x1 y1 x2 y2 &rest args
+Add a line to @var{svg} that starts at @var{x1}/@var{y1} and extends
+to @var{x2}/@var{y2}.
+@end defun
+
+@defun svg-polyline svg points &rest args
+Add a multiple segment line to @var{svg} that goes through
+@var{points}, which is a list of X/Y position pairs.
+
+@lisp
+(svg-polyline svg '((200 . 100) (500 . 450) (80 . 100))
+              :stroke-color "green")
+@end lisp
+@end defun
+
+@defun svg-polygon svg points &rest args
+Add a polygon to @var{svg} where @var{points} is a list of X/Y pairs
+that describe the outer circumference of the polygon.
+
+@lisp
+(svg-polygon svg '((100 . 100) (200 . 150) (150 . 90))
+             :stroke-color "blue" :fill-color "red"")
+@end lisp
+@end defun
+
+Finally, the @code{svg-image} takes an SVG object as its parameter and
+returns an image object suitable for use in functions like
+@code{insert-image}.  Here's a complete example that creates and
+inserts an image with a circle:
+
+@lisp
+(let ((svg (svg-create 400 400 :stroke-width 10)))
+  (svg-gradient svg "gradient1" 'linear '((0 . "red") (100 . "blue")))
+  (svg-circle svg 200 200 100 :gradient "gradient1" :stroke-color "green")
+  (insert-image (svg-image svg)))
+@end lisp
+
+
 @node Other Image Types
 @subsection Other Image Types
 @cindex PBM
@@ -5256,9 +5379,6 @@ Image type @code{jpeg}.
 @item PNG
 Image type @code{png}.
 
-@item SVG
-Image type @code{svg}.
-
 @item TIFF
 Image type @code{tiff}.
 Supports the @code{:index} property.  @xref{Multi-Frame Images}.
diff --git a/etc/NEWS b/etc/NEWS
index cc99dbd1075..c3c3ebab94d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -851,6 +851,10 @@ keymap put into the text properties (or overlays) that span the
 image.  This keymap binds keystrokes for manipulating size and
 rotation, as well as saving the image to a file.
 
++++
+*** A new library for creating and manipulating SVG images has been
+added.  See the "SVG Images" section in the lispref manual for details.
+
 ** Lisp mode
 
 ---
diff --git a/lisp/svg.el b/lisp/svg.el
new file mode 100644
index 00000000000..b6beaadc032
--- /dev/null
+++ b/lisp/svg.el
@@ -0,0 +1,230 @@
+;;; svg.el --- SVG image creation functions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: image
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'xml)
+(require 'dom)
+
+(defun svg-create (width height &rest args)
+  "Create a new, empty SVG image with dimentions WIDTHxHEIGHT.
+ARGS can be used to provide `stroke' and `stroke-width' parameters to
+any further elements added."
+  (dom-node 'svg
+            `((width . ,width)
+              (height . ,height)
+              (version . "1.1")
+              (xmlsn . "http://www.w3.org/2000/svg")
+              ,@(svg--arguments nil args))))
+
+(defun svg-gradient (svg id type stops)
+  "Add a gradient with ID to SVG.
+TYPE is `linear' or `radial'.  STOPS is a list of percentage/color
+pairs."
+  (svg--def
+   svg
+   (apply
+    'dom-node
+    (if (eq type 'linear)
+        'linearGradient
+      'radialGradient)
+    `((id . ,id)
+      (x1 . 0)
+      (x2 . 0)
+      (y1 . 0)
+      (y2 . 1))
+    (mapcar
+     (lambda (stop)
+       (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
+                         (stop-color . ,(cdr stop)))))
+     stops))))
+
+(defun svg-rectangle (svg x y width height &rest args)
+  "Create a rectangle on SVG, starting at position X/Y, of WIDTH/HEIGHT.
+ARGS is a plist of modifiers.  Possible values are
+
+:stroke-width PIXELS.  The line width.
+:stroke-color COLOR.  The line color.
+:gradient ID.  The gradient ID to use."
+  (svg--append
+   svg
+   (dom-node 'rect
+             `((width . ,width)
+               (height . ,height)
+               (x . ,x)
+               (y . ,y)
+               ,@(svg--arguments svg args)))))
+
+(defun svg-circle (svg x y radius &rest args)
+  "Create a circle of RADIUS on SVG.
+X/Y denote the center of the circle."
+  (svg--append
+   svg
+   (dom-node 'circle
+             `((cx . ,x)
+               (cy . ,y)
+               (r . ,radius)
+               ,@(svg--arguments svg args)))))
+
+(defun svg-ellipse (svg x y x-radius y-radius &rest args)
+  "Create an ellipse of X-RADIUS/Y-RADIUS on SVG.
+X/Y denote the center of the ellipse."
+  (svg--append
+   svg
+   (dom-node 'ellipse
+             `((cx . ,x)
+               (cy . ,y)
+               (rx . ,x-radius)
+               (ry . ,y-radius)
+               ,@(svg--arguments svg args)))))
+
+(defun svg-line (svg x1 y1 x2 y2 &rest args)
+  "Create a line of starting in X1/Y1, ending at X2/Y2 in SVG."
+  (svg--append
+   svg
+   (dom-node 'line
+             `((x1 . ,x1)
+               (x2 . ,y1)
+               (y1 . ,x2)
+               (y2 . ,y2)
+               ,@(svg--arguments svg args)))))
+
+(defun svg-polyline (svg points &rest args)
+  "Create a polyline going through POINTS on SVG.
+POINTS is a list of x/y pairs."
+  (svg--append
+   svg
+   (dom-node
+    'polyline
+    `((points . ,(mapconcat (lambda (pair)
+                              (format "%s %s" (car pair) (cdr pair)))
+                            points
+                            ", "))
+      ,@(svg--arguments svg args)))))
+
+(defun svg-polygon (svg points &rest args)
+  "Create a polygon going through POINTS on SVG.
+POINTS is a list of x/y pairs."
+  (svg--append
+   svg
+   (dom-node
+    'polygon
+    `((points . ,(mapconcat (lambda (pair)
+                              (format "%s %s" (car pair) (cdr pair)))
+                            points
+                            ", "))
+      ,@(svg--arguments svg args)))))
+
+(defun svg--append (svg node)
+  (let ((old (and (dom-attr node 'id)
+                  (dom-by-id svg
+                             (concat "\\`" (regexp-quote (dom-attr node 'id))
+                                     "\\'")))))
+    (if old
+        (dom-set-attributes old (dom-attributes node))
+      (dom-append-child svg node)))
+  (svg-possibly-update-image svg))
+
+(defun svg--arguments (svg args)
+  (let ((stroke-width (or (plist-get args :stroke-width)
+                          (dom-attr svg 'stroke-width)))
+        (stroke-color (or (plist-get args :stroke-color)
+                          (dom-attr svg 'stroke-color)))
+        (fill-color (plist-get args :fill-color))
+        attr)
+    (when stroke-width
+      (push (cons 'stroke-width stroke-width) attr))
+    (when stroke-color
+      (push (cons 'stroke stroke-color) attr))
+    (when fill-color
+      (push (cons 'fill fill-color) attr))
+    (when (plist-get args :gradient)
+      (setq attr
+            (append
+             ;; We need a way to specify the gradient direction here...
+             `((x1 . 0)
+               (x2 . 0)
+               (y1 . 0)
+               (y2 . 1)
+               (fill . ,(format "url(#%s)"
+                                (plist-get args :gradient))))
+             attr)))
+    (cl-loop for (key value) on args by #'cddr
+             unless (memq key '(:stroke-color :stroke-width :gradient
+                                              :fill-color))
+             ;; Drop the leading colon.
+             do (push (cons (intern (substring (symbol-name key) 1) obarray)
+                            value)
+                      attr))
+    attr))
+
+(defun svg--def (svg def)
+  (dom-append-child
+   (or (dom-by-tag svg 'defs)
+       (let ((node (dom-node 'defs)))
+         (dom-add-child-before svg node)
+         node))
+   def)
+  svg)
+
+(defun svg-image (svg)
+  "Return an image object from SVG."
+  (create-image
+   (with-temp-buffer
+     (svg-print svg)
+     (buffer-string))
+   'svg t))
+
+(defun svg-insert-image (svg)
+  "Insert SVG as an image at point.
+If the SVG is later changed, the image will also be updated."
+  (let ((image (svg-image svg))
+        (marker (point-marker)))
+    (insert-image image)
+    (dom-set-attribute svg :image marker)))
+
+(defun svg-possibly-update-image (svg)
+  (let ((marker (dom-attr svg :image)))
+    (when (and marker
+               (buffer-live-p (marker-buffer marker)))
+      (with-current-buffer (marker-buffer marker)
+        (put-text-property marker (1+ marker) 'display (svg-image svg))))))
+
+(defun svg-print (dom)
+  "Convert DOM into a string containing the xml representation."
+  (insert (format "<%s" (car dom)))
+  (dolist (attr (nth 1 dom))
+    ;; Ignore attributes that start with a colon.
+    (unless (= (aref (format "%s" (car attr)) 0) ?:)
+      (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
+  (insert ">")
+  (dolist (elem (nthcdr 2 dom))
+    (insert " ")
+    (svg-print elem))
+  (insert (format "</%s>" (car dom))))
+
+(provide 'svg)
+
+;;; svg.el ends here