git.haldean.org plotter / f2f54ca
adds support for <circle> and <line> Haldean Brown 4 years ago
1 changed file(s) with 54 addition(s) and 31 deletion(s). Raw diff Collapse all Expand all
+54
-31
svgcam.lisp less more
230230 (list (cons :G mode) (cons :X (car xy)) (cons :Y (cdr xy))))
231231
232232 (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))))
234234 pts :initial-value svgm))
235235
236236 (defun linspace (a b step)
238238 (s (/ (- b a) steps)))
239239 (loop for i from 0 to steps collect (+ a (* s i)))))
240240
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."
243243 (let* ((mode (first s))
244244 (args (rest s))
245245 (cur-xy (svgm-current svgm))
285285 (#\S (let* ((lcp? (svgm-last-ctrl-point svgm))
286286 (lcp (if (null lcp?) cur-xy lcp?))
287287 (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))))
289289
290290 ; quadratic beziers
291291 (#\Q (let* ((c (cons (first args) (second args)))
300300 (#\T (let* ((lcp? (svgm-last-ctrl-point svgm))
301301 (lcp (if (null lcp?) cur-xy lcp?))
302302 (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))))
304304
305305 ; arcs
306306 (#\A
324324 (otherwise (error "unsupported mode ~A" mode))
325325 )))
326326
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))
333329
334330 (defun normalize-stanza (s)
335331 "Takes a stanza of the form (MODE ARG0 ARG1 ARG2 ... ARGN) and returns a list of stanzas
394390 'gcode (append (svgm-gcode svgm)
395391 (xform-gcode xform (svgm-gcode-unxf svgm)))))
396392
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
397422 (defun load-svg-from-xml (data svgm xform-stack)
398423 (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))
419442
420443 (defun svg-to-gcode (fname)
421444 (let* ((svgtxt (alexandria:read-file-into-string fname))