paths working!
Haldean Brown
4 years ago
59 | 59 | (rel-base '(0 . 0)) ; the position we base relative moves off of, updated at the end of each stanza |
60 | 60 | (last-start nil) ; last path start position |
61 | 61 | (last-ctrl-point nil) ; the last control point used in any curve operation, for S paths |
62 | (gcode gcode-preamble) | |
62 | (gcode gcode-preamble) ; transformed, complete gcode | |
63 | (gcode-unxf nil) ; untransformed gcode that is being generated | |
63 | 64 | ) |
64 | 65 | |
65 | 66 | (defun point-add (a b) |
70 | 71 | (defun arc-center-xy (a xy1p) |
71 | 72 | "Finds and returns (cx, cy), is-clockwise, theta1, theta2 - theta1, in that |
72 | 73 | order, as specified by the SVG arc implementation notes" |
73 | (print a) | |
74 | (print xy1p) | |
75 | 74 | (let* ((rx (abs (first a))) |
76 | 75 | (ry (abs (second a))) |
77 | 76 | (rx2 (expt rx 2)) |
88 | 87 | (Lambda (+ (/ (expt x-prime 2) rx2) (/ (expt y-prime 2) ry2)))) |
89 | 88 | (if (> Lambda 1.0d0) |
90 | 89 | (let ((scale (+ (sqrt Lambda) 0.0001))) |
90 | (when (> scale 2) | |
91 | (error "poorly formed arc, maybe? ~A ~A" a xy1p)) | |
91 | 92 | (arc-center-xy (append (list (* scale rx) (* scale ry)) (subseq a 2)) xy1p)) |
92 | 93 | (let* ((cxy-rc (* (if (equal large-arc? cw?) -1.0 1.0) |
93 | 94 | (sqrt (/ (- (* rx2 ry2) (* rx2 (expt y-prime 2)) (* ry2 (expt x-prime 2))) |
138 | 139 | |
139 | 140 | (defun apply-xform (xform p &key (pfunc #'point)) |
140 | 141 | (clem-to-list (clem:mat-mult xform (funcall pfunc p)))) |
141 | (defun make-xformer (xform &key (pfunc #'point)) (lambda (p) (apply-xform xform p :pfunc pfunc))) | |
142 | (defun apply-xforms (xform args &key (pfunc #'point)) (mapcar (make-xformer xform :pfunc pfunc) args)) | |
143 | ||
144 | (defun to-abs (s xform svgm) | |
142 | ||
143 | (defun update-assoc (alist &rest update) | |
144 | (labels | |
145 | ((update-assoc-1 (alist k v) | |
146 | (cond | |
147 | ((null alist) (cons (cons k v) nil)) | |
148 | ((eq (caar alist) k) (cons (cons k v) (cdr alist))) | |
149 | (t (cons (car alist) (update-assoc-1 (cdr alist) k v))) | |
150 | ))) | |
151 | (reduce (lambda (al up) (update-assoc-1 al (car up) (cdr up))) | |
152 | update :initial-value alist))) | |
153 | ||
154 | (defun xform-gcode-xy (xform line) | |
155 | (let ((x (cdr (assoc :X line))) | |
156 | (y (cdr (assoc :Y line)))) | |
157 | (cond | |
158 | ((and (null x) (null y)) line) | |
159 | ((or (null x) (null y)) (error "must specify either both x and y or neither, got " line)) | |
160 | (t (let ((xformed (apply-xform xform (cons x y)))) | |
161 | (update-assoc line (cons :X (car xformed)) (cons :Y (cdr xformed)))))))) | |
162 | ||
163 | (defun xform-gcode-arc (xform line) | |
164 | (let ((x (cdr (assoc :X line))) | |
165 | (y (cdr (assoc :Y line))) | |
166 | (i (cdr (assoc :I line))) | |
167 | (j (cdr (assoc :J line)))) | |
168 | (let ((xfxy (apply-xform xform (cons x y))) | |
169 | (xfij (apply-xform xform (cons i j) :pfunc #'vec))) | |
170 | (update-assoc line | |
171 | (cons :X (car xfxy)) | |
172 | (cons :Y (cdr xfxy)) | |
173 | (cons :I (car xfij)) | |
174 | (cons :J (cdr xfij)) | |
175 | )))) | |
176 | ||
177 | (defun xform-gcode (xform lines) | |
178 | (mapcar (lambda (line) | |
179 | (let ((mode (cdr (assoc :G line)))) | |
180 | (alexandria:switch (mode) | |
181 | (0 (xform-gcode-xy xform line)) | |
182 | (1 (xform-gcode-xy xform line)) | |
183 | (2 (xform-gcode-arc xform line)) | |
184 | (3 (xform-gcode-arc xform line)) | |
185 | (otherwise line) | |
186 | ))) | |
187 | lines)) | |
188 | ||
189 | (defun to-abs (s svgm) | |
145 | 190 | (labels ((from-pairs (mode ps) |
146 | 191 | (splat-pairs mode (pairs-to-abs-xy svgm ps))) |
147 | 192 | (auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s)))) |
154 | 199 | (#\q (auto-pairs)) |
155 | 200 | (#\t (auto-pairs)) |
156 | 201 | (#\h (from-pairs #\L (list (cons (second s) 0)))) |
157 | (#\H (splat-pairs #\L (list (vec+ (svgm-current svgm) (cons (second s) 0))))) | |
202 | (#\H (list #\L (second s) (cdr (svgm-current svgm)))) | |
158 | 203 | (#\v (from-pairs #\L (list (cons 0 (second s))))) |
159 | (#\V (splat-pairs #\L (list (vec+ (svgm-current svgm) (cons 0 (second s)))))) | |
204 | (#\V (list #\L (car (svgm-current svgm)) (second s))) | |
160 | 205 | |
161 | 206 | (#\a (let* ((args (rest s)) |
162 | 207 | (xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args))))) |
163 | 208 | ; send the abs version through to-abs again to be transformed |
164 | (to-abs (append '(#\A) (subseq s 1 6) (list (car xy) (cdr xy))) xform svgm))) | |
209 | (to-abs (append '(#\A) (subseq s 1 6) (list (car xy) (cdr xy))) svgm))) | |
165 | 210 | (#\A (let* ((args (rest s)) |
166 | 211 | (rx (first args)) |
167 | 212 | (ry (second args)) |
185 | 230 | (list (cons :G mode) (cons :X (car xy)) (cons :Y (cdr xy)))) |
186 | 231 | |
187 | 232 | (defun push-polyline (svgm pts) |
188 | (reduce (lambda (svgm p) (push-final-stanza svgm (list #\L (car p) (cdr p)))) pts :initial-value svgm)) | |
233 | (reduce (lambda (svgm p) (push-final-stanza svgm (list #\L (car p) (cdr p)))) | |
234 | pts :initial-value svgm)) | |
189 | 235 | |
190 | 236 | (defun linspace (a b step) |
191 | 237 | (let* ((steps (abs (ceiling (/ (- b a) step)))) |
199 | 245 | (cur-xy (svgm-current svgm)) |
200 | 246 | (ls (svgm-last-start svgm)) |
201 | 247 | (gcode (svgm-gcode svgm)) |
248 | (gunxf (svgm-gcode-unxf svgm)) | |
202 | 249 | (rb (svgm-rel-base svgm)) |
203 | 250 | ) |
204 | 251 | (alexandria:switch (mode) |
206 | 253 | (#\M (let ((p (cons (first args) (second args)))) |
207 | 254 | (make-svg-machine |
208 | 255 | :current p :last-start p :rel-base rb |
209 | :gcode (append gcode (list '((:G . 0) (:Z . 1)) | |
210 | (gcode-goto p :mode 0) | |
211 | '((:G . 1) (:Z . -1)))) | |
256 | :gcode-unxf (append gunxf (list '((:G . 0) (:Z . 1)) (gcode-goto p :mode 0) '((:G . 1) (:Z . -1)))) | |
257 | :gcode gcode | |
212 | 258 | ))) |
213 | 259 | (#\Z (progn |
214 | 260 | (when (null ls) |
215 | 261 | (error "got Z (close path) when there's no current path")) |
216 | 262 | (make-svg-machine |
217 | 263 | :current ls :last-start ls :rel-base rb |
218 | :gcode (append gcode (list (gcode-goto ls))) | |
264 | :gcode-unxf (append gunxf (list (gcode-goto ls))) :gcode gcode | |
219 | 265 | ))) |
220 | 266 | |
221 | 267 | ; lines |
222 | 268 | (#\L (let ((p (cons (first args) (second args)))) |
223 | 269 | (make-svg-machine |
224 | :current p :last-start (if (null ls) cur-xy ls) | |
225 | :gcode (append gcode (list (gcode-goto p))) :rel-base rb | |
270 | :current p :last-start (if (null ls) cur-xy ls) :rel-base rb | |
271 | :gcode-unxf (append gunxf (list (gcode-goto p))) :gcode gcode | |
226 | 272 | ))) |
227 | 273 | |
228 | 274 | ; cubic beziers |
233 | 279 | collect (eval-bezier-cubic theta cur-xy c1 c2 p2))))) |
234 | 280 | (make-svg-machine |
235 | 281 | :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly) |
236 | :gcode (svgm-gcode svg-poly) :last-ctrl-point c2 :rel-base rb | |
282 | :gcode (svgm-gcode svg-poly) :gcode-unxf (svgm-gcode-unxf svg-poly) | |
283 | :last-ctrl-point c2 :rel-base rb | |
237 | 284 | ))) |
238 | 285 | (#\S (let* ((lcp? (svgm-last-ctrl-point svgm)) |
239 | 286 | (lcp (if (null lcp?) cur-xy lcp?)) |
244 | 291 | (#\Q (let* ((c (cons (first args) (second args))) |
245 | 292 | (p2 (cons (fifth args) (sixth args))) |
246 | 293 | (svg-poly (push-polyline svgm (loop for theta in (linspace 0 1 0.05) |
247 | collect (eval-bezier-quadratic theta cur-xy c p2))))) | |
294 | collect (eval-bezier-quadratic theta cur-xy c p2))))) | |
248 | 295 | (make-svg-machine |
249 | 296 | :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly) |
250 | :gcode (svgm-gcode svg-poly) :last-ctrl-point c :rel-base rb | |
297 | :gcode (svgm-gcode svg-poly) :gcode-unxf (svgm-gcode-unxf svg-poly) | |
298 | :last-ctrl-point c :rel-base rb | |
251 | 299 | ))) |
252 | 300 | (#\T (let* ((lcp? (svgm-last-ctrl-point svgm)) |
253 | 301 | (lcp (if (null lcp?) cur-xy lcp?)) |
261 | 309 | (ij (vec- center-xy cur-xy))) |
262 | 310 | (make-svg-machine |
263 | 311 | :current xy :last-start ls :rel-base rb |
264 | :gcode (append gcode (list (list (cons :G (if cw? 3 2)) | |
265 | (cons :I (car ij)) | |
266 | (cons :J (cdr ij)) | |
267 | (cons :X (car xy)) | |
268 | (cons :Y (cdr xy))))) | |
312 | :gcode gcode | |
313 | :gcode-unxf (append gunxf (list (list (cons :G (if cw? 3 2)) | |
314 | (cons :I (car ij)) | |
315 | (cons :J (cdr ij)) | |
316 | (cons :X (car xy)) | |
317 | (cons :Y (cdr xy))))) | |
269 | 318 | )))) |
270 | 319 | |
271 | 320 | ; rel-base update |
272 | (:end-stanza (make-svg-machine :current cur-xy :last-start ls :rel-base cur-xy :gcode gcode)) | |
321 | (:end-stanza (make-svg-machine :current cur-xy :last-start ls :rel-base cur-xy | |
322 | :gcode gcode :gcode-unxf gunxf)) | |
273 | 323 | |
274 | 324 | (otherwise (error "unsupported mode ~A" mode)) |
275 | 325 | ))) |
276 | 326 | |
277 | 327 | (defun push-stanza (svgm sraw xform) |
278 | 328 | "Creates and returns a new svg machine that includes the result of interpreting the given stanza" |
279 | (push-final-stanza svgm (to-abs sraw xform svgm))) | |
329 | (push-final-stanza svgm (to-abs sraw svgm))) | |
280 | 330 | |
281 | 331 | (defun run-stanzas (stanzas xform svgm) |
282 | 332 | (reduce (lambda (svgm s) (push-stanza svgm s xform)) stanzas :initial-value svgm)) |
314 | 364 | |
315 | 365 | (defun load-path-args (stz) |
316 | 366 | (when (> (length stz) 0) |
317 | (multiple-value-bind (st end) (cl-ppcre:scan "[\\-]?[0-9]*(\\.[0-9]+|[0-9]*)" stz) | |
318 | (cons (parse-float:parse-float (subseq stz st end)) | |
319 | (load-path-args (string-trim ", " (subseq stz end))))))) | |
367 | (let ((stz-clean (string-trim '(#\Space #\Newline #\Tab #\Linefeed #\Return #\,) stz))) | |
368 | (multiple-value-bind (st end) (cl-ppcre:scan "[\\-]?[0-9]*(\\.[0-9]+|[0-9]*)" stz-clean) | |
369 | (cons (parse-float:parse-float (subseq stz-clean st end)) | |
370 | (load-path-args (subseq stz-clean end))))))) | |
320 | 371 | |
321 | 372 | (defun load-path-stanzas (d) |
322 | 373 | (when (> (length d) 0) |
328 | 379 | |
329 | 380 | (defun load-path-data (d) |
330 | 381 | (reduce #'append (mapcar #'normalize-stanza (load-path-stanzas d)))) |
382 | ||
383 | (defun update-struct (struct &rest bindings) | |
384 | (loop | |
385 | with copy = (copy-structure struct) | |
386 | for (slot value) on bindings by #'cddr | |
387 | do (setf (slot-value copy slot) value) | |
388 | finally (return copy))) | |
389 | ||
390 | (defun xform-svgm (svgm xform) | |
391 | "Transforms gcode-unxf and appends it onto the gcode list" | |
392 | (update-struct svgm | |
393 | 'gcode-unxf nil | |
394 | 'gcode (append (svgm-gcode svgm) | |
395 | (xform-gcode xform (svgm-gcode-unxf svgm))))) | |
331 | 396 | |
332 | 397 | (defun load-svg-from-xml (data svgm xform-stack) |
333 | 398 | (if (listp data) |
342 | 407 | (children (cddr data)) |
343 | 408 | (pathdata (when (string-equal (car tag) "path") |
344 | 409 | (load-path-data (cadr (assoc "d" attributes :test #'string-equal))))) |
345 | (svgm-new (if (null pathdata) svgm (run-stanzas pathdata xform svgm)))) | |
410 | (svgm-unxf (if (null pathdata) svgm (run-stanzas pathdata xform svgm))) | |
411 | (svgm-new (xform-svgm svgm-unxf xform)) | |
412 | ) | |
346 | 413 | (reduce (lambda (asvgm child) |
347 | 414 | (load-svg-from-xml child asvgm new-xform-stack)) |
348 | 415 | children |