adds support for <circle> and <line>
Haldean Brown
4 years ago
230 | 230 | (list (cons :G mode) (cons :X (car xy)) (cons :Y (cdr xy)))) |
231 | 231 | |
232 | 232 | (defun push-polyline (svgm pts) |
233 | (reduce (lambda (svgm p) (push-final-stanza svgm (list #\L (car p) (cdr p)))) | |
233 | (reduce (lambda (svgm p) (push-stanza svgm (list #\L (car p) (cdr p)))) | |
234 | 234 | pts :initial-value svgm)) |
235 | 235 | |
236 | 236 | (defun linspace (a b step) |
238 | 238 | (s (/ (- b a) steps))) |
239 | 239 | (loop for i from 0 to steps collect (+ a (* s i))))) |
240 | 240 | |
241 | (defun push-final-stanza (svgm s) | |
242 | "Creates and returns a new svg machine that includes the result of interpreting the given stanza. Stanza must be 'final', meaning that it's already transformed and in absolute coordinates." | |
241 | (defun push-stanza (svgm s) | |
242 | "Creates and returns a new svg machine that includes the result of interpreting the given stanza. Stanza must be 'final', meaning that it's already in absolute coordinates." | |
243 | 243 | (let* ((mode (first s)) |
244 | 244 | (args (rest s)) |
245 | 245 | (cur-xy (svgm-current svgm)) |
285 | 285 | (#\S (let* ((lcp? (svgm-last-ctrl-point svgm)) |
286 | 286 | (lcp (if (null lcp?) cur-xy lcp?)) |
287 | 287 | (c1 (vec+ cur-xy (vec- cur-xy lcp)))) |
288 | (push-final-stanza svgm (append (list #\C (car c1) (cdr c1)) args)))) | |
288 | (push-stanza svgm (append (list #\C (car c1) (cdr c1)) args)))) | |
289 | 289 | |
290 | 290 | ; quadratic beziers |
291 | 291 | (#\Q (let* ((c (cons (first args) (second args))) |
300 | 300 | (#\T (let* ((lcp? (svgm-last-ctrl-point svgm)) |
301 | 301 | (lcp (if (null lcp?) cur-xy lcp?)) |
302 | 302 | (c (vec+ cur-xy (vec- cur-xy lcp)))) |
303 | (push-final-stanza svgm (append (list #\Q (car c) (cdr c)) args)))) | |
303 | (push-stanza svgm (append (list #\Q (car c) (cdr c)) args)))) | |
304 | 304 | |
305 | 305 | ; arcs |
306 | 306 | (#\A |
324 | 324 | (otherwise (error "unsupported mode ~A" mode)) |
325 | 325 | ))) |
326 | 326 | |
327 | (defun push-stanza (svgm sraw xform) | |
328 | "Creates and returns a new svg machine that includes the result of interpreting the given stanza" | |
329 | (push-final-stanza svgm (to-abs sraw svgm))) | |
330 | ||
331 | (defun run-stanzas (stanzas xform svgm) | |
332 | (reduce (lambda (svgm s) (push-stanza svgm s xform)) stanzas :initial-value svgm)) | |
327 | (defun run-stanzas (stanzas svgm) | |
328 | (reduce (lambda (svgm s) (push-stanza svgm (to-abs s svgm))) stanzas :initial-value svgm)) | |
333 | 329 | |
334 | 330 | (defun normalize-stanza (s) |
335 | 331 | "Takes a stanza of the form (MODE ARG0 ARG1 ARG2 ... ARGN) and returns a list of stanzas |
394 | 390 | 'gcode (append (svgm-gcode svgm) |
395 | 391 | (xform-gcode xform (svgm-gcode-unxf svgm))))) |
396 | 392 | |
393 | (defun a (attr data) | |
394 | (parse-float:parse-float (cadr (assoc attr (cadr data) :test #'string-equal)))) | |
395 | ||
396 | (defun load-unxf-path (svgm data) | |
397 | (run-stanzas (load-path-data (cadr (assoc "d" (cadr data) :test #'string-equal))) svgm)) | |
398 | (defun load-unxf-line (svgm d) | |
399 | (run-stanzas (list (list #\M (a "x1" d) (a "y1" d)) (list #\L (a "x2" d) (a "y2" d))) svgm)) | |
400 | (defun load-unxf-circle (svgm d) | |
401 | (let* ((cx (a "cx" d)) (cy (a "cy" d)) (r (a "r" d)) | |
402 | (xx (+ cx r)) (yy cy)) | |
403 | (update-struct | |
404 | svgm | |
405 | 'gcode-unxf (list | |
406 | (list '(:G . 0) '(:Z . 1)) | |
407 | (list '(:G . 0) (cons :X xx) (cons :Y yy)) | |
408 | (list '(:G . 1) '(:Z . -1)) | |
409 | (list '(:G . 2) (cons :X xx) (cons :Y yy) (cons :I (- r)) '(:J . 0)) | |
410 | (list '(:G . 0) '(:Z . 1)) | |
411 | )))) | |
412 | ||
413 | (defun load-unxf-gcode (svgm data) | |
414 | (funcall (alexandria:switch ((caar data) :test #'string-equal) | |
415 | ("path" #'load-unxf-path) | |
416 | ("line" #'load-unxf-line) | |
417 | ("circle" #'load-unxf-circle) | |
418 | (otherwise (lambda (svgm &rest _) svgm)) | |
419 | ) | |
420 | svgm data)) | |
421 | ||
397 | 422 | (defun load-svg-from-xml (data svgm xform-stack) |
398 | 423 | (if (listp data) |
399 | (let* ((tag (car data)) | |
400 | (attributes (cadr data)) | |
401 | (xform-attr (assoc "transform" attributes :test #'string-equal)) | |
402 | (new-xform-stack (if (null xform-attr) | |
403 | xform-stack | |
404 | (cons (parse-transform (cadr xform-attr)) xform-stack))) | |
405 | (xform (reduce #'clem:mat-mult new-xform-stack | |
406 | :initial-value (clem:identity-matrix 3))) | |
407 | (children (cddr data)) | |
408 | (pathdata (when (string-equal (car tag) "path") | |
409 | (load-path-data (cadr (assoc "d" attributes :test #'string-equal))))) | |
410 | (svgm-unxf (if (null pathdata) svgm (run-stanzas pathdata xform svgm))) | |
411 | (svgm-new (xform-svgm svgm-unxf xform)) | |
412 | ) | |
413 | (reduce (lambda (asvgm child) | |
414 | (load-svg-from-xml child asvgm new-xform-stack)) | |
415 | children | |
416 | :initial-value svgm-new) | |
417 | ) | |
418 | svgm)) | |
424 | (let* ((tag (car data)) | |
425 | (attributes (cadr data)) | |
426 | (xform-attr (assoc "transform" attributes :test #'string-equal)) | |
427 | (new-xform-stack (if (null xform-attr) | |
428 | xform-stack | |
429 | (cons (parse-transform (cadr xform-attr)) xform-stack))) | |
430 | (xform (reduce #'clem:mat-mult new-xform-stack | |
431 | :initial-value (clem:identity-matrix 3))) | |
432 | (children (cddr data)) | |
433 | (svgm-unxf (load-unxf-gcode svgm data)) | |
434 | (svgm-new (xform-svgm svgm-unxf xform)) | |
435 | ) | |
436 | (reduce (lambda (asvgm child) | |
437 | (load-svg-from-xml child asvgm new-xform-stack)) | |
438 | children | |
439 | :initial-value svgm-new) | |
440 | ) | |
441 | svgm)) | |
419 | 442 | |
420 | 443 | (defun svg-to-gcode (fname) |
421 | 444 | (let* ((svgtxt (alexandria:read-file-into-string fname)) |