From 5e8a62917ade3751a328aa90830b51bbed90e15d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 19 Feb 2016 16:04:11 +1100 Subject: [PATCH] Add a library for creating and manipulating SVG images * doc/lispref/display.texi (SVG Images): New section. * lisp/svg.el: New file. --- doc/lispref/display.texi | 126 +++++++++++++++++++++++++- etc/NEWS | 4 + lisp/svg.el | 230 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 357 insertions(+), 3 deletions(-) create mode 100644 lisp/svg.el 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 +;; 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 . + +;;; 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 "" (car dom)))) + +(provide 'svg) + +;;; svg.el ends here -- 2.11.4.GIT