9 | 9 |
|
10 | 10 |
(defun reshape-to-2x3 (vs)
|
11 | 11 |
(clem:array->matrix
|
12 | |
(make-array '(2 3)
|
|
12 |
(make-array '(3 3)
|
13 | 13 |
:initial-contents (list (list (first vs) (second vs) (third vs))
|
14 | |
(list (fourth vs) (fifth vs) (sixth vs))))))
|
|
14 |
(list (fourth vs) (fifth vs) (sixth vs))
|
|
15 |
'(0 0 1)))))
|
15 | 16 |
(defun point (xy) (clem:array->matrix
|
16 | 17 |
(make-array '(3 1)
|
17 | 18 |
:initial-contents (list (list (car xy))
|
|
54 | 55 |
(defstruct (svg-machine (:conc-name svgm-))
|
55 | 56 |
(current '(0 . 0)) ; current position
|
56 | 57 |
(last-start nil) ; last path start position
|
|
58 |
(last-ctrl-point nil) ; the last control point used in any curve operation, for S paths
|
57 | 59 |
(gcode '())
|
58 | 60 |
)
|
59 | 61 |
|
|
123 | 125 |
:current p :last-start (if (null ls) cur-xy ls)
|
124 | 126 |
:gcode (append gcode (list (gcode-goto p)))
|
125 | 127 |
)))
|
126 | |
(#\C (push-polyline svgm xform
|
127 | |
(loop for theta in *theta-steps*
|
128 | |
collect (eval-bezier-cubic
|
129 | |
theta
|
130 | |
cur-xy
|
131 | |
(cons (first args) (second args))
|
132 | |
(cons (third args) (fourth args))
|
133 | |
(cons (fifth args) (sixth args))
|
134 | |
))))
|
|
128 |
(#\C (let* ((c1 (cons (first args) (second args)))
|
|
129 |
(c2 (cons (third args) (fourth args)))
|
|
130 |
(p2 (cons (fifth args) (sixth args)))
|
|
131 |
(svg-poly (push-polyline svgm xform (loop for theta in *theta-steps*
|
|
132 |
collect (eval-bezier-cubic theta cur-xy c1 c2 p2)))))
|
|
133 |
(make-svg-machine
|
|
134 |
:current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
|
|
135 |
:gcode (svgm-gcode svg-poly) :last-ctrl-point c2
|
|
136 |
)))
|
|
137 |
(#\S (let* ((lcp? (svgm-last-ctrl-point svgm))
|
|
138 |
(lcp (if (null lcp?) cur-xy lcp?))
|
|
139 |
(c1 (vec+ cur-xy (vec- cur-xy lcp))))
|
|
140 |
(push-stanza svgm (append (list #\C (car c1) (cdr c1)) args) xform)))
|
135 | 141 |
(#\Z (progn
|
136 | 142 |
(when (null ls)
|
137 | 143 |
(error "got Z (close path) when there's no current path"))
|
|
190 | 196 |
(load-path-stanzas (subseq d end)))
|
191 | 197 |
)))
|
192 | 198 |
|
193 | |
(defun load-path-data (d xform-stack)
|
|
199 |
(defun load-path-data (d)
|
194 | 200 |
(reduce #'append (mapcar #'normalize-stanza (load-path-stanzas d))))
|
195 | 201 |
|
196 | |
(defun load-svg-from-xml (data &key (xform-stack nil))
|
197 | |
(when (listp data)
|
|
202 |
(defun load-svg-from-xml (data svgm xform-stack)
|
|
203 |
(if (listp data)
|
198 | 204 |
(let* ((tag (car data))
|
199 | 205 |
(attributes (cadr data))
|
200 | 206 |
(xform-attr (assoc "transform" attributes :test #'string-equal))
|
201 | 207 |
(new-xform-stack (if (null xform-attr)
|
202 | 208 |
xform-stack
|
203 | 209 |
(cons (parse-transform (cadr xform-attr)) xform-stack)))
|
|
210 |
(xform (reduce #'clem:mat-mult new-xform-stack
|
|
211 |
:initial-value (clem:identity-matrix 3)))
|
204 | 212 |
(children (cddr data))
|
205 | 213 |
(pathdata (when (string-equal (car tag) "path")
|
206 | |
(load-path-data (cadr (assoc "d" attributes :test #'string-equal)) new-xform-stack))))
|
207 | |
(append pathdata (reduce #'append (mapcar #'load-svg-from-xml children)))
|
208 | |
)))
|
209 | |
|
210 | |
(defun load-svg (fname)
|
|
214 |
(load-path-data (cadr (assoc "d" attributes :test #'string-equal)))))
|
|
215 |
(svgm-new (if (null pathdata) svgm (run-stanzas pathdata xform svgm))))
|
|
216 |
(reduce (lambda (asvgm child)
|
|
217 |
(load-svg-from-xml child asvgm new-xform-stack))
|
|
218 |
children
|
|
219 |
:initial-value svgm-new)
|
|
220 |
)
|
|
221 |
svgm))
|
|
222 |
|
|
223 |
(defun svg-to-gcode (fname)
|
211 | 224 |
(let* ((svgtxt (alexandria:read-file-into-string fname))
|
212 | 225 |
(svgdata (xmls:parse svgtxt)))
|
213 | |
(load-svg-from-xml svgdata)))
|
|
226 |
(svgm-gcode (load-svg-from-xml svgdata (make-svg-machine) nil))))
|