mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-25 07:28:20 +00:00
Code Issues Releases Activity

Add a library for creating and manipulating SVG images

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

* lisp/svg.el: New file.
This commit is contained in:
Lars Ingebrigtsen 2016-02-19 16:04:11 +11:00
parent 466fc43182
commit 5e8a62917a
3 changed files with 357 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
doc/lispref/display.texi
View File

@ -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}.

4
etc/NEWS
View File

@ -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
---

230
lisp/svg.el Normal file
View File

@ -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