├── example.png
├── trivial-svg.asd
├── README.md
└── trivial-svg.lisp


/example.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/calsys456/trivial-svg/HEAD/example.png


--------------------------------------------------------------------------------
/trivial-svg.asd:
--------------------------------------------------------------------------------
1 | (defsystem trivial-svg
2 |   :author "April & May"
3 |   :license "0BSD"
4 |   :description "Pure Lisp SVG renderer."
5 |   :depends-on (alexandria cl-ppcre plump serapeum vecto uiop)
6 |   :components ((:file "trivial-svg")))
7 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # Trivial-SVG: Pure-Lisp SVG renderer
  2 | 
  3 | This library allows you to render SVG images to PNG using [Vecto](https://www.xach.com/lisp/vecto/) and [zpb-ttf](https://github.com/xach/zpb-ttf).
  4 | 
  5 | The library is purely written in Common Lisp with no foreign dependency. It's optimized for fast parsing and rendering. 0BSD licensed.
  6 | 
  7 | ![example](example.png)
  8 | 
  9 | > There're 168 Google Material Symbol SVGs in 32px above. The whole process of parsing + rendering + saving PNG cost 0.116 seconds in total. There's still many space for improvement. SBCL 2.5.0 on Apple M3 chip, renderer not cached.
 10 | 
 11 | ## Package & Dependencies
 12 | 
 13 | We provide a single ASDF system `trivial-svg` defined in a single file [trivial-svg.lisp](./trivial-svg.lisp). It depends on:
 14 | 
 15 | - alexandria
 16 | - cl-ppcre
 17 | - plump
 18 | - serapeum
 19 | - vecto
 20 | 
 21 | > 3/2/2025: Note that currently the Quicklisp distribution of `zpb-ttf` library (the necessary dependency of `vecto`) is staled. You should install the library manually with a version that at least later than [this commit](https://github.com/xach/zpb-ttf/commit/3b907c6f666cd3ed56ff2d469f23c5e26a709f2b). For example:
 22 | >
 23 | > ```bash
 24 | > git clone https://github.com/xach/zpb-ttf.git ~/quicklisp/local-projects/zpb-ttf/
 25 | > ```
 26 | 
 27 | ## Usage
 28 | 
 29 | To load the source code, you can clone this library to `~/common-lisp/` or `~/quicklisp/local-projects/`, then evaluate `(ql:quickload :trivial-svg)` if you have Quicklisp installed.
 30 | 
 31 | ### Simple interface: `draw-svg-from-string`
 32 | 
 33 | ``` common-lisp
 34 | (defparameter *test-svg-string*
 35 |   "<svg xmlns='http://www.w3.org/2000/svg'
 36 |         height='128px' viewBox='0 -960 960 960' width='128px' fill='#888888'>
 37 |      <path d='m321-80-71-71 329-329-329-329 71-71 400 400L321-80Z'/>
 38 |    </svg>")
 39 | 
 40 | (draw-svg-from-string *test-svg-string* "./test.png")
 41 | ```
 42 | 
 43 | You are supposed to see a 128*128px gray right-chevron at `./test.png`.
 44 | 
 45 | *Function* **draw-svg-from-string** *svg-string output &key (font (get-font-file)) (viewport-width 1920) (viewport-height 1080)* => *NIL*
 46 | 
 47 | Draw the first SVG element inside *svg-string*. If *svg-string* is a pathname, read the content of the file. *output* can be either a stream, a pathname, or a namestring. 
 48 | 
 49 | The output PNG image will be resized to fit the size of SVG. *viewport-width* and *viewport-height* specify the initial width and height of the drawing area, which will only be used for resolving relative CSS length units in the outermost SVG element.
 50 | 
 51 | ### Custom Drawing with Vecto
 52 | 
 53 | Trivial-SVG use the `graphics-state` of Vecto,  which means it can cooperate with any Vecto drawing actions.
 54 | 
 55 | > *Function* **create-renderer** *state* *node* *`&optional`* *(root-node node) (container-attributes (make-hash-table :test #'equalp))* => *function*
 56 | >
 57 | > The funcion `create-renderer` accepts a `plump:node` *node,* which should be a valid SVG element, and will parse it into a "renderer function". The `state` should be a `vecto::graphics-state` that is only used to query graphic information like geometry, font size and so on. `root-node` refers to the DOM root of the SVG element, it's used to search referenced elements by ID; `container-attributes` is used to store inherited attributes in recursive parsing.
 58 | >
 59 | > The result function accepts 1 argument: The `vecto::graphics-state` you want to draw the SVG with. Each time when the function is called, the function will execute a series of Vecto drawing functions to draw the SVG on the state at predefined location. You can use functions like `vecto::%translate` to change the drawing result.
 60 | 
 61 | Here's the code that's used to produce [example.png](./example.png), which can be an example for custom drawing implementation. The source code of `draw-svg-from-string` is also valuable for reference.
 62 | 
 63 | ```common-lisp
 64 | (let* ((width (* 32 24))
 65 |        (height (* 32 7))
 66 |        (state (make-instance 'vecto::graphics-state
 67 |                              :width width
 68 |                              :height height
 69 |                              :transform-matrix (vecto::identity-matrix)))
 70 |        ;; We put 42 Google material symbols in ~/svg-test/
 71 |        (svg-files (directory "~/svg-test/*.svg")))
 72 |   (setf (vecto::image state)
 73 |         (make-instance 'zpng:png
 74 |                        :width width
 75 |                        :height height
 76 |                        :color-type vecto::+png-color-type+)
 77 |         (vecto::clipping-path state) (vecto::make-clipping-path width height))
 78 |   (vecto::%set-font state (vecto::%get-font state (trivial-svg:get-font-file)) 12)
 79 |   (loop for i from 0
 80 |         for svg-file in (serapeum:repeat-sequence svg-files 4)
 81 |         for svg-node = (first (plump:get-elements-by-tag-name (plump:parse svg-file) "svg"))
 82 |         do (multiple-value-bind (y x) (floor i 24)
 83 |              (let* ((state (vecto::copy state))
 84 |                     (renderer (trivial-svg:create-renderer state svg-node)))
 85 |                (vecto::%translate state (* x 32) (* y 32))
 86 |                (funcall renderer state))))
 87 |   (vecto::after-painting state)
 88 |   (zpng:write-png (vecto::image state)
 89 |                   (merge-pathnames "example.png" (asdf:system-source-directory :trivial-svg)))
 90 |   (vecto::clear-state state))
 91 | ```
 92 | 
 93 | > Note: The exported interface of `Vecto` is too simple to handle complex drawing operations, you may need to refer the source code of `Vecto` to learn how to do. It's not difficult if you have the experience of any computer drawing system.
 94 | 
 95 | ## Development
 96 | 
 97 | The plugin has not fully covered the SVG specification yet. It may misbehave when dealing with elements that are unsupported or complexly cascaded. Here's a list that it can deal with, emphasized means only partly implemented:
 98 | 
 99 | - Elements
100 |   - circle
101 |   - defs
102 |   - ellipse
103 |   - g
104 |   - image
105 |   - line
106 |   - *linearGradient*
107 |   - path
108 |   - polygon
109 |   - polyline
110 |   - *radialGradient*
111 |   - rect
112 |   - stop
113 |   - svg
114 |   - *text*
115 |   - *tspan*
116 |   - use
117 | - presentation attributes
118 |   - color
119 |   - fill
120 |   - fill-opacity
121 |   - fill-rule
122 |   - font-family
123 |   - font-size
124 |   - font-weight
125 |   - font-style
126 |   - opacity
127 |   - stop-color
128 |   - stop-opacity
129 |   - stroke
130 |   - stroke-dasharray
131 |   - stroke-linecap
132 |   - stroke-linejoin
133 |   - stroke-opacity
134 |   - stroke-width
135 |   - transform
136 |   - _writing-mode_
137 | 
138 | Here's what we're planning to do now:
139 | 
140 | - [x] [BUG] Fix the wrong interpretation of rotational transform matrix
141 | - [x] Support specifying attributes with inline `style` attribute and CSS `style` element
142 | - [ ] Support `text` and `tspan`
143 |   - [x] `x`, `y`, `dx`, `dy`, `rotate`
144 |   - [x] Get font with different weight/slant with `zpb-ttf` on all platforms
145 |     - [ ] perhaps we can optimize its speed...
146 |   - [ ] Character and word spacing
147 |   - [ ] SVG2 Content area & SVG tiny `textArea`
148 |   - [ ] ...
149 |   
150 | - [ ] Support `image`, `marker` and `symbol` (and maybe `a`?)
151 | - [ ] Support gradients `spreadMethod` and `pattern`
152 | - [ ] Support clipping and masking
153 | - [ ] Formal error handling
154 | 
155 | ### Testing
156 | 
157 | At the end of the [trivial-svg.lisp](./trivial-svg.lisp) there's an "interactive test", it will load a same SVG side-by-side, one using the `capi:browser-pane`, another using the `capi:output-pane` with `trivial-svg` library. It allows us to compare and check if the two images are identical on the screen. Images used for test are example images shown on W3C's SVG specification. You need LispWorks for Macintosh to run the interactive test, as `capi:browser-pane` does not support other Unix, and on Windows it is too old to use.
158 | 
159 | ## Implementation Notes
160 | 
161 | This library is a port of [lw-svg](https://github.com/apr3vau/lw-plugins/tree/main/svg), with Vecto and zpb-ttf instead of LispWorks Graphics Port API, making it available for every implementation. The developer will maintain a synchronic update between the two library.
162 | 
163 | Since Vecto & cl-vector is not as powerful as LW-GP, the image quality produced by two libraries may slightly different.
164 | 
165 | To simplify porting, we wrote a partial implementation of LispWorks APIs, mainly Graphics Ports and Color packages, acting as a portable layer. These APIs are keeping consistent with LW data structure, and can be converted to conforms other libraries like `Vecto`. With this layer, we can constraint the difference between lw-svg and trivial-svg into a small area, which have simplified our works significantly.
166 | 
167 | There's also a partial CSS parser inside the code. Take them if they're useful for you.
168 | 
169 | ---
170 | 
171 | ## Acknowledgements
172 | 
173 | Thanks to Zachary P. Beane, and other contributors of `vecto`, `cl-vectors`, `zpb-ttf` and other libraries. Your endeavor for the infrastructure is the basis of this project.
174 | 
175 | Thanks my sister Simone, and my headmate May, who help and support me.
176 | 
177 | Supporting Neurodiversity & Transgender & Plurality!
178 | 
179 | 🏳️‍🌈🏳️‍⚧️
180 | 


--------------------------------------------------------------------------------
/trivial-svg.lisp:
--------------------------------------------------------------------------------
   1 | ;; Copyright (c) 2025, April & May
   2 | ;; SPDX-License-Identifier: 0BSD
   3 | 
   4 | ;; Pure-Lisp SVG renderer.
   5 | 
   6 | ;; The source code can be separated to - major parts, splitted with #\Page
   7 | ;; 1. Utilities and a partial implementation of LispWorks APIs
   8 | ;; 2. CSS parser
   9 | ;; 3. SVG `path` data parser
  10 | ;; 4. Gradient painting server implementation
  11 | ;; 5. Main SVG parser & renderer
  12 | 
  13 | ;; Check README.md for usage and details.
  14 | 
  15 | (defpackage trivial-svg
  16 |   (:use #:cl #:string-case #:split-sequence)
  17 |   (:import-from #:alexandria #:clamp #:copy-hash-table #:lerp #:ensure-gethash #:with-unique-names #:when-let #:if-let)
  18 |   (:import-from #:serapeum #:push-end #:parse-float #:defalias)
  19 |   (:export
  20 |    rad-to-deg deg-to-rad hex-to-spec
  21 |    get-char-width get-char-height font-family font-subfamily find-font-loader get-font-file
  22 |    css-parse-url css-parse-angel css-parse-color css-parse-length
  23 |    css-parse-a-number css-parse-transforms css-parse-numeric-color css-parse-all-angels-from-string
  24 |    css-parse-all-length-from-string css-parse-all-numbers-from-string
  25 |    create-renderer draw-svg-from-string))
  26 | 
  27 | (in-package trivial-svg)
  28 | 
  29 | 
  30 | ;; Utilities and a partial implementation of LispWorks APIs
  31 | 
  32 | (declaim (type double-float rad-to-deg-conversion-factor 2pi pi-by-2))
  33 | 
  34 | ;; GP:2PI, GP:PI-BY-2
  35 | (defconstant 2pi (* pi 2))
  36 | (defconstant pi-by-2 (/ pi 2))
  37 | 
  38 | (defconstant rad-to-deg-conversion-factor (/ 180.0d0 pi)
  39 |   "Factor used to convert radiants to degrees by multiplication.")
  40 | 
  41 | (defun rad-to-deg (radians) (* radians rad-to-deg-conversion-factor))
  42 | 
  43 | (defun deg-to-rad (degree) (/ degree rad-to-deg-conversion-factor))
  44 | 
  45 | (defmacro with-nth (bindings list &body body)
  46 |   (with-unique-names (lst)
  47 |     `(let* ((,lst ,list))
  48 |        (symbol-macrolet
  49 |            ,(loop for i from 0
  50 |                   for var in bindings
  51 |                   collect `(,var (nth ,i ,lst)))
  52 |          ,@body))))
  53 | 
  54 | ;; serapeum's version has mysterous inline-expand warning on LispWorks, annoying...
  55 | (defun string-prefix-p (prefix string)
  56 |   (string-equal prefix string :end2 (length prefix)))
  57 | 
  58 | ;; Why I'm prefer using CL's convention `NFOO` but not Scheme's `FOO!` XD...
  59 | (defun nmerge-tables (table &rest tables)
  60 |   "Merge values of hash-tables in TABLES into TABLE. TABLE will be modified.
  61 | 
  62 | From serapeum's `merge-tables!`"
  63 |   (declare (optimize (speed 3)))
  64 |   (reduce (lambda (ht1 ht2)
  65 |             (maphash (lambda (k v)
  66 |                        (setf (gethash k ht1) v))
  67 |                      ht2)
  68 |             ht1)
  69 |           tables
  70 |           :initial-value table))
  71 | 
  72 | ;; HARLEQUIN-COMMON-LISP:STRING-TRIM-WHITESPACE
  73 | (defalias string-trim-whitespace #'serapeum:trim-whitespace)
  74 | 
  75 | ;; LISPWORKS:WHITESPACE-CHAR-P
  76 | (defalias whitespace-char-p #'serapeum:whitespacep)
  77 | 
  78 | ;; LISPWORKS:STRING-APPEND
  79 | (defalias string-append #'serapeum:string+)
  80 | 
  81 | ;; GRAPHICS-PORTS:RECTANGLE-BIND
  82 | (defmacro rectangle-bind ((x y w h) rect &body body)
  83 |   (with-unique-names (r)
  84 |     `(let* ((,r ,rect)
  85 |             (,x (first ,r))
  86 |             (,y (second ,r))
  87 |             (,w (third ,r))
  88 |             (,h (fourth ,r)))
  89 |        ,@body)))
  90 | 
  91 | ;; Color
  92 | 
  93 | ;; COLOR:MAKE-RGB, COLOR:MAKE-HSV
  94 | (defun make-rgb (r g b &optional (a 1.0))
  95 |   (vector :rgb r g b a))
  96 | (defun make-hsv (h s v &optional (a 1.0))
  97 |   (vector :hsv h s v a))
  98 | 
  99 | ;; COLOR:ENSURE-RGB
 100 | (defun ensure-rgb (color)
 101 |   (case (aref color 0)
 102 |     (:hsv (let* ((h (rad-to-deg (mod (aref color 1) 2pi)))
 103 |                  (s (aref color 2))
 104 |                  (v (aref color 3))
 105 |                  (c (* s v))
 106 |                  (x (* c (- 1 (abs (1- (mod (/ h 60) 2))))))
 107 |                  (m (- v c))
 108 |                  (rp (cond ((or (and (<= 0 h) (< h 60))
 109 |                                 (and (<= 300 h) (< h 360)))
 110 |                             c)
 111 |                            ((or (and (<= 60 h) (< h 120))
 112 |                                 (and (<= 240 h) (< h 300)))
 113 |                             x)
 114 |                            (t 0)))
 115 |                  (gp (cond ((or (and (<= 0 h) (< h 60))
 116 |                                 (and (<= 180 h) (< h 240)))
 117 |                             x)
 118 |                            ((and (<= 60 h) (< h 180))
 119 |                             c)
 120 |                            (t 0)))
 121 |                  (bp (cond ((or (and (<= 120 h) (< h 180))
 122 |                                 (and (<= 300 h) (< h 360)))
 123 |                             x)
 124 |                            ((and (<= 180 h) (< h 300))
 125 |                             c)
 126 |                            (t 0))))
 127 |             (make-rgb (+ rp m) (+ gp m) (+ bp m) (aref color 4))))
 128 |     (t color)))
 129 | 
 130 | ;; LW RGB color accessors
 131 | (defun color-red (color)
 132 |   (declare (inline color-red))
 133 |   (aref (ensure-rgb color) 1))
 134 | (defun color-green (color)
 135 |   (declare (inline color-green))
 136 |   (aref (ensure-rgb color) 2))
 137 | (defun color-blue (color)
 138 |   (declare (inline color-blue))
 139 |   (aref (ensure-rgb color) 3))
 140 | (defun color-alpha (color)
 141 |   (declare (inline color-alpha))
 142 |   (aref color 4))
 143 | 
 144 | (defun hex-to-spec (hex)
 145 |   "Convert hexdecimal color string to LW color-spec."
 146 |   (setq hex (string-trim '(#\# #\Space) hex))
 147 |   (let ((hex-list (case (length hex)
 148 |                     (3 (map 'list #'string hex))
 149 |                     (6 (loop for i from 0 to 4 by 2 collect (subseq hex i (+ 2 i))))))
 150 |         (deno (if (< (length hex) 6) 15.0 255.0)))
 151 |     (when hex-list
 152 |       (apply #'make-rgb
 153 |              (mapcar (lambda (str) (/ (parse-integer str :radix 16) deno))
 154 |                      hex-list)))))
 155 | 
 156 | ;; Transform
 157 | 
 158 | ;; Notes that these transforms are in List (conform with LW) but not
 159 | ;; Vector (like in Vecto).
 160 | 
 161 | ;; GRAPHICS-PORTS:MAKE-TRANSFORM
 162 | (defun make-transform (&optional (a 1) (b 0) (c 0) (d 1) (e 0) (f 0))
 163 |   (declare (inline make-transform))
 164 |   (list a b c d e f))
 165 | 
 166 | (defalias copy-transform #'copy-list)
 167 | 
 168 | ;; Inspired by VECTO
 169 | 
 170 | ;; GRAPHICS-PORTS:PREMULTIPLY-TRANSFORMS
 171 | (defun premultiply-transforms (transform1 transform2)
 172 |   (destructuring-bind (a b c d e f) transform2
 173 |     (destructuring-bind (a* b* c* d* e* f*) transform1
 174 |       (with-nth (a1 b1 c1 d1 e1 f1) transform1
 175 |         (setf a1 (+ (* a a*) (* b c*))
 176 |               b1 (+ (* a b*) (* b d*))
 177 |               c1 (+ (* c a*) (* d c*))
 178 |               d1 (+ (* c b*) (* d d*))
 179 |               e1 (+ (* e a*) (* f c*) e*)
 180 |               f1 (+ (* e b*) (* f d*) f*)))))
 181 |   transform1)
 182 | 
 183 | ;; GRAPHICS-PORTS:POSTMULTIPLY-TRANSFORMS
 184 | (defun postmultiply-transforms (transform1 transform2)
 185 |   (destructuring-bind (a b c d e f) transform1
 186 |     (destructuring-bind (a* b* c* d* e* f*) transform2
 187 |       (with-nth (a1 b1 c1 d1 e1 f1) transform1
 188 |         (setf a1 (+ (* a a*) (* b c*))
 189 |               b1 (+ (* a b*) (* b d*))
 190 |               c1 (+ (* c a*) (* d c*))
 191 |               d1 (+ (* c b*) (* d d*))
 192 |               e1 (+ (* e a*) (* f c*) e*)
 193 |               f1 (+ (* e b*) (* f d*) f*)))))
 194 |   transform1)
 195 | 
 196 | ;; GRAPHICS-PORTS:APPLY-SCALE, GRAPHICS-PORTS:APPLY-TRANSLATION,
 197 | ;; GRAPHICS-PORTS:APPLY-ROTATION, GRAPHICS-PORTS:APPLY-ROTATION-AROUND-POINT
 198 | (defun apply-translation (transform dx dy)
 199 |   (declare (inline apply-translation))
 200 |   (postmultiply-transforms transform (make-transform 1 0 0 1 dx dy)))
 201 | 
 202 | (defun apply-scale (transform sx sy)
 203 |   (declare (inline apply-scale))
 204 |   (postmultiply-transforms transform (make-transform sx 0 0 sy 0 0)))
 205 | 
 206 | (defun apply-rotation (transform theta)
 207 |   (declare (inline apply-rotation))
 208 |   (postmultiply-transforms
 209 |    transform
 210 |    (let ((cos (cos theta))
 211 |          (sin (sin theta)))
 212 |     (make-transform cos sin (- sin) cos 0 0))))
 213 | 
 214 | (defun apply-rotation-around-point (transform theta x y)
 215 |   (declare (inline apply-rotation-around-point))
 216 |   (apply-translation transform (- x) (- y))
 217 |   (apply-rotation transform theta)
 218 |   (apply-translation transform x y))
 219 | 
 220 | ;; Fonts
 221 | 
 222 | (defun get-char-width (char loader size)
 223 |   (let* ((scale (vecto::loader-font-scale size loader))
 224 |          (glyph (zpb-ttf:find-glyph char loader)))
 225 |     (* (zpb-ttf:advance-width glyph) scale)))
 226 | 
 227 | (defun get-char-height (char loader size)
 228 |   (let* ((scale (vecto::loader-font-scale size loader))
 229 |          (glyph (zpb-ttf:find-glyph char loader)))
 230 |     (* (zpb-ttf:advance-height glyph) scale)))
 231 | 
 232 | (defun get-glyph-width (char loader size)
 233 |   (let* ((scale (vecto::loader-font-scale size loader))
 234 |          (glyph (zpb-ttf:find-glyph char loader)))
 235 |     (* (- (zpb-ttf:xmax glyph) (zpb-ttf:xmin glyph)) scale)))
 236 | 
 237 | (defun get-glyph-height (char loader size)
 238 |   (let* ((scale (vecto::loader-font-scale size loader))
 239 |          (glyph (zpb-ttf:find-glyph char loader)))
 240 |     (* (- (zpb-ttf:ymax glyph) (zpb-ttf:ymin glyph)) scale)))
 241 | 
 242 | (defun font-family (font-loader)
 243 |   (loop for entry across (zpb-ttf::name-entries font-loader)
 244 |         when (= (zpb-ttf::name-id entry) 1) ; 1 = (zpb-ttf::name-identifier-id :font-family)
 245 |           return (zpb-ttf:value entry)))
 246 | 
 247 | (defun font-subfamily (font-loader)
 248 |   (loop for entry across (zpb-ttf::name-entries font-loader)
 249 |         when (= (zpb-ttf::name-id entry) 2) ; 2 = (zpb-ttf::name-identifier-id :font-subfamily)
 250 |           return (zpb-ttf:value entry)))
 251 | 
 252 | (defun font-subfamily-match-p (font-loader weight slant)
 253 |   ;; FIXME: not perfect. e.g. semibold?
 254 |   (let ((sub (font-subfamily font-loader)))
 255 |     (cond ((and (or (null weight) (string-equal weight "regular"))
 256 |                 (or (null slant) (string-equal slant "roman")))
 257 |            (string-equal sub "regular"))
 258 |           ((or (null weight) (string-equal weight "regular"))
 259 |            (string-equal slant sub))
 260 |           ((or (null slant) (string-equal slant "roman"))
 261 |            (string-equal weight sub))
 262 |           (t (and (search weight sub :test #'char-equal)
 263 |                   (search slant sub :test #'char-equal))))))
 264 | 
 265 | ;; A small utility to find font file within system-installed fonts.
 266 | ;; Require fc-list on Linux.
 267 | 
 268 | (defvar *default-font-family*
 269 |   #+mswindows "C:/Windows/Fonts/Arial.ttf"
 270 |   #+darwin "/System/Library/Fonts/HelveticaNeue.ttc"
 271 |   #+(and unix (not darwin)) "Liberation Sans")
 272 | 
 273 | (defun find-font-loader (family-or-file weight slant)
 274 |   (let* (result fallback)
 275 |     #+(or mswindows darwin)
 276 |     (dolist (file (if (pathnamep family-or-file) (list family-or-file)
 277 |                     (directory
 278 |                      (make-pathname :name :wild :type :wild :defaults
 279 |                                     #+mswindows #P"C:/Windows/Fonts/"
 280 |                                     #+darwin #P"/System/Library/Fonts/**/"))))
 281 |       (when (member (pathname-type file) '("ttf" "ttc" "otf" "otc") :test #'string-equal)
 282 |         (handler-case
 283 |             (let ((loader (zpb-ttf:open-font-loader file)))
 284 |               (if (string-equal (font-family loader) family-or-file)
 285 |                 (if (font-subfamily-match-p loader weight slant)
 286 |                   (progn (setq result loader)
 287 |                     (return))
 288 |                   (let ((count (zpb-ttf:collection-font-count loader)))
 289 |                     (if fallback
 290 |                       (zpb-ttf:close-font-loader loader)
 291 |                       (setq fallback loader))
 292 |                     (when (> count 1)
 293 |                       (loop named t
 294 |                             for index from 1 to count
 295 |                             for loader = (zpb-ttf:open-font-loader file :collection-index index)
 296 |                             when (font-subfamily-match-p loader weight slant)
 297 |                               do (setq result loader)
 298 |                                  (return)))))
 299 |                 (zpb-ttf:close-font-loader loader)))
 300 |           (zpb-ttf::regrettable-hex-value (e) nil)
 301 |           (error (e) nil))))
 302 |     #-(or mswindows darwin)
 303 |     (dolist (line (split-sequence #\Newline
 304 |                                   (with-output-to-string (*standard-output*)
 305 |                                     (uiop:run-program "fc-list" :output t))
 306 |                                   :remove-empty-subseqs t))
 307 |       ;; We don't use `style` field from fc-list output here,
 308 |       ;; as we need an exact index of the font from collection.
 309 |       (destructuring-bind (file family &rest style) (split-sequence #\: line)
 310 |         (declare (ignore style))
 311 |         (when (string-equal (string-trim-whitespace family) family-or-file)
 312 |           (handler-case
 313 |               (let ((loader (zpb-ttf:open-font-loader file)))
 314 |                 (if (font-subfamily-match-p loader weight slant)
 315 |                   (progn (setq result loader)
 316 |                     (return))
 317 |                   (let ((count (zpb-ttf:collection-font-count loader)))
 318 |                     (if fallback
 319 |                       (zpb-ttf:close-font-loader loader)
 320 |                       (setq fallback loader))
 321 |                     (when (> count 1)
 322 |                       (loop named t
 323 |                             for index from 1 to count
 324 |                             for loader = (zpb-ttf:open-font-loader file :collection-index index)
 325 |                             when (font-subfamily-match-p loader weight slant)
 326 |                               do (setq result loader)
 327 |                                  (return))))))
 328 |             (zpb-ttf::regrettable-hex-value (e) nil)
 329 |             (error (e) nil)))))
 330 |     (if result
 331 |       (progn (when fallback (zpb-ttf:close-font-loader fallback))
 332 |         result)
 333 |       fallback)))
 334 | 
 335 | (defun get-font-file (&optional family-or-file)
 336 |   (if family-or-file 
 337 |     (when (or (not (or (pathname-directory family-or-file)
 338 |                        (pathname-type family-or-file)))
 339 |               (not (probe-file family-or-file)))
 340 |       #+mswindows
 341 |       (or (find-if (lambda (file)
 342 |                      (member (pathname-type file) '("ttf" "ttc" "otf" "otc")
 343 |                              :test #'string=))
 344 |                    (directory (make-pathname :name family-or-file :type :wild :defaults #P"C:/Windows/Fonts/")))
 345 |           *default-font-family*)
 346 |       #+darwin
 347 |       (or (find-if (lambda (file)
 348 |                      (member (pathname-type file) '("ttf" "ttc" "otf" "otc")
 349 |                              :test #'string=))
 350 |                    (directory (make-pathname :name family-or-file :type :wild :defaults #P"/System/Library/Fonts/")))
 351 |           *default-font-family*)
 352 |       #+(and unix (not darwin))
 353 |       (let ((fc-list (mapcar (lambda (str) (first (split-sequence #\: str)))
 354 |                              (split-sequence
 355 |                               #\Newline 
 356 |                               (with-output-to-string (*standard-output*)
 357 |                                 (uiop:run-program "fc-list" :output t))))))
 358 |         (or (find (string-append "/" family-or-file ".") fc-list :test #'search)
 359 |             (find family-or-file fc-list :test #'search)
 360 |             (find *default-font-description* fc-list :test #'search)
 361 |             (error "Cannot find available font. Please give a pathname to :FAMILY"))))
 362 |     *default-font-family*))
 363 | 
 364 | 
 365 | ;; (Partial) CSS parser
 366 | 
 367 | (defun css-parse-a-number (str &optional (start 0))
 368 |   (declare (type vector str) (type fixnum start)
 369 |            ;(:explain :types)
 370 |            )
 371 |   "Parsing a CSS number gracefully out of STR, starting from START.
 372 | 
 373 | Return the first number it met, and the end position of this number.
 374 | Return NIL if there isn't a number at START."
 375 |   ;; This function will be used heavily, so should be as fast as it can...
 376 |   (check-type str string)
 377 |   (let ((char-arr (make-array 8 :element-type 'character :fill-pointer 0 :adjustable t))
 378 |         (i start)
 379 |         (len (length str))
 380 |         has-dot
 381 |         has-exp)
 382 |     (declare (type vector char-arr exp)
 383 |              (type fixnum i len))
 384 |     (tagbody
 385 |      start
 386 |      (if (= i len) (go end))
 387 |      (let ((c (char str i)))
 388 |        (cond ((member c '(#\+ #\-))
 389 |               (if (= i start)
 390 |                 (vector-push-extend c char-arr)
 391 |                 (go end)))
 392 |              ((char= c #\.)
 393 |               (if has-dot (go end)
 394 |                 (progn
 395 |                   (setq has-dot t)
 396 |                   (vector-push-extend c char-arr))))
 397 |              ((char-equal c #\e)
 398 |               (if has-exp (go end)
 399 |                 (progn
 400 |                   (setq has-exp t)
 401 |                   (vector-push-extend c char-arr))))
 402 |              ((digit-char-p c)
 403 |               (vector-push-extend c char-arr))
 404 |              (t (go end))))
 405 |      (setq i (1+ i))
 406 |      (go start)
 407 |      end)
 408 |     (if (find-if #'digit-char-p char-arr)
 409 |       (values (parse-float char-arr :type 'double-float) i)
 410 |       nil)))
 411 | 
 412 | (defun css-parse-all-numbers-from-string (str)
 413 |   "Parse all CSS format numbers in STR, return as a vector."
 414 |   (declare (optimize (safety 0))
 415 |            (type string str))
 416 |   (let ((i 0)
 417 |         (len (length str))
 418 |         (numbers (make-array 15 :element-type 'double-float :fill-pointer 0 :adjustable t)))
 419 |     (declare (type fixnum i len))
 420 |     (tagbody
 421 |      start
 422 |      (if (= i len) (go end) nil)
 423 |      (let ((c (char str i)))
 424 |        (if (or (digit-char-p c) (member c '(#\+ #\-)))
 425 |          (multiple-value-bind (num idx)
 426 |              (css-parse-a-number str i)
 427 |            (if num
 428 |              (progn
 429 |                (vector-push-extend num numbers)
 430 |                (setq i idx)
 431 |                (go start))
 432 |              (go end)))
 433 |          (progn
 434 |            (setq i (1+ i))
 435 |            (go start))))
 436 |      end)
 437 |     numbers))
 438 | 
 439 | ;; CSS length-percentage
 440 | 
 441 | (defun css-parse-length (state str &optional (width-or-height :width) viewport-w viewport-h parent-w parent-h)
 442 |   "Parse a CSS format <length-percentage> to corresponding pixels,
 443 | based on current graphics port, CSS viewport and element's parent."
 444 |   ;; FIXME: Not fully tested
 445 |   (unless viewport-w (setq viewport-w (vecto::width state)))
 446 |   (unless viewport-h (setq viewport-h (vecto::height state)))
 447 |   (unless parent-w (setq parent-w viewport-w))
 448 |   (unless parent-h (setq parent-h viewport-h))
 449 |   (when str
 450 |     (if (alpha-char-p (char str 0)) 0
 451 |       (multiple-value-bind (len len-end) (css-parse-a-number str)
 452 |         (declare (type fixnum len-end viewport-w viewport-h parent-w parent-h)
 453 |                  (type double-float len))
 454 |         (let* ((unit (subseq str len-end))
 455 |                (font (vecto::font-loaders state))
 456 |                (size (vecto::size (vecto::font state))))
 457 |           (* len
 458 |              (string-case (unit)
 459 |                ;; abs https://www.w3.org/TR/css-values/#absolute-lengths
 460 |                ("cm"   37.79527559055118D0) ;(/ 96d0 2.54d0)
 461 |                ("mm"   3.7795275590551185D0) ;(/ 96d0 25.4d0)
 462 |                ("Q"    0.9448818897637794D0) ;(/ 96d0 2.54d0 40d0)
 463 |                ("in"   96d0)
 464 |                ("pt"   1.3333333333333333D0) ;(coerce 4/3 'double-float)
 465 |                ("pc"   16d0)
 466 |                ("px"   1d0)
 467 |                ;; rel https://www.w3.org/TR/css-values/#relative-lengths
 468 |                ("em"   size)
 469 |                ("rem"  size)
 470 |                ;; FIXME: not precise value
 471 |                ("ex"   (get-glyph-height #\x font size))
 472 |                ("rex"  (get-glyph-height #\x font size))
 473 |                ("cap"  (get-glyph-height #\O font size))
 474 |                ("ch"   (get-glyph-width #\0 font size))
 475 |                ("rch"  (get-glyph-width #\0 font size))
 476 |                ("ic"   (get-char-width #\ideographic-space font size))
 477 |                ("ric"  (get-char-width #\ideographic-space font size))
 478 |                ("lh"   (let* ((scale (vecto::loader-font-scale size font))
 479 |                               (glyph (zpb-ttf:find-glyph "M" font)))
 480 |                          (* (+ (zpb-ttf:advance-width glyph) (zpb-ttf:line-gap font)) scale)))
 481 |                ("rlh"  (let* ((scale (vecto::loader-font-scale size font))
 482 |                               (glyph (zpb-ttf:find-glyph "M" font)))
 483 |                          (* (+ (zpb-ttf:advance-width glyph) (zpb-ttf:line-gap font)) scale)))
 484 |                ("vw"   (/ viewport-w 100d0))
 485 |                ("vi"   (/ viewport-w 100d0))
 486 |                ("vh"   (/ viewport-h 100d0))
 487 |                ("vb"   (/ viewport-h 100d0))
 488 |                ("vmin" (min (/ viewport-w 100d0) (/ viewport-h 100d0)))
 489 |                ("vmax" (max (/ viewport-w 100d0) (/ viewport-h 100d0)))
 490 |                ("%"    (if (eq width-or-height :width)
 491 |                          (/ parent-w 100)
 492 |                          (/ parent-h 100)))
 493 |                (t      1d0))))))))
 494 | 
 495 | (defparameter *css-length-percentage-scanner*
 496 |   (ppcre:create-scanner
 497 |    "-?((\\d+(\\.\\d+)?)|(\\.\\d+))([eE]\\d+)?(?:cm|mm|Q|in|pt|pc|px|r?em|r?ex|cap|r?ch|r?ic|r?lh|vw|vi|vh|vb|vmin|vmax|%)?"))
 498 | 
 499 | (defun css-parse-all-length-from-string (state str &optional (width-or-height :width) viewport-w viewport-h parent-w parent-h)
 500 |   "Parse all CSS <length-percentage> from STR and convert them to pixels."
 501 |   (mapcar (lambda (sub)
 502 |             (css-parse-length state sub width-or-height viewport-w viewport-h parent-w parent-h))
 503 |           (ppcre:all-matches-as-strings *css-length-percentage-scanner* str)))
 504 | 
 505 | ;; CSS color
 506 | 
 507 | (defvar *css-color-keywords* (make-hash-table :test #'equalp :size 149)
 508 |   "A map of CSS basic color keywords, from name to LW color spec.
 509 | 
 510 | https://www.w3.org/TR/css-color-3/#html4")
 511 | 
 512 | (dolist (i '(("aliceblue" "#F0F8FF")       ("antiquewhite" "#FAEBD7")      ("aqua" "#00FFFF")                 ("aquamarine" "#7FFFD4")
 513 |              ("azure" "#F0FFFF")           ("beige" "#F5F5DC")             ("bisque" "#FFE4C4")               ("black" "#000000")
 514 |              ("blanchedalmond" "#FFEBCD")  ("blue" "#0000FF")              ("blueviolet" "#8A2BE2")           ("brown" "#A52A2A")
 515 |              ("burlywood" "#DEB887")       ("cadetblue" "#5F9EA0")         ("chartreuse" "#7FFF00")           ("chocolate" "#D2691E")
 516 |              ("coral" "#FF7F50")           ("cornflowerblue" "#6495ED")    ("cornsilk" "#FFF8DC")             ("crimson" "#DC143C")
 517 |              ("cyan" "#00FFFF")            ("darkblue" "#00008B")          ("darkcyan" "#008B8B")             ("darkgoldenrod" "#B8860B")
 518 |              ("darkgray" "#A9A9A9")        ("darkgreen" "#006400")         ("darkgrey" "#A9A9A9")             ("darkkhaki" "#BDB76B")
 519 |              ("darkmagenta" "#8B008B")     ("darkolivegreen" "#556B2F")    ("darkorange" "#FF8C00")           ("darkorchid" "#9932CC")
 520 |              ("darkred" "#8B0000")         ("darksalmon" "#E9967A")        ("darkseagreen" "#8FBC8F")         ("darkslateblue" "#483D8B")
 521 |              ("darkslategray" "#2F4F4F")   ("darkslategrey" "#2F4F4F")     ("darkturquoise" "#00CED1")        ("darkviolet" "#9400D3")
 522 |              ("deeppink" "#FF1493")        ("deepskyblue" "#00BFFF")       ("dimgray" "#696969")              ("dimgrey" "#696969")
 523 |              ("dodgerblue" "#1E90FF")      ("firebrick" "#B22222")         ("floralwhite" "#FFFAF0")          ("forestgreen" "#228B22")
 524 |              ("fuchsia" "#FF00FF")         ("gainsboro" "#DCDCDC")         ("ghostwhite" "#F8F8FF")           ("gold" "#FFD700")
 525 |              ("goldenrod" "#DAA520")       ("gray" "#808080")              ("green" "#008000")                ("greenyellow" "#ADFF2F")
 526 |              ("grey" "#808080")            ("honeydew" "#F0FFF0")          ("hotpink" "#FF69B4")              ("indianred" "#CD5C5C")
 527 |              ("indigo" "#4B0082")          ("ivory" "#FFFFF0")             ("khaki" "#F0E68C")                ("lavender" "#E6E6FA")
 528 |              ("lavenderblush" "#FFF0F5")   ("lawngreen" "#7CFC00")         ("lemonchiffon" "#FFFACD")         ("lightblue" "#ADD8E6")
 529 |              ("lightcoral" "#F08080")      ("lightcyan" "#E0FFFF")         ("lightgoldenrodyellow" "#FAFAD2") ("lightgray" "#D3D3D3")
 530 |              ("lightgreen" "#90EE90")      ("lightgrey" "#D3D3D3")         ("lightpink" "#FFB6C1")            ("lightsalmon" "#FFA07A")
 531 |              ("lightseagreen" "#20B2AA")   ("lightskyblue" "#87CEFA")      ("lightslategray" "#778899")       ("lightslategrey" "#778899")
 532 |              ("lightsteelblue" "#B0C4DE")  ("lightyellow" "#FFFFE0")       ("lime" "#00FF00")                 ("limegreen" "#32CD32")
 533 |              ("linen" "#FAF0E6")           ("magenta" "#FF00FF")           ("maroon" "#800000")               ("mediumaquamarine" "#66CDAA")
 534 |              ("mediumblue" "#0000CD")      ("mediumorchid" "#BA55D3")      ("mediumpurple" "#9370DB")         ("mediumseagreen" "#3CB371")
 535 |              ("mediumslateblue" "#7B68EE") ("mediumspringgreen" "#00FA9A") ("mediumturquoise" "#48D1CC")      ("mediumvioletred" "#C71585")
 536 |              ("midnightblue" "#191970")    ("mintcream" "#F5FFFA")         ("mistyrose" "#FFE4E1")            ("moccasin" "#FFE4B5")
 537 |              ("navajowhite" "#FFDEAD")     ("navy" "#000080")              ("oldlace" "#FDF5E6")              ("olive" "#808000")
 538 |              ("olivedrab" "#6B8E23")       ("orange" "#FFA500")            ("orangered" "#FF4500")            ("orchid" "#DA70D6")
 539 |              ("palegoldenrod" "#EEE8AA")   ("palegreen" "#98FD98")         ("paleturquoise" "#AFEEEE")        ("palevioletred" "#DB7093")
 540 |              ("papayawhip" "#FFEFD5")      ("peachpuff" "#FFDAB9")         ("peru" "#CD853F")                 ("pink" "#FFC0CD")
 541 |              ("plum" "#DDA0DD")            ("powderblue" "#B0E0E6")        ("purple" "#800080")               ("red" "#FF0000")
 542 |              ("rosybrown" "#BC8F8F")       ("royalblue" "#4169E1")         ("saddlebrown" "#8B4513")          ("salmon" "#FA8072")
 543 |              ("sandybrown" "#F4A460")      ("seagreen" "#2E8B57")          ("seashell" "#FFF5EE")             ("sienna" "#A0522D")
 544 |              ("silver" "#C0C0C0")          ("skyblue" "#87CEEB")           ("slateblue" "#6A5ACD")            ("slategray" "#708090")
 545 |              ("slategrey" "#708090")       ("snow" "#FFFAFA")              ("springgreen" "#00FF7F")          ("steelblue" "#4682B4")
 546 |              ("tan" "#D2B48C")             ("teal" "#008080")              ("thistle" "#D8BFD8")              ("tomato" "#FF6347")
 547 |              ("turquoise" "#40E0D0")       ("saddlebrown" "#8B4513")       ("violet" "#EE82EE")               ("wheat" "#F5DEB3")
 548 |              ("white" "#FFFFFF")           ("whitesmoke" "#F5F5F5")        ("yellow" "#FFFF00")               ("yellowgreen" "#9ACD32")))
 549 |   (setf (gethash (first i) *css-color-keywords*)
 550 |         (hex-to-spec (second i))))
 551 | 
 552 | (setf (gethash "transparent" *css-color-keywords*) (make-rgb 0.0 0.0 0.0 0.0))
 553 | 
 554 | ;; For scanning valid arguments of the numeric color function
 555 | ;; e.g. rgb(255, 0, 0)
 556 | (defparameter *css-color-numeric-regexp* (ppcre:create-scanner "[\\d\\-\\.%]+"))
 557 | 
 558 | (defun css-parse-numeric-color (str)
 559 |   "Parse a CSS numerical color value to LW color spec.
 560 | 
 561 | https://www.w3.org/TR/css-color-3/#numerical"
 562 |   (let ((params (ppcre:all-matches-as-strings *css-color-numeric-regexp* str)))
 563 |     (flet ((parse-num (str)
 564 |              (let ((num (parse-integer str :junk-allowed t)))
 565 |                (if (eql (char str (1- (length str))) #\%)
 566 |                  (/ (clamp num 0 100) 100)
 567 |                  (/ (clamp num 0 255) 255)))))
 568 |       (let ((func (cond ((string-prefix-p "rgb" str) #'make-rgb)
 569 |                         ((string-prefix-p "hsl" str) #'make-hsv))))
 570 |         (destructuring-bind (x y z) (mapcar #'parse-num (subseq params 0 3))
 571 |           (if (= (length params) 4)
 572 |             (let ((alpha (clamp (parse-float (nth 3 params)) 0.0 1.0)))
 573 |               (funcall func x y z alpha))
 574 |             (funcall func x y z)))))))
 575 | 
 576 | (defun css-parse-color (str)
 577 |   "Parse a valid CSS color to LW color spec."
 578 |   (unless (or (null str) (member str '("none" "auto") :test #'equalp))
 579 |     (if (eql (char str 0) #\#)
 580 |       (hex-to-spec str)
 581 |       (if (or (string-prefix-p "rgb" str) (string-prefix-p "hsl" str))
 582 |         (css-parse-numeric-color str)
 583 |         (gethash str *css-color-keywords*)))))
 584 | 
 585 | ;; CSS angle
 586 | 
 587 | (defun css-parse-angel (str &optional (start 0))
 588 |   "Parse a CSS <angel> to radians from START of the STR.
 589 | 
 590 | Return the radians and the end of parsing.
 591 | 
 592 | https://www.w3.org/TR/css3-values/#angles"
 593 |   (let ((len (length str)))
 594 |     (multiple-value-bind (num end-pos) (css-parse-a-number str start)
 595 |       (unless (null num)
 596 |         (cond ((search "grad" str :start2 end-pos :end2 (min len (+ end-pos 4)))
 597 |                (values (deg-to-rad (* num 0.9d0)) (+ end-pos 4)))
 598 |               ((search "rad" str :start2 end-pos :end2 (min len (+ end-pos 3)))
 599 |                (values num (+ end-pos 3)))
 600 |               ((search "turn" str :start2 end-pos :end2 (min len (+ end-pos 4)))
 601 |                (values (* num 2pi) (+ end-pos 4)))
 602 |               ((search "deg" str :start2 end-pos :end2 (min len (+ end-pos 3)))
 603 |                (values (deg-to-rad num) (+ end-pos 3)))
 604 |               (t (values (deg-to-rad num) end-pos)))))))
 605 | 
 606 | (defun css-parse-all-angels-from-string (str)
 607 |   "Parse a CSS <angel> to radians in STR, return as a vector"
 608 |   (let ((i 0)
 609 |         (len (length str))
 610 |         (numbers (make-array 15 :element-type 'double-float :fill-pointer 0 :adjustable t)))
 611 |     (declare (type fixnum i len))
 612 |     (tagbody
 613 |      start
 614 |      (if (= i len) (go end) nil)
 615 |      (let ((c (char str i)))
 616 |        (if (or (digit-char-p c) (member c '(#\+ #\-)))
 617 |          (multiple-value-bind (num idx)
 618 |              (css-parse-angel str i)
 619 |            (if num
 620 |              (progn
 621 |                (vector-push-extend num numbers)
 622 |                (setq i idx)
 623 |                (go start))
 624 |              (go end)))
 625 |          (progn
 626 |            (setq i (1+ i))
 627 |            (go start))))
 628 |      end)
 629 |     numbers))
 630 | 
 631 | ;; CSS transform
 632 | 
 633 | (defparameter *transform-scanner*
 634 |   (ppcre:create-scanner "(matrix|scale(?:X|Y)?|translate(?:X|Y)?|rotate|skew(?:X|Y)?)\\((?:.|\\s)+?\\)")
 635 |   "Scanner for searching CSS <transform-function>s.
 636 | 
 637 | https://www.w3.org/TR/css-transforms-1/#transform-functions")
 638 | 
 639 | (defun css-parse-transforms (state str &optional viewport-w viewport-h parent-w parent-h)
 640 |   "Parse a CSS transform property value to a list of TRANSFORMs.
 641 | 
 642 | https://www.w3.org/TR/css-transforms-1/#transform-property"
 643 |   (let (transforms)
 644 |     (ppcre:do-scans (match-start match-end fname-starts fname-ends
 645 |                                  *transform-scanner* str)
 646 |       (declare (ignore match-start))
 647 |       (setq fname-starts (aref fname-starts 0)
 648 |             fname-ends (aref fname-ends 0))
 649 |       (let* ((fname (subseq str fname-starts fname-ends))
 650 |              (args-str (subseq str (1+ fname-ends) (1- match-end)))
 651 |              (args (cond ((member fname '("rotate" "skew" "skewX" "skewY") :test #'string=)
 652 |                           (css-parse-all-angels-from-string args-str))
 653 |                          ((member fname '("translate" "translateX" "translateY") :test #'string=)
 654 |                           (split-sequence-if (lambda (c) (member c '(#\, #\Space))) args-str
 655 |                                              :remove-empty-subseqs t))
 656 |                          (t (css-parse-all-numbers-from-string args-str)))))
 657 |         (if (string= fname "matrix")
 658 |           (push-end (apply #'make-transform (coerce args 'list)) transforms)
 659 |           (let ((trans (make-transform)))
 660 |             (string-case (fname)
 661 |               ("scale" (apply-scale trans (aref args 0) (aref args (if (= (length args) 1) 0 1))))
 662 |               ("scaleX" (apply-scale trans (aref args 0) 1))
 663 |               ("scaleY" (apply-scale trans 1 (aref args 0)))
 664 |               ("translate" (apply-translation
 665 |                             trans
 666 |                             (css-parse-length state (first args) :width viewport-w viewport-h parent-w parent-h)
 667 |                             (css-parse-length state (or (second args) (first args)) :height viewport-w viewport-h parent-w parent-h)))
 668 |               ("translateX" (apply-translation
 669 |                              trans
 670 |                              (css-parse-length state (first args) :width viewport-w viewport-h parent-w parent-h)
 671 |                              1))
 672 |               ("translateY" (apply-translation
 673 |                              trans 1
 674 |                              (css-parse-length state (first args) :height viewport-w viewport-h parent-w parent-h)))
 675 |               ("rotate" (apply-rotation trans (aref args 0)))
 676 |               ("skew"
 677 |                (setf (nth 1 trans) (tan (aref args 0)))
 678 |                (setf (nth 2 trans) (if (= (length args) 1) 0 (tan (aref args 0)))))
 679 |               ("skewX" (setf (nth 1 trans) (tan (aref args 0))))
 680 |               ("skewY" (setf (nth 2 trans) (tan (aref args 0)))))
 681 |             (push-end trans transforms)))))
 682 |     transforms))
 683 | 
 684 | ;; CSS url
 685 | 
 686 | (defparameter *css-url-scanner*
 687 |   (ppcre:create-scanner "(?:url\\(\"(.+)\"\\))|(?:url\\('(.+)'\\))|(?:url\\((.+)\\))"))
 688 | 
 689 | (defun css-parse-url (str root-node)
 690 |   "Return the element targeted by t§he URL expression inside STR."
 691 |   (multiple-value-bind (whole arr)
 692 |       (ppcre:scan-to-strings *css-url-scanner* str)
 693 |     (declare (ignore whole))
 694 |     (let ((url (or (aref arr 0) (aref arr 1) (aref arr 2))))
 695 |       (if (or (null url) (not (eql (char url 0) #\#)))
 696 |         (error "LW-SVG only support ID url selector.")
 697 |         (plump-dom:get-element-by-id root-node (subseq url 1))))))
 698 | 
 699 | ;; CSS `style` parser
 700 | 
 701 | (defun css-parse-style-properties (str)
 702 |   "Parse CSS style content STR to a hash-table"
 703 |   (setq str (string-trim-whitespace str))
 704 |   (let ((table (make-hash-table :test #'equalp)))
 705 |     (mapcar (lambda (str)
 706 |               (destructuring-bind (name val)
 707 |                   (mapcar #'string-trim-whitespace (split-sequence #\: str :remove-empty-subseqs t))
 708 |                 (setf (gethash name table) val)))
 709 |             (mapcar #'string-trim-whitespace (split-sequence #\; str :remove-empty-subseqs t)))
 710 |     table))
 711 | 
 712 | (defmacro css-parse-class (node)
 713 |   `(split-sequence #\Space (plump:attribute ,node "class") :remove-empty-subseqs t))
 714 | 
 715 | (defparameter *css-class-name-scanner*
 716 |   (ppcre:create-scanner "[A-Za-z][A-Za-z0-9\\-_]*"))
 717 | 
 718 | (defparameter *css-id-scanner*
 719 |   (ppcre:create-scanner "[A-Za-z][A-Za-z0-9\\-_:\\.]*"))
 720 | 
 721 | (defparameter *css-attribute-selector-scanner*
 722 |   (ppcre:create-scanner "\\[([A-Za-z]+)((?:~|\\|)?=)?([A-Za-z]+)?\\]"))
 723 | 
 724 | (defun css-parse-a-selector (str)
 725 |   "Parse one CSS selector from a CSS selector list (separated by #\,)
 726 | 
 727 | Return a function that accept one argument PLUMP:NODE, which will
 728 | return a non-nil value if the node conforms the selector."
 729 |   (let ((index 0)
 730 |         (len (length str))
 731 |         funcs)
 732 |     (tagbody
 733 |      start
 734 |      (let ((first-char (char str index)))
 735 |        (case first-char
 736 |          (#\. (multiple-value-bind (start end)
 737 |                   (ppcre:scan *css-class-name-scanner* str :start index)
 738 |                 (let ((cla (subseq str start end)))
 739 |                   (push (lambda (node) (member cla (css-parse-class node) :test #'string=)) funcs))
 740 |                 (setq index end)))
 741 |          (#\# (multiple-value-bind (start end)
 742 |                   (ppcre:scan *css-id-scanner* str :start index)
 743 |                 (let ((id (subseq str start end)))
 744 |                   (push (lambda (node) (equal id (plump:attribute node "id"))) funcs))
 745 |                 (setq index end)))
 746 |          (#\[ (multiple-value-bind (start end rs re)
 747 |                   (ppcre:scan *css-attribute-selector-scanner* str :start index)
 748 |                 (declare (ignore start))
 749 |                 (let ((attr (subseq str (aref rs 0) (aref re 0)))
 750 |                       (op (when (aref rs 1)
 751 |                             (subseq str (aref rs 1) (aref re 1))))
 752 |                       (val (when (aref rs 2)
 753 |                              (string-trim '(#\") (subseq str (aref rs 2) (aref re 2))))))
 754 |                   (push
 755 |                    (if op
 756 |                      (case (char op 0)
 757 |                        (#\= (lambda (node) (equal (plump:attribute node attr) val)))
 758 |                        (#\~ (lambda (node)
 759 |                               (member val (split-sequence #\Space (plump:attribute node attr))
 760 |                                       :test #'equal)))
 761 |                        (#\| (lambda (node)
 762 |                               (let ((x (plump:attribute node attr)))
 763 |                                 (or (equal x val)
 764 |                                     (and (stringp x)
 765 |                                          (string-prefix-p (string-append x "-") val)))))))
 766 |                      (lambda (node) (plump:attribute node attr)))
 767 |                    funcs))
 768 |                 (setq index end)))
 769 |          (#\Space (let ((prev-func (pop funcs))
 770 |                         (sub-func (css-parse-a-selector (subseq str (1+ index)))))
 771 |                     (push
 772 |                      (lambda (node)
 773 |                        (and (loop for parent = (plump:parent node) then (plump:parent parent)
 774 |                                   until (or (plump:root-p parent) (null parent))
 775 |                                   thereis (funcall prev-func parent))
 776 |                             (funcall sub-func node)))
 777 |                      funcs)
 778 |                     (setq index len)))
 779 |          (t (if (alpha-char-p first-char)
 780 |               (let* ((end (or (position-if-not #'alpha-char-p str :start index) len))
 781 |                      (name (subseq str index end)))
 782 |                 (push (lambda (node) (equal name (plump:tag-name node))) funcs)
 783 |                 (setq index end))
 784 |               (setq index len)))))
 785 |      (if (< index len)
 786 |        (go start)))
 787 |     (lambda (node)
 788 |       (every (lambda (func) (funcall func node)) funcs))))
 789 | 
 790 | (defun css-parse-selectors (str)
 791 |   "Parse a CSS selector list.
 792 | 
 793 | Return a function that accept one argument PLUMP:NODE, which will
 794 | return a non-nil value if the node conforms the selector."
 795 |   (let ((selectors (mapcar #'css-parse-a-selector
 796 |                            (mapcar #'string-trim-whitespace
 797 |                                    (split-sequence #\, str :remove-empty-subseqs t)))))
 798 |     (lambda (node)
 799 |       (some (lambda (func) (funcall func node)) selectors))))
 800 | 
 801 | (defparameter *css-style-block-scanner*
 802 |   (ppcre:create-scanner "([^\\{\\}]+?)\\{([^\\{\\}]+?)\\}"))
 803 | 
 804 | (defun css-parse-style-element (node)
 805 |   "Giving a `<style>` element, return an alist which has the function
 806 | of the CSS selector as CAR, and a hash-table of corresponding
 807 | properties as CDR."
 808 |   (let ((str (string-trim-whitespace (plump:text node)))
 809 |         result)
 810 |     (ppcre:do-scans (ms me rs re *css-style-block-scanner* str)
 811 |       (when (every #'identity rs)
 812 |         (let ((selector (css-parse-selectors (subseq str (aref rs 0) (aref re 0))))
 813 |               (props (css-parse-style-properties (subseq str (aref rs 1) (aref re 1)))))
 814 |           (push (cons selector props) result))))
 815 |     result))
 816 | 
 817 | 
 818 | ;; Deal with SVG path data
 819 | 
 820 | ;; TODO: https://svgwg.org/svg2-draft/implnote.html#ArcCorrectionOutOfRangeRadii
 821 | (defun convert-svg-arc (x1 y1 rx ry fai fa fs x2 y2)
 822 |   "Conversion from endpoint to center parameterization.
 823 | 
 824 | Returns a list, the CAR is :ARC, the CDR conforms to the arglist of
 825 | VECTO::APPROXIMATE-ELLIPTICAL-ARC.
 826 | 
 827 | https://svgwg.org/svg2-draft/implnote.html#ArcImplementationNotes"
 828 |   (declare (optimize (float 0) (safety 0) (speed 3) (space 0))
 829 |            (type double-float x1 y1 rx ry x2 y2 fa fs fai)
 830 |            ;(:explain :non-floats)
 831 |            )
 832 |   (setq fai (* (/ fai 180.0) pi))
 833 |   (let* ((sinfai (sin fai))
 834 |          (-sinfai (- sinfai))
 835 |          (cosfai (cos fai))
 836 |          (x1-x2/2 (/ (- x1 x2) 2.0))
 837 |          (y1-y2/2 (/ (- y1 y2) 2.0))
 838 |          (x1p (+ (* x1-x2/2 cosfai) (* y1-y2/2 sinfai)))
 839 |          (y1p (+ (* x1-x2/2 -sinfai) (* y1-y2/2 cosfai)))
 840 |          (rx^ (* rx rx))
 841 |          (ry^ (* ry ry))
 842 |          (lamb (+ (/ (* x1p x1p) rx^) (/ (* y1p y1p) ry^))))
 843 |     (declare (type double-float rx ry rx^ ry^))
 844 |     (if (> lamb 1)
 845 |       ;; We add a very little constant to the enlarged radii,
 846 |       ;; to compensate the probable loss during float-point calculation,
 847 |       ;; ensure we always have a valid solution for RC
 848 |       (setq rx (+ (* rx (sqrt lamb)) 1d-6)
 849 |             ry (+ (* ry (sqrt lamb)) 1d-6)
 850 |             rx^ (* rx rx)
 851 |             ry^ (* ry ry)))
 852 |     (let* ((rc (let ((rc (sqrt
 853 |                           (- (/ (* rx^ ry^)
 854 |                                 (+ (* rx^ y1p y1p) (* ry^ x1p x1p)))
 855 |                              1.0))))
 856 |                  (if (= fa fs) (- rc) rc)))
 857 |            (cxp (* rc (/ (* rx y1p) ry)))
 858 |            (cyp (* rc (- (/ (* ry x1p) rx))))
 859 |            (cx (+ (* cxp cosfai) (* cyp -sinfai) (/ (+ x1 x2) 2.0)))
 860 |            (cy (+ (* cxp sinfai) (* cyp cosfai)  (/ (+ y1 y2) 2.0))))
 861 |       (flet ((angle (ux uy vx vy)
 862 |                (declare (inline angle) (type double-float ux uy vx vy))
 863 |                (let ((arc (acos (/ (+ (* ux vx) (* uy vy))
 864 |                                    (* (sqrt (+ (* ux ux) (* uy uy)))
 865 |                                       (sqrt (+ (* vx vx) (* vy vy))))))))
 866 |                  (declare (type double-float arc))
 867 |                  (if (minusp (- (* ux vy) (* uy vx)))
 868 |                    (- arc) arc))))
 869 |         (let* ((vx (/ (- x1p cxp) rx))
 870 |                (vy (/ (- y1p cyp) ry))
 871 |                (start (angle 1.0d0 0.0d0 vx vy))
 872 |                (sweep (mod (angle vx vy (/ (- (- x1p) cxp) rx) (/ (- (- y1p) cyp) ry))
 873 |                            2pi)))
 874 |           (declare (type double-float start sweep))
 875 |           (if (= fs 0d0)
 876 |             (when (plusp sweep) (setq sweep (- sweep 2pi)))
 877 |             (when (minusp sweep) (setq sweep (- sweep 2pi))))
 878 |           ;; Modified for TRIVIAL-SVG
 879 |           (list :arc cx cy rx ry fai start (+ start sweep)))))))
 880 | 
 881 | (defstruct svg-path-command
 882 |   (char #\Null :type character)
 883 |   (args (make-array 8 :element-type 'double-float :fill-pointer 0 :adjustable t)
 884 |         :type (vector double-float)))
 885 | 
 886 | (defmacro do-svg-path-arguments ((args &rest variables) &body body)
 887 |   (let ((arg-count (length variables)))
 888 |     (with-unique-names (start index len)
 889 |       `(let ((,index 0)
 890 |              (,len (length ,args)))
 891 |          (declare (type fixnum start))
 892 |          (tagbody
 893 |           ,start
 894 |           (let ,(loop for i from 0
 895 |                       for var in variables
 896 |                       collect (list var `(aref ,args (+ ,index ,i))))
 897 |             (declare (type double-float ,@variables))
 898 |             ,@body)
 899 |           (setq ,index (the fixnum (+ ,index ,arg-count)))
 900 |           (when (> ,len ,index)
 901 |             (go ,start)))))))
 902 | 
 903 | ;; https://www.w3.org/TR/2018/CR-SVG2-20181004/paths.html
 904 | (defun convert-path-commands (commands)
 905 |   "Convert a vector of parsed SVG <path> element data (see
 906 | SVG-PARSE-PATH-DATA below) to a vector of PATH that conform with
 907 | LispWorks GP:DRAW-PATH."
 908 |   (declare (type (vector svg-path-command) commands)
 909 |            (optimize (float 0) (safety 0) (speed 3) (debug 0))
 910 |            ;(:explain :non-floats :print-original-form)
 911 |            )
 912 |   (let ((cpx 0d0) (cpy 0d0)
 913 |         (ocx2 0d0) (ocy2 0d0)
 914 |         (oqx 0d0) (oqy 0d0)
 915 |         last-cubic-p
 916 |         last-quadratic-p
 917 |         last-move-p
 918 |         (path (make-array (length commands) :fill-pointer 0 :adjustable t)))
 919 |     (declare (type double-float cpx cpy ocx2 ocy2 oqx oqy))
 920 |     (macrolet ((push-path (data) `(vector-push-extend ,data path))
 921 |                (line-absolute (x y)
 922 |                  `(progn
 923 |                     (push-path (list :line ,x ,y))
 924 |                     (setq cpx ,x cpy ,y)))
 925 |                (line-relative (x y)
 926 |                  `(progn
 927 |                     (setq cpx (+ cpx ,x) cpy (+ cpy ,y))
 928 |                     (push-path (list :line cpx cpy)))))
 929 |       (dotimes (i (length commands))
 930 |         (let* ((command (aref commands i))
 931 |                (char (svg-path-command-char command))
 932 |                (args (svg-path-command-args command)))
 933 |           (case char
 934 |             (#\M
 935 |              (do-svg-path-arguments (args x y)
 936 |                (setq cpx x cpy y)
 937 |                (push-path (list (if last-move-p :line :move) x y))
 938 |                (setq last-move-p t)))
 939 |             (#\m
 940 |              (do-svg-path-arguments (args x y)
 941 |                (setq cpx (+ cpx x)
 942 |                      cpy (+ cpy y))
 943 |                (push-path (list (if last-move-p :line :move) cpx cpy))
 944 |                (setq last-move-p t)))
 945 |             ((or #\Z #\z)
 946 |              (push-path (list :close)))
 947 |             (#\L
 948 |              (do-svg-path-arguments (args x y)
 949 |                (line-absolute x y)))
 950 |             (#\l
 951 |              (do-svg-path-arguments (args x y)
 952 |                (line-relative x y)))
 953 |             (#\H
 954 |              (do-svg-path-arguments (args x)
 955 |                (line-absolute x cpy)))
 956 |             (#\V
 957 |              (do-svg-path-arguments (args y)
 958 |                (line-absolute cpx y)))
 959 |             (#\h
 960 |              (do-svg-path-arguments (args x)
 961 |                (line-relative x 0.0d0)))
 962 |             (#\v
 963 |              (do-svg-path-arguments (args y)
 964 |                (line-relative 0.0d0 y)))
 965 |             (#\C
 966 |              (do-svg-path-arguments (args cx1 cy1 cx2 cy2 nx ny)
 967 |                (setq cpx nx cpy ny
 968 |                      ocx2 cx2 ocy2 cy2)
 969 |                (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny))))
 970 |             (#\c
 971 |              (do-svg-path-arguments (args rcx1 rcy1 rcx2 rcy2 rnx rny)
 972 |                (let ((cx1 (- rcx1 cpx)) (cy1 (- rcy1 cpy))
 973 |                      (cx2 (- rcx2 cpx)) (cy2 (- rcy2 cpy))
 974 |                      (nx (- rnx cpx)) (ny (- rny cpy)))
 975 |                  (setq cpx nx cpy ny
 976 |                        ocx2 cx2 ocy2 cy2)
 977 |                  (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny)))))
 978 |             (#\S
 979 |              (do-svg-path-arguments (args cx2 cy2 nx ny)
 980 |                (let ((cx1 (if last-cubic-p (- (* cpx 2.0d0) ocx2)
 981 |                             cpx))
 982 |                      (cy1 (if last-cubic-p (- (* cpy 2.0d0) ocy2)
 983 |                             cpy)))
 984 |                  (setq cpx nx cpy ny
 985 |                        ocx2 cx2 ocy2 cy2
 986 |                        last-cubic-p t)
 987 |                  (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny)))))
 988 |             (#\s
 989 |              (do-svg-path-arguments (args rcx2 rcy2 rnx rny)
 990 |                (let ((cx1 (if last-cubic-p (- (* cpx 2.0d0) ocx2)
 991 |                             cpx))
 992 |                      (cy1 (if last-cubic-p (- (* cpy 2.0d0) ocy2)
 993 |                             cpy))
 994 |                      (cx2 (+ cpx rcx2)) (cy2 (+ cpy rcy2))
 995 |                      (nx (+ cpx rnx)) (ny (+ cpy rny)))
 996 |                  (setq cpx nx cpy ny
 997 |                        ocx2 cx2 ocy2 cy2
 998 |                        last-cubic-p t)
 999 |                  (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny)))))
1000 |             (#\Q
1001 |              (do-svg-path-arguments (args qcx1 qcy1 nx ny)
1002 |                (let ((cx1 (+ cpx (/ (* (- qcx1 cpx) 2.0d0) 3.0d0)))
1003 |                      (cy1 (+ cpy (/ (* (- qcy1 cpy) 2.0d0) 3.0d0)))
1004 |                      (cx2 (+ nx (/ (* (- qcx1 nx) 2.0d0) 3.0d0)))
1005 |                      (cy2 (+ ny (/ (* (- qcy1 ny) 2.0d0) 3.0d0))))
1006 |                  (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny))
1007 |                  (setq cpx nx cpy ny
1008 |                        oqx qcx1 oqy qcy1
1009 |                        last-quadratic-p t))))
1010 |             (#\q
1011 |              (do-svg-path-arguments (args rqcx1 rqcy1 rnx rny)
1012 |                (let ((qcx1 (+ cpx rqcx1))
1013 |                      (qcy1 (+ cpy rqcy1))
1014 |                      (nx (+ cpx rnx))
1015 |                      (ny (+ cpy rny)))
1016 |                  (let ((cx1 (+ cpx (/ (* (- qcx1 cpx) 2d0) 3d0)))
1017 |                        (cy1 (+ cpy (/ (* (- qcy1 cpy) 2d0) 3d0)))
1018 |                        (cx2 (+ nx (/ (* (- qcx1 nx) 2d0) 3d0)))
1019 |                        (cy2 (+ ny (/ (* (- qcy1 ny) 2d0) 3d0))))
1020 |                    (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny))
1021 |                    (setq cpx (+ cpx rnx) cpy (+ cpy rny)
1022 |                          oqx qcx1 oqy qcy1
1023 |                          last-quadratic-p t)))))
1024 |             (#\T
1025 |              (do-svg-path-arguments (args nx ny)
1026 |                (if last-quadratic-p
1027 |                  (let ((qcx1 (- (* cpx 2d0) oqx))
1028 |                        (qcy1 (- (* cpy 2d0) oqy)))
1029 |                    (let ((cx1 (+ cpx (/ (* (- qcx1 cpx) 2d0) 3d0)))
1030 |                          (cy1 (+ cpy (/ (* (- qcy1 cpy) 2d0) 3d0)))
1031 |                          (cx2 (+ nx (/ (* (- qcx1 nx) 2d0) 3d0)))
1032 |                          (cy2 (+ ny (/ (* (- qcy1 ny) 2d0) 3d0))))
1033 |                      (setq oqx qcx1 oqy qcy1 last-quadratic-p t)
1034 |                      (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny))))
1035 |                  (push-path (list :line nx ny)))
1036 |                (setq cpx nx cpy ny)))
1037 |             (#\t
1038 |              (do-svg-path-arguments (args rnx rny)
1039 |                (let ((nx (+ cpx rnx))
1040 |                      (ny (+ cpy rny)))
1041 |                  (if last-quadratic-p
1042 |                    (let ((qcx1 (- (* cpx 2d0) oqx))
1043 |                          (qcy1 (- (* cpy 2d0) oqy)))
1044 |                      (let ((cx1 (+ cpx (/ (* (- qcx1 cpx) 2d0) 3d0)))
1045 |                            (cy1 (+ cpy (/ (* (- qcy1 cpy) 2d0) 3d0)))
1046 |                            (cx2 (+ nx (/ (* (- qcx1 nx) 2d0) 3d0)))
1047 |                            (cy2 (+ ny (/ (* (- qcy1 ny) 2d0) 3d0))))
1048 |                        (setq oqx qcx1 oqy qcy1 last-quadratic-p t)
1049 |                        (push-path (list :bezier cx1 cy1 cx2 cy2 nx ny))))
1050 |                    (push-path (list :line nx ny)))
1051 |                  (setf cpx nx cpy ny))))
1052 |             (#\A (do-svg-path-arguments (args rx ry fai fa fs x2 y2)
1053 |                    (unless (and (= cpx x2) (= cpy y2))
1054 |                      (if (or (= rx 0d0) (= ry 0d0))
1055 |                        (line-absolute x2 y2)
1056 |                        (progn
1057 |                          (if (< rx 0d0) (setq rx (abs rx)))
1058 |                          (if (< ry 0d0) (setq ry (abs ry)))
1059 |                          (push-path (convert-svg-arc cpx cpy rx ry fai fa fs x2 y2))
1060 |                          (setq cpx x2 cpy y2))))))
1061 |             (#\a (do-svg-path-arguments (args rx ry fai fa fs x2 y2)
1062 |                    (unless (and (= cpx x2) (= cpy y2))
1063 |                      (if (or (= rx 0d0) (= ry 0d0))
1064 |                        (line-relative x2 y2)
1065 |                        (progn
1066 |                          (if (< rx 0d0) (setq rx (abs rx)))
1067 |                          (if (< ry 0d0) (setq ry (abs ry)))
1068 |                          (push-path (convert-svg-arc cpx cpy rx ry fai fa fs (+ cpx x2) (+ cpy y2)))
1069 |                          (setq cpx (+ cpx x2) cpy (+ cpy y2))))))))
1070 |           (setq last-cubic-p (member char '(#\C #\c #\S #\s))
1071 |                 last-quadratic-p (member char '(#\Q #\q #\T #\t))
1072 |                 last-move-p (member char '(#\M #\m)))))
1073 |       path)))
1074 | 
1075 | (defun svg-parse-path-data (data-string)
1076 |   "Parse the svg path `d` property from string to a vector of SVG-PATH-COMMAND for further parsing."
1077 |   (declare (type string data-string))
1078 |   (let ((commands (make-array 20 :element-type 'vector :fill-pointer 0 :adjustable t))
1079 |         current-command
1080 |         (i 0)
1081 |         (len (length data-string)))
1082 |     (declare (type fixnum i len))
1083 |     (flet ((start-new-command (command-char)
1084 |              (when current-command
1085 |                (vector-push-extend current-command commands))
1086 |              (setq current-command (make-svg-path-command :char command-char))))
1087 |       (tagbody
1088 |        start
1089 |        (if (= i len) (go end) nil)
1090 |        (let ((c (char data-string i)))
1091 |          (cond ((alpha-char-p c)
1092 |                 (start-new-command c)
1093 |                 (setq i (1+ i))
1094 |                 (go start))
1095 |                ((or (digit-char-p c) (member c '(#\+ #\-)))
1096 |                 (multiple-value-bind (num idx)
1097 |                     (css-parse-a-number data-string i)
1098 |                   (if num
1099 |                     (progn
1100 |                       (vector-push-extend num (svg-path-command-args current-command))
1101 |                       (setq i idx)
1102 |                       (go start))
1103 |                     (go end))))
1104 |                (t (setq i (1+ i))
1105 |                   (go start))))
1106 |        end)
1107 |       (start-new-command #\Null)
1108 |       commands)))
1109 | 
1110 | 
1111 | ;; Gradient
1112 | 
1113 | (defclass svg-gradient ()
1114 |   ((stops :initform nil
1115 |           :accessor svg-gradient-stops)))
1116 | 
1117 | (defclass svg-linear-gradient (svg-gradient)
1118 |   ((x1 :type fixnum :initarg :x1)
1119 |    (y1 :type fixnum :initarg :y1)
1120 |    (x2 :type fixnum :initarg :x2)
1121 |    (y2 :type fixnum :initarg :y2)))
1122 | 
1123 | (defclass svg-radial-gradient (svg-gradient)
1124 |   ((cx :type fixnum :initarg :cx)
1125 |    (cy :type fixnum :initarg :cy)
1126 |    (r :type fixnum :initarg :r)
1127 |    (fx :type fixnum :initarg :fx)
1128 |    (fy :type fixnum :initarg :fy)
1129 |    (fr :type fixnum :initarg :fr)
1130 |    (mx :type fixnum :initarg :mx)
1131 |    (my :type fixnum :initarg :my)))
1132 | 
1133 | (defstruct svg-gradient-stop
1134 |   (offset 0d0 :type double-float)
1135 |   color
1136 |   opacity)
1137 | 
1138 | (defun svg-parse-gradient (node left top right bottom)
1139 |   (string-case  ((plump-dom:tag-name node))
1140 |     ("linearGradient" (svg-parse-linear-gradient node left top right bottom))
1141 |     ("radialGradient" (svg-parse-radial-gradient node left top right bottom))))
1142 | 
1143 | (defun svg-parse-linear-gradient (node left top right bottom)
1144 |   (declare (optimize (safety 0)))
1145 |   (flet ((parse-vector-value (node key start end)
1146 |            (when-let (str (gethash key (plump:attributes node)))
1147 |              (let ((len (length str)))
1148 |                (if (eql #\% (char str (1- len)))
1149 |                  (+ start
1150 |                     (round (* (- end start)
1151 |                               (/ (parse-float str :end (1- len)) 100d0))))
1152 |                  (parse-integer str)))))
1153 |          (parse-stop-value (node key)
1154 |            (when-let (str (gethash key (plump:attributes node)))
1155 |              (let ((len (length str)))
1156 |                (if (eql #\% (char str (1- len)))
1157 |                  (/ (parse-float str :end (1- len)) 100d0)
1158 |                  (parse-integer str))))))
1159 |     (let ((grad (make-instance 'svg-linear-gradient
1160 |                                :x1 (or (parse-vector-value node "x1" left right) (round left))
1161 |                                :y1 (or (parse-vector-value node "y1" top bottom) (round top))
1162 |                                :x2 (or (parse-vector-value node "x2" left right) (round right))
1163 |                                :y2 (or (parse-vector-value node "y2" top bottom) (round top))))
1164 |           (stops (plump-dom:get-elements-by-tag-name node "stop")))
1165 |       (dolist (stop stops)
1166 |         (push (make-svg-gradient-stop
1167 |                :offset (or (parse-stop-value stop "offset") 0d0)
1168 |                :color (or (css-parse-color (gethash "stop-color" (plump:attributes stop))) :black)
1169 |                :opacity (or (parse-stop-value stop "stop-opacity") 1d0))
1170 |               (svg-gradient-stops grad)))
1171 |       (setf (svg-gradient-stops grad)
1172 |             (sort (svg-gradient-stops grad)
1173 |                   (lambda (grad1 grad2)
1174 |                     (< (svg-gradient-stop-offset grad1) (svg-gradient-stop-offset grad2)))))
1175 |       (let ((start (copy-svg-gradient-stop
1176 |                     (first (svg-gradient-stops grad))))
1177 |             (end (copy-svg-gradient-stop
1178 |                   (car (last (svg-gradient-stops grad))))))
1179 |         (when (/= (svg-gradient-stop-offset start) 0d0)
1180 |           (setf (svg-gradient-stop-offset start) 0d0)
1181 |           (push start (svg-gradient-stops grad)))
1182 |         (when (/= (svg-gradient-stop-offset end) 1d0)
1183 |           (setf (svg-gradient-stop-offset end) 1d0)
1184 |           (push-end end (svg-gradient-stops grad))))
1185 |       grad)))
1186 | 
1187 | (defun svg-parse-radial-gradient (node left top right bottom)
1188 |   (declare (optimize (safety 0)))
1189 |   (flet ((parse-vector-value (node key start end)
1190 |            (when-let (str (gethash key (plump:attributes node)))
1191 |              (let ((len (length str)))
1192 |                (if (eql #\% (char str (1- len)))
1193 |                  (+ start
1194 |                     (round (* (- end start)
1195 |                               (/ (parse-float str :end (1- len)) 100d0))))
1196 |                  (parse-integer str)))))
1197 |          (parse-stop-value (node key)
1198 |            (when-let (str (gethash key (plump:attributes node)))
1199 |              (let ((len (length str)))
1200 |                (if (eql #\% (char str (1- len)))
1201 |                  (/ (parse-float str :end (1- len)) 100d0)
1202 |                  (parse-integer str))))))
1203 |     (let* ((cx (or (parse-vector-value node "cx" left right) left))
1204 |            (cy (or (parse-vector-value node "cy" top bottom) top))
1205 |            (r (or (parse-vector-value node "r" 0 (- right left)) (round (- right left) 2)))
1206 |            (fx (or (parse-vector-value node "fx" left right) cx))
1207 |            (fy (or (parse-vector-value node "fy" top bottom) cy))
1208 |            (fr (or (parse-vector-value node "fr" left right) 0))
1209 |            ;; 设大圆为Cr，圆心为R；小圆为Cf，圆心为F。在Cr上任取一点M=(x1, y1)，Cf上任取一点N=(x2, y2)，
1210 |            ;; 使MR平行于NF。同理取得点P, Q。求直线MN与直线PQ的交点为(mx, my)
1211 |            ;; https://www.cnblogs.com/lingge1992/p/6738487.html
1212 |            (x1 cx)
1213 |            (y1 (+ cy r))
1214 |            (x2 fx)
1215 |            (y2 (+ fy fr))
1216 |            (x3 (+ cx r))
1217 |            (y3 cy)
1218 |            (x4 (+ fx fr))
1219 |            (y4 fy)
1220 |            (a1 (- y2 y1))
1221 |            (b1 (- x1 x2))
1222 |            (c1 (- (* x2 y1) (* y2 x1)))
1223 |            (a2 (- y4 y3))
1224 |            (b2 (- x3 x4))
1225 |            (c2 (- (* x4 y3) (* y4 x3)))
1226 |            (d (- (* a1 b2) (* a2 b1)))
1227 |            (mx (if (zerop d) cx (round (/ (- (* b1 c2) (* b2 c1)) d))))
1228 |            (my (if (zerop d) cy (round (/ (- (* c1 a2) (* c2 a1)) d))))
1229 |            (grad (make-instance 'svg-radial-gradient
1230 |                                 :cx cx :cy cy :r r :fx fx :fy fy :fr fr :mx mx :my my))
1231 |            (stops (plump-dom:get-elements-by-tag-name node "stop")))
1232 |       (declare (type fixnum cx cy r fx fy fr))
1233 |       (dolist (stop stops)
1234 |         (push (make-svg-gradient-stop
1235 |                :offset (or (parse-stop-value stop "offset") 0d0)
1236 |                :color (or (css-parse-color (gethash "stop-color" (plump:attributes stop))) :black)
1237 |                :opacity (or (parse-stop-value stop "stop-opacity") 1d0))
1238 |               (svg-gradient-stops grad)))
1239 |       (setf (svg-gradient-stops grad)
1240 |             (sort (svg-gradient-stops grad)
1241 |                   (lambda (grad1 grad2)
1242 |                     (< (svg-gradient-stop-offset grad1) (svg-gradient-stop-offset grad2)))))
1243 |       (let ((start (copy-svg-gradient-stop
1244 |                     (first (svg-gradient-stops grad))))
1245 |             (end (copy-svg-gradient-stop
1246 |                   (car (last (svg-gradient-stops grad))))))
1247 |         (when (/= (svg-gradient-stop-offset start) 0d0)
1248 |           (setf (svg-gradient-stop-offset start) 0d0)
1249 |           (push start (svg-gradient-stops grad)))
1250 |         (when (/= (svg-gradient-stop-offset end) 1d0)
1251 |           (setf (svg-gradient-stop-offset end) 1d0)
1252 |           (push-end end (svg-gradient-stops grad))))
1253 |       grad)))
1254 | 
1255 | (defgeneric svg-gradient-color (x y grad)
1256 |   (:method (x y (grad svg-linear-gradient))
1257 |    (declare (optimize (safety 0) (float 0))
1258 |             (type fixnum x y))
1259 |    (let* ((x1 (slot-value grad 'x1))
1260 |           (y1 (slot-value grad 'y1))
1261 |           (x2 (slot-value grad 'x2))
1262 |           (y2 (slot-value grad 'y2))
1263 |           (v1x (- x1 x))
1264 |           (v1y (- y1 y))
1265 |           (v2x (- x1 x2))
1266 |           (v2y (- y1 y2))
1267 |           (v2len (sqrt (+ (* v2x v2x) (* v2y v2y))))
1268 |           (percentage (/ (+ (* v1x v2x) (* v1y v2y)) v2len v2len))
1269 |           (stops (svg-gradient-stops grad))
1270 |           before after)
1271 |      (declare (type fixnum x1 y1 x2 y2))
1272 |      (loop for prev-stop = (first stops) then stop
1273 |            for stop in (cdr stops)
1274 |            until (<= (svg-gradient-stop-offset prev-stop)
1275 |                      percentage
1276 |                      (svg-gradient-stop-offset stop))
1277 |            finally (setq before prev-stop
1278 |                          after stop))
1279 |      (let ((ratio (/ (- percentage (svg-gradient-stop-offset before))
1280 |                      (- (svg-gradient-stop-offset after) (svg-gradient-stop-offset before)))))
1281 |        (flet ((lerp-color (func)
1282 |                 (lerp ratio
1283 |                       (funcall func (svg-gradient-stop-color before))
1284 |                       (funcall func (svg-gradient-stop-color after)))))
1285 |          (make-rgb
1286 |           (lerp-color #'color-red) (lerp-color #'color-green) (lerp-color #'color-blue)
1287 |           (lerp ratio (svg-gradient-stop-opacity before) (svg-gradient-stop-opacity after)))))))
1288 |   
1289 |   (:method (x y (grad svg-radial-gradient))
1290 |    (declare (optimize (safety 0) (float 0))
1291 |             (type fixnum x y))
1292 |    (let* ((cx (slot-value grad 'cx))
1293 |           (cy (slot-value grad 'cy))
1294 |           (r (slot-value grad 'r))
1295 |           (fx (slot-value grad 'fx))
1296 |           (fy (slot-value grad 'fy))
1297 |           (fr (slot-value grad 'fr))
1298 |           (mx (slot-value grad 'mx))
1299 |           (my (slot-value grad 'my))
1300 |           (stops (svg-gradient-stops grad)))
1301 |      (declare (type fixnum cx cy r fx fy fr mx my))
1302 |      ;; 设大圆为Cr，圆心为R；小圆为Cf，圆心为F；已知点M(mx, my)，N(x, y)， 射线MN交Cf于点P, 交Cr于点Q, 求PN:PQ
1303 |      ;; 首先解三角形MFP得到MP，根据余弦定理，PF²=MF²+MP²-2MF⋅MP⋅cos∠PMF；
1304 |      ;; 使用向量点积法求得cos∠PMF，代入等式并解二元一次方程得到线段MP的长
1305 |      ;; 根据定义知PF平行于QR, 可知三角形PMF与三角形QMR相似，因而可得MF:MR=MP:MQ，进而求得线段MQ的长
1306 |      ;; 根据勾股定理求得MN，PN:PQ=(MN-MP):(MQ-MP)，计算完毕
1307 |      (cond ((<= (sqrt (+ (* (- x fx) (- x fx)) (* (- y fy) (- y fy)))) fr)
1308 |             (svg-gradient-stop-color (first stops)))
1309 |            ((>= (sqrt (+ (* (- x cx) (- x cx)) (* (- y cy) (- y cy)))) r)
1310 |             (svg-gradient-stop-color (car (last stops))))
1311 |            (t
1312 |             (let* ((vMFx (- fx mx))
1313 |                    (vMFy (- fy my))
1314 |                    (lenMF (float (sqrt (+ (* vMFx vMFx) (* vMFy vMFy))) 0d0))
1315 |                    (vMNx (- x mx))
1316 |                    (vMNy (- y my))
1317 |                    (lenMN (float (sqrt (+ (* vMNx vMNx) (* vMNy vMNy))) 0d0))
1318 |                    (MFMN (* lenMF lenMN))
1319 |                    (cosR (if (zerop MFMN) 0d0
1320 |                            (/ (+ (* vMNx vMFx) (* vMNy vMFy))
1321 |                               MFMN)))
1322 |                    (lenMP (if (zerop MFMN) 0d0
1323 |                                  (/ (+ (* 2d0 lenMF cosR) (sqrt (+ (* 4d0 (* fr fr)) (* cosR cosR))))
1324 |                                     2d0)))
1325 |                    (lenMQ (if (zerop MFMN) (float r 0d0)
1326 |                                  (* (/ lenMP fr) r)))
1327 |                    (percentage (clamp (/ (- lenMN lenMP) (- lenMQ lenMP)) 0d0 1d0))
1328 |                    before after)
1329 |               (declare (type fixnum vMFx vMFy vMNx vMNy)
1330 |                        (type double-float cosR lenMP lenMQ))
1331 |               (loop for prev-stop = (first stops) then stop
1332 |                     for stop in (cdr stops)
1333 |                     until (<= (svg-gradient-stop-offset prev-stop)
1334 |                               percentage
1335 |                               (svg-gradient-stop-offset stop))
1336 |                     finally (setq before prev-stop
1337 |                                   after stop))
1338 |               (let ((ratio (/ (- percentage (svg-gradient-stop-offset before))
1339 |                               (- (svg-gradient-stop-offset after) (svg-gradient-stop-offset before)))))
1340 |                 (flet ((lerp-color (func)
1341 |                          (lerp ratio
1342 |                                (funcall func (svg-gradient-stop-color before))
1343 |                                (funcall func (svg-gradient-stop-color after)))))
1344 |                   (make-rgb
1345 |                    (lerp-color #'color-red) (lerp-color #'color-green) (lerp-color #'color-blue)
1346 |                    (lerp ratio (svg-gradient-stop-opacity before) (svg-gradient-stop-opacity after)))))))))))
1347 | 
1348 | 
1349 | ;; SVG render
1350 | 
1351 | (defvar *svg-presentation-attributes*
1352 |   '("x"                            "y"                          "cx"                          "cy"
1353 |     "r"                            "rx"                         "ry"                          "width"
1354 |     "height"                       "d"                          "fill"                        "transform"
1355 |     "alignment-baseline"           "baseline-shift"             "clip-path"                   "clip-rule"
1356 |     "color"                        "color-interpolation"        "color-interpolation-filters" "color-rendering"
1357 |     "cursor"                       "direction"                  "display"                     "dominant-baseline"
1358 |     "fill-opacity"                 "fill-rule"                  "filter"                      "flood-color"
1359 |     "flood-opacity"                "font-family"                "font-size"                   "font-size-adjust"
1360 |     "font-stretch"                 "font-style"                 "font-variant"                "font-weight"
1361 |     "glyph-orientation-horizontal" "glyph-orientation-vertical" "image-rendering"             "letter-spacing"
1362 |     "lighting-color"               "marker-end"                 "marker-mid"                  "marker-start"
1363 |     "mask"                         "opacity"                    "overflow"                    "paint-order"
1364 |     "pointer-events"               "shape-rendering"            "stop-color"                  "stop-opacity"
1365 |     "stroke"                       "stroke-dasharray"           "stroke-dashoffset"           "stroke-linecap"
1366 |     "stroke-linejoin"              "stroke-miterlimit"          "stroke-opacity"              "stroke-width"
1367 |     "text-anchor"                  "text-decoration"            "text-overflow"               "text-rendering"
1368 |     "unicode-bidi"                 "vector-effect"              "visibility"                  "white-space"
1369 |     "word-spacing"                 "writing-mode"               ))
1370 | 
1371 | (defun draw-lw-path-to-vecto-state (state lw-path)
1372 |   (flet ((draw-sub-path (p)
1373 |            (case (first p)
1374 |              (:move (apply #'vecto::%move-to state (rest p)))
1375 |              (:line (apply #'vecto::%line-to state (rest p)))
1376 |              (:bezier (apply #'vecto::%curve-to state (rest p)))
1377 |              (:arc
1378 |               (destructuring-bind (cx cy rx ry fai start sweep) (rest p)
1379 |                 (let ((curves (if (> start sweep)
1380 |                                 (nreverse (mapcar #'nreverse
1381 |                                                   (vecto::approximate-elliptical-arc cx cy rx ry fai sweep start)))
1382 |                                 (vecto::approximate-elliptical-arc cx cy rx ry fai start sweep))))
1383 |                   (destructuring-bind (((startx . starty) &rest ignored-curve)
1384 |                                        &rest ignored-curves)
1385 |                       curves
1386 |                     (declare (ignore ignored-curve ignored-curves))
1387 |                     (if (vecto::path state)
1388 |                       (vecto::%line-to state startx starty)
1389 |                       (vecto::%move-to state startx starty)))
1390 |                   (loop for (nil
1391 |                              (cx1 . cy1)
1392 |                              (cx2 . cy2)
1393 |                              (x2 . y2)) in curves
1394 |                         do (vecto::%curve-to state cx1 cy1 cx2 cy2 x2 y2))))))))
1395 |     (if (listp lw-path)
1396 |       (dolist (p lw-path) (draw-sub-path p))
1397 |       (loop for p across lw-path do (draw-sub-path p)))))
1398 | 
1399 | (defun lw-color-to-vecto (color)
1400 |   (make-instance 'vecto::rgba-color
1401 |                  :red (color-red color)
1402 |                  :green (color-green color)
1403 |                  :blue (color-blue color)
1404 |                  :alpha (color-alpha color)))
1405 | 
1406 | (defvar *css-collapse-whitespace-scanner*
1407 |   (ppcre:create-scanner "\\s{2,}"))
1408 | 
1409 | (defun create-renderer (state node &optional (root-node node) (container-attributes (make-hash-table :test #'equalp)))
1410 |   "Compile a SVG DOM element into a \"renderer\" function, which can
1411 | draw the SVG to the specified STATE.
1412 | 
1413 | STATE: a graphics-state that is used to provide necessary display
1414 | informations to compile the SVG.
1415 | 
1416 | Note that the returned function can be used to draw the SVG at any
1417 | graphics state, but the graphics informations, i.e. fonts, relative
1418 | size, screen DPI, will be embedded using the attributes from this
1419 | STATE.
1420 | 
1421 | ROOT-NODE: The root node of the SVG DOM, in PLUMP:NODE, which can
1422 | be NODE or its parent.  It is used to search for DOM elements being
1423 | referenced by SVG, to build re-used graphic objects.
1424 | 
1425 | NODE: the PLUMP:NODE of the SVG element being compiled.
1426 | 
1427 | CONTAINER-ATTRIBUTES: A hash-table of inherit attributes that are used
1428 | in recursive parsing. Not needed when parsing a standalone SVG
1429 | element."
1430 |   (declare (optimize (float 0) (safety 0) (speed 3))
1431 |            (type hash-table container-attributes)
1432 |            ;(:explain :types)
1433 |            )
1434 |   (let ((tag (plump-dom:tag-name node))
1435 |         (new-attrs (plump-dom:attributes node))
1436 |         (first-call-p (zerop (hash-table-count container-attributes))))
1437 |     (declare (type string tag))
1438 |     ;; Processing CSS style properties and merge them into NEW-ATTRS
1439 |     (let ((styles (ensure-gethash
1440 |                    "css-styles" container-attributes
1441 |                    (mapcan #'css-parse-style-element
1442 |                            (plump-dom:get-elements-by-tag-name root-node "style")))))
1443 |       ;; There're some problems here, so it only conforms SVG 1.1 but not 2
1444 |       (loop for (pred . attrs) in styles
1445 |             when (funcall pred node)
1446 |               do (nmerge-tables new-attrs attrs))
1447 |       (when-let (inline-style (plump-dom:attribute node "style"))
1448 |         (nmerge-tables new-attrs (css-parse-style-properties inline-style))))
1449 |     (labels (;; Helper functions & Getter of presentation attributes
1450 |              (svg-parse-length (val width-or-height)
1451 |                (if (stringp val)
1452 |                  (rectangle-bind (x y w h)
1453 |                      (gethash "viewBox" container-attributes)
1454 |                    (declare (ignore x y))
1455 |                    (css-parse-length
1456 |                     state val width-or-height w h
1457 |                     (gethash "width" container-attributes)
1458 |                     (gethash "height" container-attributes)))
1459 |                  val))
1460 |              (svg-parse-all-length (val width-or-height)
1461 |                (if (stringp val)
1462 |                  (rectangle-bind (x y w h)
1463 |                      (gethash "viewBox" container-attributes)
1464 |                    (declare (ignore x y))
1465 |                    (css-parse-all-length-from-string
1466 |                     state val width-or-height w h
1467 |                     (gethash "width" container-attributes)
1468 |                     (gethash "height" container-attributes)))
1469 |                  val))
1470 |              (parse-opacity (val)
1471 |                (if (stringp val) (clamp (parse-float val) 0.0 1.0) (if val 1.0 nil)))
1472 |              (with-alpha (color alpha)
1473 |                (when color
1474 |                  (setq color (ensure-rgb color))
1475 |                  (make-rgb (color-red color)
1476 |                            (color-green color)
1477 |                            (color-blue color)
1478 |                            (* (color-alpha color) alpha))))
1479 |              (get-attr (key &optional default)
1480 |                (declare (inline get-attr))
1481 |                (gethash key new-attrs
1482 |                         (gethash key container-attributes
1483 |                                  default)))
1484 |              (get-fill ()
1485 |                (declare (inline get-fill))
1486 |                (when-let (fill (get-attr "fill"))
1487 |                  (string-case (fill)
1488 |                    ("context-fill"
1489 |                     (setq fill (gethash "fill" container-attributes)))
1490 |                    ("context-stroke"
1491 |                     (setq fill (gethash "stroke" container-attributes)))
1492 |                    (t nil))
1493 |                  (setq fill
1494 |                        (cond ((member fill '(nil "auto") :test #'equalp) (make-rgb 0.0 0.0 0.0 1.0))
1495 |                              ((string-equal fill "none") nil)
1496 |                              ((search "url" fill) (css-parse-url fill root-node))
1497 |                              (t (css-parse-color fill))))
1498 |                  (when-let (op (or (parse-opacity (gethash "fill-opacity" container-attributes))
1499 |                                    (parse-opacity (gethash "opacity" container-attributes))))
1500 |                    (setq fill (with-alpha fill op)))
1501 |                  (when-let (op (or (parse-opacity (gethash "fill-opacity" new-attrs))
1502 |                                    (parse-opacity (gethash "opacity" new-attrs))))
1503 |                    (setq fill (with-alpha fill op)))
1504 |                  fill))
1505 |              (get-fill-rule ()
1506 |                (declare (inline get-fill-rule))
1507 |                (if-let (val (get-attr "fill-rule"))
1508 |                    (if (stringp val)
1509 |                      (if (string-equal val "evenodd") :even-odd :winding)
1510 |                      val)
1511 |                  :winding))
1512 |              (get-stroke ()
1513 |                (declare (inline get-stroke))
1514 |                (when-let (stroke (get-attr "stroke"))
1515 |                  (string-case (stroke)
1516 |                    ("context-fill"
1517 |                     (setq stroke (gethash "fill" container-attributes)))
1518 |                    ("context-stroke"
1519 |                     (setq stroke (gethash "stroke" container-attributes)))
1520 |                    (t nil))
1521 |                  (setq stroke
1522 |                        (cond ((member stroke '(nil "auto" "none") :test #'equalp) nil)
1523 |                              ((search "url" stroke) (css-parse-url stroke root-node))
1524 |                              (t (css-parse-color stroke))))
1525 |                  (when-let (op (or (parse-opacity (gethash "stroke-opacity" container-attributes))
1526 |                                    (parse-opacity (gethash "opacity" container-attributes))))
1527 |                    (setq stroke (with-alpha stroke op)))
1528 |                  (when-let (op (or (parse-opacity (gethash "stroke-opacity" new-attrs))
1529 |                                    (parse-opacity (gethash "opacity" new-attrs))))
1530 |                    (setq stroke (with-alpha stroke op)))
1531 |                  stroke))
1532 |              (get-stroke-dasharray ()
1533 |                (declare (inline get-stroke-dasharray))
1534 |                (when-let (val (get-attr "stroke-dasharray"))
1535 |                  (if (stringp val)
1536 |                    (map 'vector #'round (svg-parse-all-length val :width))
1537 |                    val)))
1538 |              (get-linecap ()
1539 |                (declare (inline get-linecap))
1540 |                (string-case ((get-attr "stroke-linecap"))
1541 |                  ("round" :round)
1542 |                  ("square" :square)
1543 |                  (t :butt)))
1544 |              (get-linejoin ()
1545 |                (declare (inline get-linejoin))
1546 |                (string-case ((get-attr "stroke-linejoin"))
1547 |                  ("round" :round)
1548 |                  ("bevel" :bevel)
1549 |                  (t :miter)))
1550 |              (get-a-length (name)
1551 |                (declare (inline get-a-length))
1552 |                (svg-parse-length
1553 |                 (get-attr name)
1554 |                 (if (or (find #\y name) (search "height" name)) :height :width)))
1555 |              (get-font ()
1556 |                (let* ((family (get-attr "font-family"))
1557 |                       (weight (when-let (weight (get-attr "font-weight"))
1558 |                                 (if (digit-char-p (char weight 0))
1559 |                                   (let ((num (parse-integer weight)))
1560 |                                     (cond ((< num 400) "light")
1561 |                                           ((< num 500) "regular")
1562 |                                           ((< num 700) "semibold")
1563 |                                           ((< num 800) "bold")
1564 |                                           (t "black")))
1565 |                                   (if (string-equal weight "normal") "regular"
1566 |                                     weight))))
1567 |                       (slant (when-let (style (get-attr "font-style"))
1568 |                                (string-case (style :default nil)
1569 |                                  ("italic" "italic")
1570 |                                  ("oblique" "oblique"))))
1571 |                       (size (if-let (size (get-attr "font-size"))
1572 |                                 (round (svg-parse-length size :width))
1573 |                               (vecto::size (vecto::font state))))
1574 |                       (loader (vecto::loader (vecto::font state))))
1575 |                  (if family
1576 |                    (let ((subs (split-sequence-if (lambda (c) (member c '(#\, #\Space #\"))) family
1577 |                                                   :remove-empty-subseqs t)))
1578 |                      (dolist (sub subs)
1579 |                        (string-case (sub :default nil)
1580 |                          ("serif"
1581 |                           #+(or mswindows darwin) (setq sub "Times New Roman")
1582 |                           #-(or mswindows darwin) (setq sub "Liberation Serif"))
1583 |                          ("sans-serif"
1584 |                           #+mswindows (setq sub "Arial")
1585 |                           #+darwin (setq sub "Helvetica Neue")
1586 |                           #-(or mswindows darwin) (setq sub "Liberation Sans"))
1587 |                          ("monospace"
1588 |                           #+(or mswindows darwin) (setq sub "Courier New")
1589 |                           #-(or mswindows darwin) (setq sub "Liberation Mono")))
1590 |                        (if-let (cache (gethash (list sub weight slant) (vecto::font-loaders state)))
1591 |                            (progn (setq loader cache)
1592 |                              (return))
1593 |                          (when-let (found (find-font-loader sub weight slant))
1594 |                            (find-font-loader sub weight slant)
1595 |                            (setq loader found)
1596 |                            (setf (gethash (list sub weight slant) (vecto::font-loaders state)) found)
1597 |                            (return)))))
1598 |                    (when (or weight slant)
1599 |                      (setq family (font-family loader))
1600 |                      (if-let (cache (gethash (list family weight slant) (vecto::font-loaders state)))
1601 |                          (setq loader cache)
1602 |                        (when-let (found (find-font-loader family weight slant))
1603 |                          (setq loader found)
1604 |                          (setf (gethash (list family weight slant) (vecto::font-loaders state)) found)))))
1605 |                  (values loader size)))
1606 |              (multiply-transforms-for-drawing (trans-origin-x trans-origin-y)
1607 |                (let ((transform (make-transform))
1608 |                      (svg-transform (gethash "svg-transform" container-attributes))
1609 |                      (container-transforms (gethash "container-transforms" container-attributes))
1610 |                      (self-transforms (gethash "transform" new-attrs)))
1611 |                  ;; These transforms has not been parsed, so parse them first
1612 |                  (rectangle-bind (x y w h)
1613 |                      (gethash "viewBox" container-attributes)
1614 |                    (declare (ignore x y))
1615 |                    (when self-transforms
1616 |                      (setq self-transforms
1617 |                            (css-parse-transforms
1618 |                             state self-transforms w h
1619 |                             (gethash "width" container-attributes)
1620 |                             (gethash "height" container-attributes))))
1621 |                    (when container-transforms
1622 |                      (setq container-transforms
1623 |                            (css-parse-transforms
1624 |                             state container-transforms w h
1625 |                             (gethash "width" container-attributes)
1626 |                             (gethash "height" container-attributes)))))
1627 |                  (apply-translation transform (- trans-origin-x) (- trans-origin-y))
1628 |                  (dolist (trans (append self-transforms container-transforms))
1629 |                    (premultiply-transforms transform trans))
1630 |                  (apply-translation transform trans-origin-x trans-origin-y)
1631 |                  ;; Apply svg-transform in the end. It's relative with (0, 0);
1632 |                  (when svg-transform (postmultiply-transforms transform svg-transform))
1633 |                  transform))
1634 |              (run-draw-path (trans-origin-x trans-origin-y path)
1635 |                (declare (type double-float trans-origin-x trans-origin-y))
1636 |                (let* ((transform (coerce (multiply-transforms-for-drawing trans-origin-x trans-origin-y) 'vector))
1637 |                       (fill (get-fill))
1638 |                       (stroke (get-stroke))
1639 |                       (stroke-width (or (get-a-length "stroke-width") 1))
1640 |                       (linecap (get-linecap))
1641 |                       (linejoin (get-linejoin))
1642 |                       (dash (get-stroke-dasharray))
1643 |                       (fill-rule (get-fill-rule)))
1644 |                  ;; Deal with gradients
1645 |                  (when (plump-dom:node-p stroke)
1646 |                    (setq stroke :black))
1647 |                  (if (plump-dom:node-p fill)
1648 |                    (let ((grad-trans (gethash "gradientTransform" (plump-dom:attributes fill))))
1649 |                      ;; Parse gradient transforms
1650 |                      (rectangle-bind (x y w h)
1651 |                          (gethash "viewBox" container-attributes)
1652 |                        (declare (ignore x y))
1653 |                        (if grad-trans
1654 |                          (setq grad-trans
1655 |                                (css-parse-transforms state grad-trans w h
1656 |                                                      (gethash "width" container-attributes)
1657 |                                                      (gethash "height" container-attributes)))
1658 |                          (setq grad-trans (make-transform)))
1659 |                        (let* ((grad (svg-parse-gradient fill 0 0 w h))
1660 |                               (rev-grad-trans (vecto::invert-matrix (coerce grad-trans 'vector)))
1661 |                               (fill-source (lambda (x y)
1662 |                                              (multiple-value-bind (origin-x origin-y)
1663 |                                                  (vecto::transform-coordinates x y rev-grad-trans)
1664 |                                                (let ((color (svg-gradient-color origin-x origin-y grad)))
1665 |                                                  (values-list (map 'list #'vecto::float-octet (subseq color 1))))))))
1666 |                          (lambda (state)
1667 |                            (let ((state (vecto::copy state)))
1668 |                              (setf (vecto::line-width state) stroke-width
1669 |                                    (vecto::cap-style state) linecap
1670 |                                    (vecto::join-style state) linejoin
1671 |                                    (vecto::dash-vector state) dash
1672 |                                    (vecto::transform-matrix state) (if-let (old-trans (vecto::transform-matrix state))
1673 |                                                                        (vecto::mult transform old-trans)
1674 |                                                                      transform))
1675 |                              (draw-lw-path-to-vecto-state state path)
1676 |                              (setf (vecto::fill-source state) fill-source)
1677 |                              (if (eq fill-rule :even-odd)
1678 |                                (vecto::draw-even-odd-filled-paths state)
1679 |                                (vecto::draw-filled-paths state))
1680 |                              (when stroke
1681 |                                (setf (vecto::stroke-color state) (lw-color-to-vecto stroke))
1682 |                                (vecto::draw-stroked-paths state)))
1683 |                            ))))
1684 |                    ;; No gradient, yield normal drawing function
1685 |                    (lambda (state)
1686 |                      (let ((state (vecto::copy state)))
1687 |                        (setf (vecto::line-width state) stroke-width
1688 |                              (vecto::cap-style state) linecap
1689 |                              (vecto::join-style state) linejoin
1690 |                              (vecto::dash-vector state) dash)
1691 |                        (vecto::apply-matrix state transform)
1692 |                        (draw-lw-path-to-vecto-state state path)
1693 |                        (when fill
1694 |                          (setf (vecto::fill-color state) (lw-color-to-vecto fill))
1695 |                          (if (eq fill-rule :even-odd)
1696 |                            (vecto::draw-even-odd-filled-paths state)
1697 |                            (vecto::draw-filled-paths state)))
1698 |                        (if stroke
1699 |                          (progn
1700 |                            (setf (vecto::stroke-color state) (lw-color-to-vecto stroke))
1701 |                            (vecto::draw-stroked-paths state))
1702 |                          (when (not fill) ; Draw the path in default color if nether `fill` nor `stroke` specified.
1703 |                            (setf (vecto::stroke-color state) ())
1704 |                            (vecto::draw-stroked-paths state))))))))
1705 |              (collapse-whitespace-around-children (node)
1706 |                (let ((children (plump:children node))
1707 |                      (space (gethash "text-space" container-attributes)))
1708 |                  (unless (equalp space "preserve")
1709 |                    (let ((start (aref children 0))
1710 |                          (end (aref children (1- (length children)))))
1711 |                      (when (plump-dom:text-node-p start)
1712 |                        (setf (plump:text start) (string-left-trim '(#\Space #\Tab #\Return #\Newline) (plump:text start))))
1713 |                      (when (plump-dom:text-node-p end)
1714 |                        (setf (plump:text end) (string-right-trim '(#\Space #\Tab #\Return #\Newline) (plump:text end))))))))
1715 |              (draw-a-character (char font-loader size transform)
1716 |                ;; FIXME: i18n for :lr and :tb
1717 |                (let* ((text-x (pop (gethash "text-x" container-attributes)))
1718 |                       (shift-x (pop (gethash "text-dx" container-attributes)))
1719 |                       (text-y (pop (gethash "text-y" container-attributes)))
1720 |                       (shift-y (pop (gethash "text-dy" container-attributes)))
1721 |                       (rotate (pop (gethash "text-rotate" container-attributes)))
1722 |                       (x1 (or text-x
1723 |                               (+ (or (gethash "text-prev-x" container-attributes) 0)
1724 |                                  (or (gethash "text-total-width" container-attributes) 0))))
1725 |                       (dx1 (or shift-x
1726 |                                (gethash "text-prev-dx" container-attributes)
1727 |                                0))
1728 |                       (y1 (or text-y
1729 |                               (+ (or (gethash "text-prev-y" container-attributes) 0)
1730 |                                  (or (gethash "text-total-height" container-attributes) 0))))
1731 |                       (dy1 (or shift-y
1732 |                                (gethash "text-prev-dy" container-attributes)
1733 |                                0))
1734 |                       (r1 (or rotate
1735 |                               (gethash "text-prev-rotate" container-attributes)
1736 |                               0))
1737 |                       (x (+ x1 dx1))
1738 |                       (y (+ y1 dy1))
1739 |                       (char-width (get-char-width char font-loader size))
1740 |                       (char-height (get-char-height char font-loader size))
1741 |                       (fill (get-fill)))
1742 |                  (when text-x
1743 |                    (setf (gethash "text-prev-x" container-attributes) text-x
1744 |                          (gethash "text-total-width" container-attributes) 0))
1745 |                  (when text-y
1746 |                    (setf (gethash "text-prev-y" container-attributes) text-y
1747 |                          (gethash "text-total-height" container-attributes) 0))
1748 |                  (when rotate
1749 |                    (setf (gethash "text-prev-rotate" container-attributes) rotate))
1750 |                  (case (gethash "writing-mode" container-attributes)
1751 |                    (:lr
1752 |                     (setf (gethash "text-total-width" container-attributes)
1753 |                           (+ (gethash "text-total-width" container-attributes 0)
1754 |                              char-width)))
1755 |                    (:tb
1756 |                     (setf (gethash "text-total-height" container-attributes)
1757 |                           (+ (gethash "text-total-height" container-attributes 0)
1758 |                              char-height))))
1759 |                  (unless (whitespace-char-p char)
1760 |                    (let ((new-transform (make-transform)))
1761 |                      ;; ??? Why the path of string is mirrored @VECTO
1762 |                      (apply-translation new-transform (- x) (- y))
1763 |                      (apply-scale new-transform 1 -1)
1764 |                      (apply-rotation new-transform r1)
1765 |                      (apply-translation new-transform x y)
1766 |                      (postmultiply-transforms new-transform transform)
1767 |                      (setq new-transform (coerce new-transform 'vector))
1768 |                      (lambda (state)
1769 |                        (let ((state (vecto::copy state)))
1770 |                          (vecto::%set-font state font-loader size)
1771 |                          (setf (vecto::transform-matrix state) (if-let (old-trans (vecto::transform-matrix state))
1772 |                                                                    (vecto::mult new-transform old-trans)
1773 |                                                                  new-transform)
1774 |                                (vecto::fill-color state) (lw-color-to-vecto fill))
1775 |                          (vecto::%draw-string state x y (string char))))))))
1776 |              (draw-a-text-node (text-node)
1777 |                (let* ((transform (multiply-transforms-for-drawing
1778 |                                   (or (gethash "text-start-x" container-attributes) 0)
1779 |                                   (or (gethash "text-start-y" container-attributes) 0)))
1780 |                       (space (gethash "text-space" container-attributes)))
1781 |                  (multiple-value-bind (loader size) (get-font)
1782 |                    (unless (equalp space "preserve")
1783 |                      (setf (plump:text text-node)
1784 |                            (ppcre:regex-replace-all
1785 |                             *css-collapse-whitespace-scanner* (plump:text text-node)
1786 |                             ;; FIXME: check i18n here
1787 |                             (if (member (get-attr "lang") '("jp" "kr" "zh")
1788 |                                         :test (lambda (lang str) (string-prefix-p str lang)))
1789 |                               "" " "))))
1790 |                    (when-let (funcs (loop for char across (plump:text text-node)
1791 |                                           for func = (draw-a-character char loader size transform)
1792 |                                           when func collect func))
1793 |                      (lambda (state)
1794 |                        (dolist (func funcs)
1795 |                          (funcall func state))))))))
1796 |       (string-case (tag)
1797 |         ("path" (run-draw-path
1798 |                  0d0 0d0
1799 |                  (convert-path-commands (svg-parse-path-data (gethash "d" new-attrs)))))
1800 |         ("rect" (let ((x (or (get-a-length "x") 0d0))
1801 |                       (y (or (get-a-length "y") 0d0))
1802 |                       (w (or (get-a-length "width") (svg-parse-length "100%" :width)))
1803 |                       (h (or (get-a-length "height") (svg-parse-length "100%" :height)))
1804 |                       (rx (get-a-length "rx"))
1805 |                       (ry (get-a-length "ry")))
1806 |                   (declare (type double-float x y w h))
1807 |                   (cond ((and rx (or (null ry) (equal ry "auto")))
1808 |                          (setq rx (svg-parse-length rx :width)
1809 |                                ry (min (/ h 2d0) (* (/ rx w) h))))
1810 |                         ((and ry (or (null rx) (equal rx "auto")))
1811 |                          (setq ry (svg-parse-length ry :height)
1812 |                                rx (min (/ w 2d0) (* (/ ry h) w)))))
1813 |                   (run-draw-path
1814 |                    x y
1815 |                    (if (or (null rx) (and (= rx 0d0) (= ry 0d0)))
1816 |                      `((:move ,x ,y) (:line ,(+ x w) ,y) (:line ,(+ x w) ,(+ y h)) (:line ,x ,(+ y h)) (:close))
1817 |                      `((:move ,(+ x rx) ,y) (:line ,(- (+ x w) rx) ,y) (:arc ,(- (+ x w) rx) ,(+ y ry) ,rx ,ry 0 ,(- pi-by-2) 0)
1818 |                        (:line ,(+ x w) ,(- (+ y h) ry)) (:arc ,(- (+ x w) rx) ,(- (+ y h) ry) ,rx ,ry 0 0 ,pi-by-2)
1819 |                        (:line ,(+ x rx) ,(+ y h)) (:arc ,(+ x rx) ,(- (+ y h) ry) ,rx ,ry 0 ,pi-by-2 ,pi)
1820 |                        (:line ,x ,(+ y ry)) (:arc ,(+ x rx) ,(+ y ry) ,rx ,ry 0 ,pi ,(+ pi pi-by-2))
1821 |                        (:close))))))
1822 |         ("circle" (let ((cx (or (get-a-length "cx") 0d0))
1823 |                         (cy (or (get-a-length "cy") 0d0))
1824 |                         (r (or (get-a-length "r") 0d0)))
1825 |                     (declare (type double-float cx cy r))
1826 |                     (run-draw-path cx cy (list (list :arc cx cy r r 0d0 0d0 2pi)))))
1827 |         ("ellipse" (let ((cx (or (get-a-length "cx") 0d0))
1828 |                          (cy (or (get-a-length "cy") 0d0))
1829 |                          (rx (get-attr "rx"))
1830 |                          (ry (get-attr "ry")))
1831 |                      (declare (type double-float cx cy))
1832 |                      (cond ((and rx (or (null ry) (equal ry "auto")))
1833 |                             (setq rx (svg-parse-length rx :width)
1834 |                                   ry rx))
1835 |                            ((and ry (or (null rx) (equal rx "auto")))
1836 |                             (setq ry (svg-parse-length ry :height)
1837 |                                   rx ry))
1838 |                            ((null rx) (setq rx 0d0 ry 0d0))
1839 |                            (t (setq rx (svg-parse-length rx :width)
1840 |                                     ry (svg-parse-length ry :height))))
1841 |                      (run-draw-path cx cy (list (list :arc cx cy rx ry 0d0 0d0 2pi)))))
1842 |         ("line" (let ((x1 (get-a-length "x1")) (y1 (get-a-length "y1"))
1843 |                       (x2 (get-a-length "x2")) (y2 (get-a-length "y2")))
1844 |                   (declare (type double-float x1 y1 x2 y2))
1845 |                   (run-draw-path (/ (+ x1 x2) 2d0) (/ (+ y1 y2) 2d0)
1846 |                                  (list (list :move x1 y1) (list :line x2 y2)))))
1847 |         ("polyline" (let* ((points (css-parse-all-numbers-from-string (get-attr "points")))
1848 |                            (path (make-array (1+ (/ (length points) 2)) :element-type 'list :fill-pointer 0))
1849 |                            (start-x (aref points 0)) (start-y (aref points 1))
1850 |                            mid-x mid-y)
1851 |                       (vector-push (list :move start-x start-y) path)
1852 |                       (loop for i fixnum from 2 to (1- (length points)) by 2
1853 |                             for x double-float = (aref points i)
1854 |                             and y double-float = (aref points (1+ i))
1855 |                             do (vector-push (list :line x y) path)
1856 |                             minimize x into min-x
1857 |                             maximize x into max-x
1858 |                             minimize y into min-y
1859 |                             maximize y into max-y
1860 |                             finally (setq min-x (min min-x start-x)
1861 |                                           max-x (max max-x start-x)
1862 |                                           min-y (min min-y start-y)
1863 |                                           max-y (max max-y start-y)
1864 |                                           mid-x (/ (+ min-x max-x) 2d0)
1865 |                                           mid-y (/ (+ min-y max-y) 2d0)))
1866 |                       (run-draw-path mid-x mid-y path)))
1867 |         ("polygon" (let* ((points (css-parse-all-numbers-from-string (get-attr "points")))
1868 |                           (path (make-array (+ (/ (length points) 2) 2) :element-type 'list :fill-pointer 0))
1869 |                           (start-x (aref points 0))
1870 |                           (start-y (aref points 1))
1871 |                           mid-x mid-y)
1872 |                      (vector-push (list :move start-x start-y) path)
1873 |                      (loop for i fixnum from 2 to (1- (length points)) by 2
1874 |                            for x double-float = (aref points i)
1875 |                            and y double-float = (aref points (1+ i))
1876 |                            do (vector-push (list :line x y) path)
1877 |                            minimize x into min-x
1878 |                            maximize x into max-x
1879 |                            minimize y into min-y
1880 |                            maximize y into max-y
1881 |                            finally (setq min-x (min min-x start-x)
1882 |                                          max-x (max max-x start-x)
1883 |                                          min-y (min min-y start-y)
1884 |                                          max-y (max max-y start-y)
1885 |                                          mid-x (/ (the double-float (+ min-x max-x)) 2d0)
1886 |                                          mid-y (/ (the double-float (+ min-y max-y)) 2d0)))
1887 |                      (vector-push (list :close) path)
1888 |                      (run-draw-path mid-x mid-y path)))
1889 |         ("text"
1890 |          (let* ((children (plump-dom:children node))
1891 |                 (new-table (copy-hash-table container-attributes))
1892 |                 ;; FIXME: formal whitespace handling
1893 |                 (space (if-let (val (get-attr "white-space"))
1894 |                            (if (string-prefix-p "pre" val) "preserve" "normal")
1895 |                          (or (get-attr "space") (get-attr "xml:space")))))
1896 |            (maphash (lambda (k v) (setf (gethash k new-table) v))
1897 |                     new-attrs)
1898 |            (setf (gethash "text-x" new-table) (svg-parse-all-length (gethash "x" new-attrs) :width)
1899 |                  (gethash "text-y" new-table) (svg-parse-all-length (gethash "y" new-attrs) :height)
1900 |                  (gethash "text-dx" new-table) (svg-parse-all-length (gethash "dx" new-attrs) :width)
1901 |                  (gethash "text-dy" new-table) (svg-parse-all-length (gethash "dy" new-attrs) :height)
1902 |                  (gethash "text-rotate" new-table) (coerce (css-parse-all-angels-from-string (gethash "rotate" new-attrs)) 'list)
1903 |                  (gethash "text-space" new-table) space
1904 |                  (gethash "writing-mode" new-table) :lr
1905 |                  (gethash "text-start-x" new-table) (when-let (xs (gethash "text-x" new-table))
1906 |                                                       (first xs))
1907 |                  (gethash "text-start-y" new-table) (when-let (ys (gethash "text-y" new-table))
1908 |                                                       (first ys)))
1909 |            (setq container-attributes new-table)
1910 |            (collapse-whitespace-around-children node)
1911 |            (when-let (funcs (loop for child across children
1912 |                                   for func = (cond ((plump-dom:textual-node-p child)
1913 |                                                     (draw-a-text-node child))
1914 |                                                    ((plump-dom:element-p child)
1915 |                                                     (create-renderer state child root-node new-table)))
1916 |                                   when func collect func))
1917 |              (lambda (state)
1918 |                (dolist (func funcs)
1919 |                  (funcall func state))))))
1920 |         ("tspan"
1921 |          (let ((backup-attrs (loop for attr in (append 
1922 |                                                        *svg-presentation-attributes*)
1923 |                                    for val = (gethash attr new-attrs)
1924 |                                    for old = (gethash attr container-attributes)
1925 |                                    when val
1926 |                                      do (setf (gethash attr container-attributes) val)
1927 |                                      and collect (cons attr old))))
1928 |            (dolist (attr '("text-x" "text-y" "text-dx" "text-dy"
1929 |                            "text-rotate" "text-prev-rotate"))
1930 |              (push (cons attr (gethash attr container-attributes)) backup-attrs))
1931 |            (when-let (new (svg-parse-all-length (gethash "x" new-attrs) :width))
1932 |              (setf (gethash "text-x" container-attributes) (append new (gethash "text-x" container-attributes)))
1933 |              (unless (gethash "text-start-x" container-attributes)
1934 |                (setf (gethash "text-start-x" container-attributes) (first new))))
1935 |            (when-let (new (svg-parse-all-length (gethash "y" new-attrs) :height))
1936 |              (setf (gethash "text-y" container-attributes) (append new (gethash "text-y" container-attributes)))
1937 |              (unless (gethash "text-start-y" container-attributes)
1938 |                (setf (gethash "text-start-y" container-attributes) (first new))))
1939 |            (when-let (new (svg-parse-all-length (gethash "dx" new-attrs) :width))
1940 |              (setf (gethash "text-dx" container-attributes) (append new (gethash "text-dx" container-attributes))))
1941 |            (when-let (new (svg-parse-all-length (gethash "dy" new-attrs) :height))
1942 |              (setf (gethash "text-dy" container-attributes) (append new (gethash "text-dy" container-attributes))))
1943 |            (when-let (new (coerce (css-parse-all-angels-from-string (gethash "rotate" new-attrs)) 'list))
1944 |              (setf (gethash "text-rotate" container-attributes) new))
1945 |            (collapse-whitespace-around-children node)
1946 |            (when-let (funcs (loop for child across (plump-dom:children node)
1947 |                                   for func = (cond ((plump-dom:textual-node-p child)
1948 |                                                     (draw-a-text-node child))
1949 |                                                    ((plump-dom:element-p child)
1950 |                                                     (create-renderer state child root-node container-attributes)))
1951 |                                   when func collect func))
1952 |              (prog1 (lambda (state)
1953 |                       (dolist (func funcs)
1954 |                         (funcall func state)))
1955 |                (loop for (attr . val) in backup-attrs
1956 |                      do (setf (gethash attr container-attributes) val))))))
1957 |         (t (when (member tag '("a" "clipPath" "g" "mask" "pattern" "svg" "switch" "unknown" "use")
1958 |                          :test #'string=)
1959 |              (let ((new-table (copy-hash-table container-attributes)))
1960 |                (maphash (lambda (k v) (setf (gethash k new-table) v))
1961 |                         new-attrs)
1962 |                ;; If a transform is specified for a container,
1963 |                ;; since we know nether the transform-origin, nor the parent's size it relative with,
1964 |                ;; we need to store it for later parse & apply. It should be a STRING.
1965 |                (when-let (new-transform (gethash "transform" new-attrs))
1966 |                  ;; When transformed containers nested, append them after new transforms.
1967 |                  (when-let (trans (gethash "container-transforms" new-table))
1968 |                    (setq new-transform (string-append new-transform " " trans)))
1969 |                  (setf (gethash "container-transforms" new-table) new-transform))
1970 |                (string-case (tag)
1971 |                  ("svg"
1972 |                   (let ((viewbox (if-let (val (gethash "viewBox" new-attrs))
1973 |                                      (coerce (css-parse-all-numbers-from-string val) 'list)
1974 |                                    (list 0 0 (vecto::width state) (vecto::height state)))))
1975 |                     (rectangle-bind (viewbox-l viewbox-t viewbox-w viewbox-h)
1976 |                         viewbox
1977 |                       (let* ((new-x (if-let (val (gethash "x" new-attrs))
1978 |                                         (svg-parse-length val :width)
1979 |                                       0))
1980 |                              (new-y (if-let (val (gethash "y" new-attrs))
1981 |                                         (svg-parse-length val :height)
1982 |                                       0))
1983 |                              (new-w (svg-parse-length (gethash "width" new-attrs) :width))
1984 |                              (new-h (svg-parse-length (gethash "height" new-attrs) :height))
1985 |                              (transform (make-transform))
1986 |                              (preserve-aspect (if-let (val (gethash "preserveAspectRatio" new-attrs))
1987 |                                                   (split-sequence #\Space val)
1988 |                                                 '("xMidYMid" "meet")))
1989 |                              (align (first preserve-aspect))
1990 |                              (scale (or (second preserve-aspect) "meet")))
1991 |                         (declare (type string align scale))
1992 |                         (cond ((and (null new-w) new-h) (setq new-w new-h))
1993 |                               ((and new-w (null new-h)) (setq new-h new-w))
1994 |                               ((null new-h) (setq new-w viewbox-w new-h viewbox-h)))
1995 |                         (setq new-w (round new-w)
1996 |                               new-h (round new-h))
1997 |                         (if (string= align "none") ; Do not preserve aspect
1998 |                           (progn
1999 |                             ;; Scale viewBox to fit SVG `width` and `height`
2000 |                             (when (and viewbox (or new-w new-h))
2001 |                               (apply-scale transform (/ new-w viewbox-w) (/ new-h viewbox-h)))
2002 |                             ;; Move the left-top of the viewBox to (x, y)
2003 |                             (apply-translation transform new-x new-y))
2004 |                           (let* ((xalign (subseq align 0 4))
2005 |                                  (yalign (subseq align 4 8))
2006 |                                  (svg-align-x 0)
2007 |                                  (svg-align-y 0)
2008 |                                  (viewbox-align-x 0)
2009 |                                  (viewbox-align-y 0))
2010 |                             (declare (type string xalign yalign))
2011 |                             (string-case (xalign)
2012 |                               ("xMin" (setq svg-align-x new-x
2013 |                                             viewbox-align-x viewbox-l))
2014 |                               ("xMid" (setq svg-align-x (+ new-x (/ new-w 2))
2015 |                                             viewbox-align-x (+ viewbox-l (/ viewbox-w 2))))
2016 |                               ("xMax" (setq svg-align-x (+ new-x new-w)
2017 |                                             viewbox-align-x (+ viewbox-l viewbox-w))))
2018 |                             (string-case (yalign)
2019 |                               ("YMin" (setq svg-align-y new-y
2020 |                                             viewbox-align-y viewbox-t))
2021 |                               ("YMid" (setq svg-align-y (+ new-y (/ new-h 2))
2022 |                                             viewbox-align-y (+ viewbox-t (/ viewbox-h 2))))
2023 |                               ("YMax" (setq svg-align-y (+ new-y new-h)
2024 |                                             viewbox-align-y (+ viewbox-t viewbox-h))))
2025 |                             ;; Apply scaling, and align selected points
2026 |                             (apply-translation transform (- viewbox-align-x) (- viewbox-align-y))
2027 |                             (let* ((x-ratio (/ new-w viewbox-w))
2028 |                                    (y-ratio (/ new-h viewbox-h))
2029 |                                    (ratio (if (string= scale "meet")
2030 |                                             (min x-ratio y-ratio)
2031 |                                             (max x-ratio y-ratio))))
2032 |                               (apply-scale transform ratio ratio))
2033 |                             (apply-translation transform svg-align-x svg-align-y)))
2034 |                         ;; If the element itself is `svg`, we assume the transform-origin is 0, 0;
2035 |                         ;; no additional translation needed, so we just multiply them into the svg-transform
2036 |                         (when-let (container-transforms (gethash "container-transforms" new-table))
2037 |                           (dolist (trans container-transforms)
2038 |                             (postmultiply-transforms transform trans))
2039 |                           (remhash "container-transforms" new-table))
2040 |                         (when-let (prev-transform (gethash "svg-transform" container-attributes))
2041 |                           (postmultiply-transforms transform prev-transform))
2042 |                         ;; Store modified attributes
2043 |                         (setf (gethash "svg-transform" new-table) transform
2044 |                               (gethash "viewBox" new-table) viewbox
2045 |                               (gethash "width" new-table) new-w
2046 |                               (gethash "height" new-table) new-h)
2047 |                         ;; Pack a drawing function
2048 |                         (let ((funcs (loop for child across (plump-dom:children node)
2049 |                                            for func = (when (plump-dom:element-p child)
2050 |                                                         (create-renderer state child root-node new-table))
2051 |                                            when func collect func)))
2052 |                           (lambda (state)
2053 |                             ;; If it's the out-most SVG element,
2054 |                             ;; and the graphics state has no underlying image representation,
2055 |                             ;; resize the Vecto canvas to fit its size
2056 |                             (when (and first-call-p
2057 |                                        (or (not (slot-boundp state 'vecto::image))
2058 |                                            (null (vecto::image state))))
2059 |                               ;; From vecto::state-image
2060 |                               (setf (vecto::image state)
2061 |                                     (make-instance 'zpng:png
2062 |                                                    :width new-w
2063 |                                                    :height new-h
2064 |                                                    :color-type vecto::+png-color-type+)
2065 |                                     (vecto::width state) new-w
2066 |                                     (vecto::height state) new-h
2067 |                                     (vecto::clipping-path state) (vecto::make-clipping-path new-w new-h)))
2068 |                             (dolist (func funcs)
2069 |                               (funcall func state))))))))
2070 |                  ("use"
2071 |                   (let* ((id (string-left-trim '(#\#) (or (gethash "href" new-attrs)
2072 |                                                           (gethash "xlink:href" new-attrs))))
2073 |                          (new-x (if-let (val (gethash "x" new-attrs))
2074 |                                     (svg-parse-length val :width)
2075 |                                   0))
2076 |                          (new-y (if-let (val (gethash "y" new-attrs))
2077 |                                     (svg-parse-length val :height)
2078 |                                   0))
2079 |                          (transform (if-let (val (gethash "svg-transform" container-attributes))
2080 |                                         (copy-transform val)
2081 |                                       (make-transform)))
2082 |                          (child (plump-dom:get-element-by-id root-node id))
2083 |                          (child-tag (plump-dom:tag-name child))
2084 |                          ; Make a shadow tree
2085 |                          (shadow-child (make-instance 'plump:element
2086 |                                                       :parent node
2087 |                                                       :tag-name (if (member child-tag '("def" "marker" "symbol"))
2088 |                                                                   "g" child-tag)
2089 |                                                       :children (plump:make-child-array)
2090 |                                                       :attributes (plump:attributes child))))
2091 |                     (if child
2092 |                       (progn ; Move the left-top of the sub-graph to (x, y)
2093 |                         (apply-translation transform new-x new-y)
2094 |                         (setf (gethash "svg-transform" new-table) transform)
2095 |                         (maphash (lambda (key val)
2096 |                                    (when (or (string= key "style")
2097 |                                              (member key *svg-presentation-attributes* :test #'string=))
2098 |                                      (plump:set-attribute shadow-child key val)))
2099 |                                  (plump:attributes child))
2100 |                         (loop for child-child across (plump:children child)
2101 |                               for copy = (plump-dom:clone-node child-child)
2102 |                               do (plump-dom:append-child shadow-child copy))
2103 |                         (create-renderer state shadow-child root-node new-table))
2104 |                       (warn "The element ~A referenced by ~A not found" id node))))
2105 |                  (t
2106 |                   (let ((funcs (delete nil (loop for child across (plump-dom:children node)
2107 |                                                  when (plump-dom:element-p child)
2108 |                                                    collect (create-renderer state child root-node new-table)))))
2109 |                     (lambda (state)
2110 |                       (dolist (func funcs)
2111 |                         (funcall func state)))))))))))))
2112 | 
2113 | (defun draw-svg-from-string (svg-string output &key (font (get-font-file)) (viewport-width 1920) (viewport-height 1080))
2114 |   "Draw the first SVG element inside STRING.
2115 | 
2116 | If OUTPUT is a stream, write the PNG binary data to OUTPUT; Otherwise
2117 | it treat the OUTPUT as a namestring, try to write the PNG to its file
2118 | using ZPNG:WRITE-PNG."
2119 |   (let ((svg (first (plump:get-elements-by-tag-name (plump:parse svg-string) "svg"))))
2120 |     (let ((vecto::*graphics-state* (make-instance
2121 |                                     'vecto::graphics-state
2122 |                                     :width viewport-width
2123 |                                     :height viewport-height
2124 |                                     :transform-matrix (vecto::identity-matrix))))
2125 |       (vecto:set-font (vecto:get-font font) 12)
2126 |       (let ((renderer (create-renderer vecto::*graphics-state* svg)))
2127 |         (funcall renderer vecto::*graphics-state*))
2128 |       (vecto::after-painting vecto::*graphics-state*)
2129 |       (if (streamp output)
2130 |         (vecto:save-png-stream output)
2131 |         (vecto:save-png output))
2132 |       (vecto::clear-state vecto::*graphics-state*))))
2133 | 
2134 | 
2135 | ;; Test and scratch
2136 | 
2137 | (defparameter *interactive-tests*
2138 |   '(("Text and tspan" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/text/tspan01.svg")
2139 |     ("Text rotation 1" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/text/tspan04.svg")
2140 |     ("Text rotation 2" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/text/tspan05.svg")
2141 |     ("Path quadratic bezier" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/paths/quad01.svg")
2142 |     ("Path arc" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/paths/arcs01.svg")
2143 |     ("Retangle and transform" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/shapes/rect02.svg")
2144 |     ("Ellipse and transform" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/shapes/ellipse01.svg")
2145 |     ("Line and stroke-width" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/shapes/line01.svg")
2146 |     ("Polyline" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/shapes/polyline01.svg")
2147 |     ("Polygon" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/shapes/polygon01.svg")
2148 |     ("Dashed stroke" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/painting/dashes.svg")
2149 |     ("Fill rule nonzero" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/painting/fillrule-nonzero.svg")
2150 |     ("Fill rule evenodd" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/painting/fillrule-evenodd.svg")
2151 |     ("Groups and Opacity" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/masking/opacity01.svg")
2152 |     ("Linear gradient" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/pservers/lingrad01.svg")
2153 |     ("Radial gradient" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/pservers/radgrad01.svg")
2154 |     ("Use element and CSS style" "https://www.w3.org/TR/2018/CR-SVG2-20181004/images/struct/Use-changed-styles.svg")))
2155 | 
2156 | ;; Here's the interactive test adapted from LW-SVG.
2157 | ;; Can only running with LispWorks Macintosh.
2158 | ;; It requires DEXADOR and FLEXI-STREAMS packages:
2159 | ;; (ql:quickload '(dexador flexi-streams))
2160 | 
2161 | #+nil
2162 | (capi:define-interface interactive-test-interface ()
2163 |   ((i :initform 0)
2164 |    (name :initform (first (first *interactive-tests*)))
2165 |    (url :initform (second (first *interactive-tests*)))
2166 |    (wrong :initform nil))
2167 |   (:panes
2168 |    (browser
2169 |     capi:browser-pane
2170 |     :url url
2171 |     :visible-min-width 500
2172 |     :visible-min-height 500)
2173 |    (output
2174 |     capi:output-pane
2175 |     :visible-min-width 500
2176 |     :visible-min-height 500
2177 |     :background :white
2178 |     :foreground :black
2179 |     :display-callback (lambda (pane x y w h)
2180 |                         (declare (ignore x y w h))
2181 |                         (gp:draw-image
2182 |                          pane
2183 |                          (gp:convert-external-image
2184 |                           pane
2185 |                           (make-instance 'gp:external-image
2186 |                                          :type :png
2187 |                                          :data (flexi-streams:with-output-to-sequence (out)
2188 |                                                  (draw-svg-from-string
2189 |                                                   (dex:get (slot-value (capi:element-interface pane) 'url) :force-string t)
2190 |                                                   out
2191 |                                                   :viewport-width 500 :viewport-height 500))))
2192 |                          0 0)))
2193 |    (buttons
2194 |     capi:push-button-panel
2195 |     :items '(:yes :no)
2196 |     :selection-callback
2197 |     (lambda (data itf)
2198 |       (with-slots (i name url browser output wrong) itf
2199 |         (when (eql data :no)
2200 |           (push name wrong))
2201 |         (incf i)
2202 |         (if (>= i (length *interactive-tests*))
2203 |           (progn
2204 |             (if wrong
2205 |               (capi:prompt-with-list
2206 |                wrong
2207 |                (format nil "Test finished with ~A/~A errors." (length wrong) (length *interactive-tests*)))
2208 |               (capi:prompt-with-message "All test are passed!"))
2209 |             (capi:quit-interface itf))
2210 |           (progn
2211 |             (setf (capi:interface-title itf) (format nil "~A/~A ~A"
2212 |                                                      (1+ i) (1+ (length *interactive-tests*))
2213 |                                                      (first (nth i *interactive-tests*)))
2214 |                   url (second (nth i *interactive-tests*)))
2215 |             (capi:browser-pane-navigate browser url)
2216 |             (gp:invalidate-rectangle output)))))))
2217 |   (:layouts
2218 |    (main-layout
2219 |     capi:column-layout
2220 |     '(displayers-row buttons)
2221 |     :title "Compare if two images are same"
2222 |     :title-position :frame
2223 |     :adjust :center)
2224 |    (displayers-row
2225 |     capi:row-layout
2226 |     '(browser output)))
2227 |   (:default-initargs
2228 |    :title (format nil "1/~A ~A" (1+ (length *interactive-tests*)) (first (first *interactive-tests*)))))
2229 | 
2230 | ;(capi:display (make-instance 'interactive-test-interface))
2231 | 
2232 | ;; Following code can be used to draw the examples in interactive
2233 | ;; test, save them into file for checking.
2234 | #+nil
2235 | (progn
2236 |   (ql:quickload :dexador)
2237 |   (loop for i from 0
2238 |         for (nil url) in *interactive-tests*
2239 |         do (draw-svg-from-string (funcall (intern "GET" "DEX") url :force-string t) (format nil "~~/svg-test/~A.png" i)
2240 |                                  :viewport-width 500 :viewport-height 500)))
2241 | 
2242 | #|
2243 | (ql:quickload :trivial-svg)
2244 | 
2245 | (let* ((width (* 32 24))
2246 |        (height (* 32 7))
2247 |        (state (make-instance 'vecto::graphics-state
2248 |                              :width width
2249 |                              :height height
2250 |                              :transform-matrix (vecto::identity-matrix)))
2251 |        ;; We put 42 Google material symbols in ~/svg-test/
2252 |        (svg-files (directory "~/svg-test/*.svg")))
2253 |   (setf (vecto::image state)
2254 |         (make-instance 'zpng:png
2255 |                        :width width
2256 |                        :height height
2257 |                        :color-type vecto::+png-color-type+)
2258 |         (vecto::clipping-path state) (vecto::make-clipping-path width height))
2259 |   (vecto::%set-font state (vecto::%get-font state (trivial-svg:get-font-file)) 12)
2260 |   (loop for i from 0
2261 |         for svg-file in (serapeum:repeat-sequence svg-files 4)
2262 |         for svg-node = (first (plump:get-elements-by-tag-name (plump:parse svg-file) "svg"))
2263 |         do (multiple-value-bind (y x) (floor i 24)
2264 |              (let* ((state (vecto::copy state))
2265 |                     (renderer (trivial-svg:create-renderer state svg-node)))
2266 |                (vecto::%translate state (* x 32) (* y 32))
2267 |                (funcall renderer state))))
2268 |   (vecto::after-painting state)
2269 |   (zpng:write-png (vecto::image state)
2270 |                   (merge-pathnames "example.png" (asdf:system-source-directory :trivial-svg)))
2271 |   (vecto::clear-state state))
2272 | |#
2273 | 


--------------------------------------------------------------------------------