Coverage report: /home/ellis/comp/core/lib/dat/xml/svg.lisp

KindCoveredAll%
expression01611 0.0
branch038 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; dat/xml/svg.lisp --- SVG data encoders
2
 
3
 ;; based on https://github.com/orthecreedence/cl-svg-polygon
4
 
5
 ;;; Code:
6
 (in-package :dat/svg)
7
 
8
 ;;; MATRIX
9
 (defun id-matrix (dims)
10
   "Return a square identity matrix with the specified dimensions."
11
   (let ((array (make-array (* dims dims) :initial-element 0.0 :element-type 'single-float)))
12
     (dotimes (d dims)
13
       (setf (aref array (* d (1+ dims))) 1.0))
14
     array))
15
 
16
 (defun mat* (m1 m2)
17
   "Multiply 3x3 matrices m1 by m2."
18
   (let ((new (make-array 9 :initial-element 0.0 :element-type 'single-float)))
19
     (dotimes (x 3)
20
       (dotimes (y 3)
21
         (let ((prod (+ (* (aref m1 (* x 3)) (aref m2 y))
22
                        (* (aref m1 (+ (* x 3) 1)) (aref m2 (+ y 3)))
23
                        (* (aref m1 (+ (* x 3) 2)) (aref m2 (+ y 6))))))
24
           (setf (aref new (+ y (* x 3))) (coerce prod 'single-float)))))
25
     new))
26
 
27
 (defun matv* (m v)
28
   "Multiple a matrix by a vector, return the resulting vector."
29
   (let ((new (make-list 3))
30
         (vx (car v))
31
         (vy (cadr v))
32
         (vz 1))
33
     (dotimes (i 3)
34
       (setf (nth i new) (+ (* vx (aref m (* i 3)))
35
                            (* vy (aref m (+ (* i 3) 1)))
36
                            (* vz (aref m (+ (* i 3) 2))))))
37
     new))
38
 
39
 (defun m-rotate (degrees &key reverse)
40
   "Generate a rotation matrix."
41
   (let* ((matrix (id-matrix 3))
42
          (angle-rad (* (mod degrees 360) (/ PI 180)))
43
          (cos (coerce (cos angle-rad) 'single-float))
44
          (sin (coerce (sin angle-rad) 'single-float)))
45
     (setf (aref matrix 0) cos
46
           (aref matrix 1) (if reverse sin (- sin))
47
           (aref matrix 3) (if reverse (- sin) sin)
48
           (aref matrix 4) cos)
49
     matrix))
50
 
51
 (defun m-scale (x y)
52
   "Generate a scaling matrix."
53
   (let ((matrix (id-matrix 3)))
54
     (setf (aref matrix 0)  (coerce x 'single-float)
55
           (aref matrix 4)  (coerce y 'single-float))
56
     matrix))
57
   
58
 (defun m-translate (x y)
59
   "Generate a translation matrix."
60
   (let ((translatrix (id-matrix 3)))
61
     (setf (aref translatrix 2) (coerce x 'single-float)
62
           (aref translatrix 5) (coerce y 'single-float))
63
     translatrix))
64
 
65
 (defun m-skew (degrees &key (axis :x))
66
   "Generate a skew matrix along the :axis axis (:x or :y)."
67
   (let ((matrix (id-matrix 3))
68
         (angle-rad (* (mod degrees 360) (/ PI 180)))
69
         (idx (if (equal axis :x) 1 3)))
70
     (setf (aref matrix idx) (coerce (tan angle-rad) 'single-float))
71
     matrix))
72
 
73
 ;;; VECTOR
74
 (defun norm (v)
75
   "Calculate a vector norm."
76
   (expt (loop for x in v sum (expt x 2)) .5))
77
 
78
 (defun normalize (v)
79
   "Normalize a 2D vector"
80
   (let ((x (car v))
81
         (y (cadr v)))
82
     (let ((norm (norm v)))
83
       (list (/ x norm) (/ y norm)))))
84
 
85
 (defun dot-prod (v1 v2)
86
   "Give the dot product of two 2D vectors."
87
   (+ (* (car v1) (car v2))
88
      (* (cadr v1) (cadr v2))))
89
 
90
 ;;; TRANSFORMATIONS
91
 (defun parse-transform (transform)
92
   "Turn a transform(...) into an easily-parsable list structure."
93
   ;; convert "translate(-10,-20) scale(2) rotate(45) translate(5,10)" into
94
   ;; "(translate -10 -20) (scale 2) (rotate 45) (translate 5 10)"
95
   ;; (ie read-from-string'able)
96
   (let* ((transform (cl-ppcre::regex-replace-all "([a-z]+)\\(" transform "(\\1 "))
97
          (transform (cl-ppcre::regex-replace-all "," transform " ")))
98
     (read-from-string (format nil "( ~a )" transform))))
99
 
100
 (defun get-transformations (object groups)
101
   "Given an SVG object and a tree of groups, grab all transformations, starting
102
    from the top down, into a flat list so they can be applied sequentially."
103
   (let ((object-transform (getf object :transform))
104
         (object-group (getf object :group))
105
         (transformations nil))
106
     (labels ((traverse-groups (path groups)
107
                (dolist (group groups)
108
                  (when (eql (car (getf group :group)) (car path))
109
                    (let* ((groups (getf group :groups))
110
                           (transform (getf group :transform))
111
                           (transform (if (listp transform) (car transform) transform)))
112
                      (when transform
113
                        (push transform transformations))
114
                      (when groups
115
                        (traverse-groups (cdr path) groups)))))))
116
       (traverse-groups object-group groups))
117
     (when object-transform
118
       (push object-transform transformations))
119
     transformations))
120
 
121
 (defun get-matrix-from-transformation (transformation)
122
   "Given a transformation in list form (FN ARG1 ARG2 ...), turn it into a matrix
123
   which can be multipled to give the overall transformation for an object."
124
   (macrolet ((idx (var idx default)
125
                (let ((name (gensym)))
126
                  `(let ((,name (nth ,idx ,var)))
127
                     (if ,name ,name ,default)))))
128
     (let ((transformation (if (listp (car transformation))
129
                               (car transformation)
130
                               transformation)))
131
       (case (intern (write-to-string (car transformation)) :dat/svg)
132
         (matrix (vector (nth 1 transformation) (nth 3 transformation) (nth 5 transformation)
133
                         (nth 2 transformation) (nth 4 transformation) (nth 6 transformation)
134
                         0 0 1))
135
         (translate (m-translate (nth 1 transformation) (idx transformation 2 0)))
136
         (scale (m-scale (nth 1 transformation) (idx transformation 2 0)))
137
         (rotate (let ((angle (nth 1 transformation))
138
                       (center-x (idx transformation 2 0))
139
                       (center-y (idx transformation 3 0)))
140
                   (if (and (eq 0 center-x) (eq 0 center-y))
141
                       ;; just rotate, no offset funny business
142
                       (m-rotate angle)
143
                       (mat* (mat* (m-translate center-x center-y) (m-rotate angle)) (m-translate (- center-x) (- center-y))))))
144
         (skewx (m-skew (nth 1 transformation) :axis :x))
145
         (skewy (m-skew (nth 1 transformation) :axis :y))))))
146
 
147
 (defun apply-transformations (points object groups &key scale)
148
   "Apply all transformations for an object, starting from its top-level group
149
   and working down to the object itself."
150
   (let ((transformations (get-transformations object groups))
151
         (matrix (id-matrix 3))
152
         (trans-points nil))
153
     (dolist (transform transformations)
154
       (setf matrix (mat* (get-matrix-from-transformation transform) matrix)))
155
     (when scale
156
       (setf matrix (mat* (m-scale (car scale) (cadr scale)) matrix)))
157
     (loop for p across points do
158
       (push (butlast (matv* matrix (append p '(1)))) trans-points))
159
     (values (reverse trans-points)
160
             matrix)))
161
 ;;; PATHS
162
 (define-condition unsupported-path-command (error)
163
   ((text :initarg :text :reader text))
164
   (:documentation "Thrown when an unsupported action/feature is parsed in a path."))
165
 
166
 (defun points-close-equal-p (point1 point2 &key (precision 10))
167
   "Determine if two points are (about) the same. Yes, this is open to
168
    interpretation, which is why it takes a precision argument =]."
169
   (flet ((round-point (point)
170
            (mapcar (lambda (x) (/ (floor (* x precision)) precision)) point)))
171
     (equal (round-point point1) (round-point point2))))
172
 
173
 (defun replace-char (char rep str)
174
   "Replace all instances of char with rep in str (non-destructive)."
175
   (let ((new-str (make-string (length str))))
176
     (loop for i from 0
177
           for c across str do
178
       (setf (aref new-str i) (if (eq c char)
179
                                  rep
180
                                  c)))
181
     new-str))
182
 
183
 (defmacro cmd-repeat (args-and-count &body body)
184
   "Some commands can repeat values with the command, namely the curve commands:
185
        c,1,2,4,4,5,5 c,8,8,3,4,3,1
186
     can be written as
187
        c,1,2,4,4,5,5,8,8,3,4,3,1
188
   yay. This macro helps alleviate some of the issues caused by this wonderful
189
   feature in the get-points-from-path function."
190
   (let ((i (gensym))
191
         (a (gensym))
192
         (args (car args-and-count))
193
         (count (cadr args-and-count)))
194
     `(dotimes (,i (floor (/ (length ,args) ,count)))
195
        ,@body
196
        (setf cur-x (car cur-point)
197
              cur-y (cadr cur-point))
198
        (dotimes (,a ,count)
199
          (setf ,args (cdr ,args))))))
200
 
201
 (defun get-points-from-path (str-data &key (curve-resolution 10))
202
   "Given a string describing an SVG path, do our best to retrieve points along
203
   that path. Bezier curves are approximated as accurately as needed (defined by
204
   :curve-resolution).
205
 
206
   If the path generates an arc between x1,y1 and x2,y2, we just ignore the whole
207
   arc thing and set x2,y2 as the next point in the path.
208
 
209
   If Z/z ends the path in the middle, we silently return the current set of 
210
   points without continuing the path. The idea here is we are generating
211
   polygons so breaks or cutouts are not acceptable."
212
     (let ((commands (split "(?=[a-zA-Z])" str-data))
213
           (scanner-empty-p (cl-ppcre:create-scanner (concatenate 'string "[" *whitespaces* "]") :multi-line-mode t))
214
           (points nil)
215
         (parts nil)
216
         (first-point nil)
217
         (cur-point '(0 0))
218
         (last-anchor nil)
219
         (disconnected nil))
220
     (dolist (cmd-str commands)
221
       ;; this (let) splits the command from "M-113-20" to
222
       ;; ("M" "-113" "-20")
223
       (let* ((cmd-parts (cl-ppcre:split "( |,|(?<=[A-Za-z])|(?=\-))" cmd-str))
224
              (cmd (aref (car cmd-parts) 0))
225
              ;(forget (format t "cmd: ~s~%" cmd-parts))
226
              (args (remove-if #'null (mapcar (lambda (a)
227
                                                (if (cl-ppcre:scan scanner-empty-p a)
228
                                                    nil
229
                                                    (read-from-string a)))
230
                                              (cdr cmd-parts))))
231
              (cur-x (car cur-point))
232
              (cur-y (cadr cur-point)))
233
         ;; process the commands (http://www.w3.org/TR/SVG/paths.html)
234
         (case (if (eq cmd #\z)
235
                   (aref (string-upcase cmd) 0)
236
                   cmd)
237
           (#\M
238
            (cmd-repeat (args 2)
239
              (setf cur-point args)
240
              (push cur-point points)))
241
           (#\m
242
            (cmd-repeat (args 2)
243
              (setf cur-point (list (+ cur-x (car args))
244
                                    (+ cur-y (cadr args))))
245
              (push cur-point points)))
246
           (#\L
247
            (cmd-repeat (args 2)
248
              (setf cur-point args)
249
              (push cur-point points)))
250
           (#\l
251
            (cmd-repeat (args 2)
252
              (setf cur-point (list (+ cur-x (car args))
253
                                    (+ cur-y (cadr args))))
254
              (push cur-point points)))
255
           (#\H
256
            (cmd-repeat (args 1)
257
              (setf (car cur-point) (car args))
258
              (push cur-point points)))
259
           (#\h
260
            (cmd-repeat (args 1)
261
              (setf (car cur-point) (+ cur-x (car args)))
262
              (push cur-point points)))
263
           (#\V
264
            (cmd-repeat (args 1)
265
              (setf (cadr cur-point) (car args))
266
              (push cur-point points)))
267
           (#\v
268
            (cmd-repeat (args 1)
269
              (setf (cadr cur-point) (+ cur-y (car args)))
270
              (push cur-point points)))
271
           (#\C
272
            (cmd-repeat (args 6)
273
              (let ((x1 (car args))
274
                    (y1 (cadr args))
275
                    (x2 (nth 2 args))
276
                    (y2 (nth 3 args))
277
                    (x (nth 4 args))
278
                    (y (nth 5 args)))
279
                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
280
                      last-anchor (list x2 y2)
281
                      cur-point (list x y)))))
282
           (#\c
283
            (cmd-repeat (args 6)
284
              (let ((x1 (+ (car args) cur-x))
285
                    (y1 (+ (cadr args) cur-y))
286
                    (x2 (+ (nth 2 args) cur-x))
287
                    (y2 (+ (nth 3 args) cur-y))
288
                    (x (+ (nth 4 args) cur-x))
289
                    (y (+ (nth 5 args) cur-y)))
290
                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
291
                      last-anchor (list x2 y2)
292
                      cur-point (list x y)))))
293
           (#\S
294
            (cmd-repeat (args 4)
295
              (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
296
                    (y1 (+ cur-y (- cur-y (cadr last-anchor))))
297
                    (x2 (car args))
298
                    (y2 (cadr args))
299
                    (x (nth 2 args))
300
                    (y (nth 3 args)))
301
                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
302
                      last-anchor (list x2 y2)
303
                      cur-point (list x y)))))
304
           (#\s
305
            (cmd-repeat (args 4)
306
              (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
307
                    (y1 (+ cur-y (- cur-y (cadr last-anchor))))
308
                    (x2 (+ (car args) cur-x))
309
                    (y2 (+ (cadr args) cur-y))
310
                    (x (+ (nth 2 args) cur-x))
311
                    (y (+ (nth 3 args) cur-y)))
312
                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
313
                      last-anchor (list x2 y2)
314
                      cur-point (list x y)))))
315
           (#\Q
316
            (cmd-repeat (args 4)
317
              (let ((x1 (car args))
318
                    (y1 (cadr args))
319
                    (x (nth 2 args))
320
                    (y (nth 3 args)))
321
                (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
322
                      last-anchor (list x1 y1)
323
                      cur-point (list x y)))))
324
           (#\q
325
            (cmd-repeat (args 4)
326
              (let ((x1 (+ (car args) cur-x))
327
                    (y1 (+ (cadr args) cur-y))
328
                    (x (+ (nth 2 args) cur-x))
329
                    (y (+ (nth 3 args) cur-y)))
330
                (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
331
                      last-anchor (list x1 y1)
332
                      cur-point (list x y)))))
333
           (#\T
334
            (cmd-repeat (args 2)
335
              (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
336
                    (y1 (+ cur-y (- cur-y (cadr last-anchor))))
337
                    (x (car args))
338
                    (y (cadr args)))
339
                (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
340
                      last-anchor (list x1 y1)
341
                      cur-point (list x y)))))
342
           (#\t
343
            (cmd-repeat (args 2)
344
              (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
345
                    (y1 (+ cur-y (- cur-y (cadr last-anchor))))
346
                    (x (+ (car args) cur-x))
347
                    (y (+ (cadr args) cur-y)))
348
                (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
349
                      last-anchor (list x1 y1)
350
                      cur-point (list x y)))))
351
           (#\A
352
            (cmd-repeat (args 7)
353
              (let ((rx (car args))
354
                    (ry (cadr args))
355
                    (x-rot (caddr args))
356
                    (large-arc (cadddr args))
357
                    (sweep-flag (cadr (cdddr args)))
358
                    (x1 (car cur-point))
359
                    (y1 (cadr cur-point))
360
                    (x2 (+ (caddr (cdddr args)) (car cur-point)))
361
                    (y2 (+ (cadddr (cdddr args)) (cadr cur-point))))
362
                (setf points (append (elliptical-arc x1 y1 x2 y2 rx ry x-rot large-arc sweep-flag :resolution curve-resolution) points)
363
                      cur-point (list x2 y2)))))
364
           (#\a
365
            (cmd-repeat (args 7)
366
              (let ((rx (car args))
367
                    (ry (cadr args))
368
                    (x-rot (caddr args))
369
                    (large-arc (cadddr args))
370
                    (sweep-flag (cadr (cdddr args)))
371
                    (x1 (car cur-point))
372
                    (y1 (cadr cur-point))
373
                    (x2 (+ (caddr (cdddr args)) (car cur-point)))
374
                    (y2 (+ (cadddr (cdddr args)) (cadr cur-point))))
375
                (setf points (append (elliptical-arc x1 y1 x2 y2 rx ry x-rot large-arc sweep-flag :resolution curve-resolution) points)
376
                      cur-point (list x2 y2)))))
377
           (#\Z
378
            (push (coerce (reverse (if (points-close-equal-p (car points) first-point)
379
                                       (cdr points)
380
                                       points)) 'vector) parts)
381
            (setf points nil))))
382
       (when (= (length points) 1)
383
         (setf first-point (car points))))
384
     (when (not (zerop (length points)))
385
       ;; we have unfinished points. add them to the part list
386
       (setf disconnected t)
387
       (push (coerce (reverse (if (points-close-equal-p (car points) first-point)
388
                                  (cdr points)
389
                                  points)) 'vector) parts))
390
     (values (reverse parts) disconnected)))
391
 
392
 (defun bezier-cubic (x1 y1 x2 y2 ax1 ay1 ax2 ay2 &key (resolution 10))
393
   "Sample resolution points off of a cubic bezier curve from (x1,y1) to (x2,y2)
394
   using anchor points (ax1,ay1) (ax2,ay2)."
395
   (let ((points nil))
396
     (flet ((cubic (t-val p0 p1 p2 p3)
397
              (+ (* (expt (- 1 t-val) 3) p0)
398
                 (* 3 (expt (- 1 t-val) 2) t-val p1)
399
                 (* 3 (- 1 t-val) (expt t-val 2) p2)
400
                 (* (expt t-val 3) p3))))
401
       (dotimes (i resolution)
402
         (let ((t-val (* (1+ i) (/ 1 resolution))))
403
           (push (list (cubic t-val x1 ax1 ax2 x2)
404
                       (cubic t-val y1 ay1 ay2 y2))
405
                 points))))
406
     points))
407
 
408
 (defun bezier-quadratic (x1 y1 x2 y2 ax1 ay1 &key (resolution 10))
409
   "Sample resolution points off of a quadratic bezier curve from (x1,y1) to
410
   (x2,y2) using anchor points (ax1,ay1) (ax2,ay2)."
411
   (let ((points nil))
412
     (flet ((quadratic (t-val p0 p1 p2)
413
              (+ (* (expt (- 1 t-val) 2) p0)
414
                 (* 2 (- 1 t-val) t-val p1)
415
                 (* (expt t-val 2) p2))))
416
       (dotimes (i resolution)
417
         (let ((t-val (* (1+ i) (/ 1 resolution))))
418
           (push (list (quadratic t-val x1 ax1 x2)
419
                       (quadratic t-val y1 ay1 y2)) points))))
420
     points))
421
 
422
 (defun elliptical-arc (x1 y1 x2 y2 rx ry x-rotation large-arc-flag sweep-flag &key (resolution 10))
423
   "Calculate an arc in a path. Yuck."
424
   (let ((rot-mat-i (m-rotate x-rotation :reverse t))
425
         (rot-mat (m-rotate x-rotation)))
426
     ;; calculate a bunch of crap, mainly ellipse center x,y
427
     (let* ((xy-i (matv* rot-mat-i (list (/ (- x1 x2) 2)
428
                                         (/ (- y1 y2) 2))))
429
            (x-i (car xy-i))
430
            (y-i (cadr xy-i))
431
            (rx2 (expt rx 2))
432
            (ry2 (expt ry 2))
433
            (x-i2 (expt x-i 2))
434
            (y-i2 (expt y-i 2))
435
            (cxy-m (expt (/ (- (* rx2 ry2) (* rx2 y-i2) (* ry2 x-i2))
436
                            (+ (* rx2 y-i2) (* rx2 x-i2)))
437
                         .5))
438
            (cxy-m (if (eq large-arc-flag sweep-flag)
439
                       (- cxy-m)
440
                       cxy-m))
441
            (cx-i (* cxy-m (/ (* rx y-i) ry)))
442
            (cy-i (* cxy-m (/ (* ry x-i) (- rx))))
443
            (cxy (matv* rot-mat (list cx-i cy-i)))
444
            (cx (+ (car cxy) (/ (+ x1 x2) 2)))
445
            (cy (+ (cadr cxy) (/ (+ y1 y2) 2))))
446
       (flet ((angle (v1 v2)
447
                (let ((x1 (car v1))
448
                      (y1 (cadr v1))
449
                      (x2 (car v2))
450
                      (y2 (cadr v2)))
451
                  (let ((sign (if (< 0 (- (* x1 y2) (* y1 x2)))
452
                                  1
453
                                  -1)))
454
                    (* sign (acos (/ (dot-prod v1 v2)
455
                                     (* (norm v1) (norm v2)))))))))
456
         ;; calculate the start/delta angles
457
         (let ((theta-1 (angle (list 1 0) (list (/ (- x-i cx-i) rx)
458
                                                (/ (- y-i cy-i) ry))))
459
               (theta-delta (angle (list (/ (- x-i cx-i) rx)
460
                                         (/ (- y-i cy-i) ry))
461
                                   (list (/ (- (- x-i) cx-i) rx)
462
                                         (/ (- (- y-i) cy-i) ry)))))
463
           (let ((theta-step (/ theta-delta resolution))
464
                 (points nil))
465
             ;; create our points for the ellipse. if this were a true
466
             ;; implementation, we'd do radii correction such that x2,y2 always
467
             ;; fall ON the ellipse path, but i truly do not care enough to
468
             ;; bother. if your SVG generator sucks, take it up with them, or
469
             ;; better yet do the proper calculations and issue a pull request.
470
             (dotimes (i resolution)
471
               (let ((angle (+ theta-1 (* theta-step i))))
472
                 (let ((xy (matv* rot-mat (list (* rx (cos angle))
473
                                                (* ry (sin angle))))))
474
                   (push (list (+ (car xy) cx)
475
                               (+ (cadr xy) cy)) points))))
476
             ;; get the last point on there.
477
             (push (list x2 y2) points)
478
             (reverse points)))))))
479
 
480
 ;;; SVG
481
 (define-condition not-an-object (simple-condition) ())
482
 
483
 (defun get-points-from-ellipse (x y rx ry &key (curve-resolution 20))
484
   "Calculate curve-resolution points along an ellipse. Can be used for circles
485
   too (when rx == ry)."
486
   (let ((points (make-array curve-resolution)))
487
     (dotimes (i curve-resolution)
488
       (let ((rad (* i (/ (* 2 PI) curve-resolution))))
489
         (setf (aref points i)
490
               (list (coerce (+ x (* (cos rad) rx)) 'single-float)
491
                     (coerce (+ y (* (sin rad) ry)) 'single-float)))))
492
     points))
493
 
494
 (defmacro with-plist-string-reads (plist bindings &body body)
495
   "Helper macro to make convert-to-points much more readable. Basically wraps
496
   around reading values from a string in a plist and binding the result to a
497
   variable:
498
   
499
     (with-plist-string-reads my-plist ((x :x) (y :y))
500
       (+ x y))
501
   
502
   Expands to:
503
 
504
     (let ((x (read-from-string (getf my-plist :x)))
505
           (y (read-from-string (getf my-plist :y))))
506
       (+ x y))
507
 
508
   Much cleaner."
509
   `(let ,(loop for binding in bindings collect
510
           (list (car binding) `(read-from-string (getf ,plist ,(cadr binding)))))
511
      ,@body))
512
 
513
 (defun convert-to-points (obj &key (curve-resolution 10))
514
   "Take an object loaded from and SVG file (most likely using parse-svg-nodes)
515
   and turn it into a set of points describing a polygon. Curves are
516
   approximated using :curve-resolution. The higher the resolution, the more
517
   accurate the curve will be. This works for paths with bezier curves as well
518
   as ellipses and circles."
519
   (case (intern (string-upcase (getf obj :type)) :dat/svg)
520
     (rect
521
       (with-plist-string-reads obj ((x :x) (y :y) (w :width) (h :height)) 
522
         (list :points (list (vector (list x y)
523
                                     (list (+ x w) y)
524
                                     (list (+ x w) (+ y h))
525
                                     (list x (+ y h)))))))
526
     (polygon
527
       (let* ((pairs (uiop:split-string (getf obj :points)))
528
              (points (loop for pair in pairs
529
                            if (find #\, pair) collect (progn (setf (aref pair (search "," pair)) #\space)
530
                                                              (read-from-string (format nil "(~a)" pair))))))
531
         (list :points (list (coerce points 'vector)))))
532
     (path
533
       (multiple-value-bind (parts disconnected)
534
           (get-points-from-path (getf obj :d) :curve-resolution curve-resolution)
535
         (list :points parts :meta (list :disconnected disconnected))))
536
     (ellipse 
537
       (with-plist-string-reads obj ((x :cx) (y :cy) (rx :rx) (ry :ry))
538
         (list :points (list (get-points-from-ellipse x y rx ry :curve-resolution curve-resolution)))))
539
     (circle
540
       (with-plist-string-reads obj ((x :cx) (y :cy) (r :r))
541
         (list :points (list (get-points-from-ellipse x y r r :curve-resolution curve-resolution)))))
542
     (t
543
       (error 'not-an-object))))
544
 
545
 (defun get-node-attr (node attr-name)
546
   "Given a node, get the attribute stored under attr-name."
547
   (cadr (dat/xml::find-attrib attr-name node)))
548
 
549
 (defun parse-svg-nodes (nodes &key parent-group (next-id 0) save-attributes (group-id-attribute-name "id"))
550
   "Given an SVG doc read via dat/xml:parse, return two things:
551
 
552
     1. A list of plist objects describing ALL the objects found in the SVG file.
553
        Each object stores the group it's part of along with its attributes and
554
        transformations.
555
     2. A list of plist objects describing ALL the groups found, each storing its
556
        group id (created if not explicit) and any transformations that group has.
557
   
558
   The idea is that given this data, we can easily generate polygons for each
559
   object and then apply transformations to it starting with its top-level group
560
   and working down to the object's transformations itself."
561
   (let ((objs nil)
562
         (groups nil))
563
     (loop for node in (xml-node-children nodes)
564
           do (let ((tag (xml-node-name node)))
565
                (if (equal tag "g")
566
                    (let* ((gid (get-node-attr node group-id-attribute-name))
567
                           (gid (if gid gid (get-node-attr node "id")))
568
                           (gid (list (if gid gid (incf next-id))))
569
                           (full-gid (if parent-group
570
                                         (append parent-group gid)
571
                                         gid)))
572
                      (multiple-value-bind (sub-nodes sub-groups) (parse-svg-nodes node
573
                                                                                   :parent-group full-gid
574
                                                                                   :next-id next-id
575
                                                                                   :save-attributes save-attributes
576
                                                                                   :group-id-attribute-name group-id-attribute-name)
577
                        (setf objs (append sub-nodes objs))
578
                        (push (list :group gid :transform (parse-transform (get-node-attr node "transform")) :groups sub-groups) groups)))
579
                    (let* ((gid parent-group)
580
                           (obj (list :type tag :group gid))
581
                           (tagsym (intern (string-upcase tag) :dat/svg))
582
                           (attrs (append (case tagsym
583
                                            (rect (list "x" "y" "width" "height"))
584
                                            (polygon (list "points"))
585
                                            (path (list "d"))
586
                                            (ellipse (list "cx" "cy" "rx" "ry"))
587
                                            (circle (list "cx" "cy" "r"))
588
                                            (t nil))
589
                                          save-attributes)))
590
                      (when attrs
591
                        (push (append obj (loop for attr in (append attrs (list "transform" "fill" "style" "opacity"))
592
                                                for val = (get-node-attr node attr)
593
                                                for parsed = (if (and val (equal attr "transform")) (parse-transform val) val)
594
                                                if parsed append (list (read-from-string (format nil ":~a" attr)) parsed)))
595
                              objs))))))
596
     (values objs groups)))
597
 
598
 (defun file-contents (path)
599
   "Sucks up an entire file from PATH into a freshly-allocated string,
600
   returning two values: the string and the number of bytes read."
601
   (with-open-file (s path)
602
     (let* ((len (file-length s))
603
            (data (make-string len)))
604
       (values data (read-sequence data s)))))
605
 
606
 (defun parse-svg-string (svg-str &key (curve-resolution 10) scale save-attributes (group-id-attribute-name "id"))
607
   "Parses an SVG string, creating the nodes and groups from the SVG, then
608
   converts each object into a set of points using the data in that object and
609
   the transformations from the groups the object belongs to (and the object's
610
   own transformations).
611
 
612
   SVG object curve resolutions can be set via :curve-resolution (the higher the
613
   value, the more accurate curves are)."
614
   (multiple-value-bind (nodes groups)
615
       (parse-svg-nodes (xml-parse svg-str :quash-errors nil) :save-attributes save-attributes :group-id-attribute-name group-id-attribute-name)
616
     (remove-if
617
       'null
618
       (mapcar (lambda (node)
619
                 (handler-case
620
                   (let* ((points-and-meta (convert-to-points node :curve-resolution curve-resolution))
621
                          (points-and-holes (getf points-and-meta :points))
622
                          (points (apply-transformations (car points-and-holes) node groups :scale scale))
623
                          (holes nil))
624
                     (dolist (hole (cdr points-and-holes))
625
                       (push (coerce (apply-transformations hole node groups :scale scale) 'vector) holes))
626
                     (append node (list :point-data (coerce points 'vector) :holes holes :meta (getf points-and-meta :meta))))
627
                   (not-an-object ()
628
                     nil)))
629
               nodes))))
630
 
631
 (defun parse-svg-file (filename &key (curve-resolution 10) scale save-attributes (group-id-attribute-name "id"))
632
   "Simple wrapper around parse-svg-string.
633
   
634
   SVG object curve resolutions can be set via :curve-resolution (the higher the
635
   value, the more accurate curves are)."
636
   (parse-svg-string (file-contents filename) :curve-resolution curve-resolution :scale scale :save-attributes save-attributes :group-id-attribute-name group-id-attribute-name))