41 | 41 |
))
|
42 | 42 |
(defun make-skew-x (a) (reshape-to-2x3 (list 1 (tan a) 0 0 1 0)))
|
43 | 43 |
(defun make-skew-y (a) (reshape-to-2x3 (list 1 0 0 (tan a) 1 0)))
|
|
44 |
|
|
45 |
(defconstant point-to-mm-xform (make-scale (/ 25.4 72)))
|
44 | 46 |
|
45 | 47 |
(defun parse-transform (xform-str)
|
46 | 48 |
(cl-ppcre:register-groups-bind (fun argstr) ("([a-zA-Z]+)\\(([^)]*)\\)" xform-str)
|
|
87 | 89 |
(x-prime (clem:val xy1-prime 0 0))
|
88 | 90 |
(y-prime (clem:val xy1-prime 1 0))
|
89 | 91 |
(Lambda (+ (/ (expt x-prime 2) rx2) (/ (expt y-prime 2) ry2))))
|
90 | |
(if (> Lambda 1.0d0)
|
91 | |
(let ((scale (+ (sqrt Lambda) 0.0001)))
|
92 | |
(when (> scale 2)
|
93 | |
(error "poorly formed arc, maybe? ~A ~A" a xy1p))
|
94 | |
(arc-center-xy (append (list (* scale rx) (* scale ry)) (subseq a 2)) xy1p))
|
95 | |
(let* ((cxy-rc (* (if (equal large-arc? cw?) -1.0 1.0)
|
96 | |
(sqrt (/ (- (* rx2 ry2) (* rx2 (expt y-prime 2)) (* ry2 (expt x-prime 2)))
|
97 | |
(+ (* rx2 (expt y-prime 2)) (* ry2 (expt x-prime 2)))))))
|
98 | |
(cxy-r (if (complexp cxy-rc) (break) cxy-rc))
|
99 | |
(cxy-prime (point (cons (/ (* cxy-r rx y-prime) ry)
|
100 | |
(/ (* -1 cxy-r ry x-prime) rx))))
|
101 | |
(cxy (point-add
|
102 | |
(clem:mat-mult (clem:transpose rphi) cxy-prime)
|
103 | |
(point-scale (clem:mat-add xy1 xy2) 0.5)))
|
104 | |
(cx-prime (clem:val cxy-prime 0 0))
|
105 | |
(cy-prime (clem:val cxy-prime 1 0))
|
106 | |
(theta1 (angle-between
|
107 | |
'(1 . 0)
|
108 | |
(cons (/ (- x-prime cx-prime) rx)
|
109 | |
(/ (- y-prime cy-prime) ry))))
|
110 | |
(dtheta-unwhitened (angle-between
|
111 | |
(cons (/ (- x-prime cx-prime) rx)
|
112 | |
(/ (- y-prime cy-prime) ry))
|
113 | |
(cons (/ (- 0 x-prime cx-prime) rx)
|
114 | |
(/ (- 0 y-prime cy-prime) ry))))
|
115 | |
(dtheta (cond
|
116 | |
((and cw? (> dtheta-unwhitened 0)) (- dtheta-unwhitened tau))
|
117 | |
((and (not cw?) (< dtheta-unwhitened 0)) (+ dtheta-unwhitened tau))
|
118 | |
(t dtheta-unwhitened)))
|
119 | |
)
|
120 | |
(values (cons (clem:val cxy 0 0) (clem:val cxy 1 0))
|
121 | |
cw?
|
122 | |
theta1
|
123 | |
dtheta
|
124 | |
)
|
125 | |
))))
|
|
92 |
(cond
|
|
93 |
((and (= x-prime 0) (= y-prime 0)) (error "arcs cannot start and end at same point"))
|
|
94 |
((> Lambda 1.0d0)
|
|
95 |
(let ((scale (+ (sqrt Lambda) 0.0001)))
|
|
96 |
(when (> scale 2)
|
|
97 |
(error "poorly formed arc, maybe? ~A ~A ~A" a xy1p scale))
|
|
98 |
(arc-center-xy (append (list (* scale rx) (* scale ry)) (subseq a 2)) xy1p)))
|
|
99 |
(t (let* ((cxy-rc (* (if (equal large-arc? cw?) -1.0 1.0)
|
|
100 |
(sqrt (/ (- (* rx2 ry2) (* rx2 (expt y-prime 2)) (* ry2 (expt x-prime 2)))
|
|
101 |
(+ (* rx2 (expt y-prime 2)) (* ry2 (expt x-prime 2)))))))
|
|
102 |
(cxy-r (if (complexp cxy-rc) (break) cxy-rc))
|
|
103 |
(cxy-prime (point (cons (/ (* cxy-r rx y-prime) ry)
|
|
104 |
(/ (* -1 cxy-r ry x-prime) rx))))
|
|
105 |
(cxy (point-add
|
|
106 |
(clem:mat-mult (clem:transpose rphi) cxy-prime)
|
|
107 |
(point-scale (clem:mat-add xy1 xy2) 0.5)))
|
|
108 |
(cx-prime (clem:val cxy-prime 0 0))
|
|
109 |
(cy-prime (clem:val cxy-prime 1 0))
|
|
110 |
(theta1 (angle-between
|
|
111 |
'(1 . 0)
|
|
112 |
(cons (/ (- x-prime cx-prime) rx)
|
|
113 |
(/ (- y-prime cy-prime) ry))))
|
|
114 |
(dtheta-unwhitened (angle-between
|
|
115 |
(cons (/ (- x-prime cx-prime) rx)
|
|
116 |
(/ (- y-prime cy-prime) ry))
|
|
117 |
(cons (/ (- 0 x-prime cx-prime) rx)
|
|
118 |
(/ (- 0 y-prime cy-prime) ry))))
|
|
119 |
(dtheta (cond
|
|
120 |
((and cw? (> dtheta-unwhitened 0)) (- dtheta-unwhitened tau))
|
|
121 |
((and (not cw?) (< dtheta-unwhitened 0)) (+ dtheta-unwhitened tau))
|
|
122 |
(t dtheta-unwhitened)))
|
|
123 |
)
|
|
124 |
(values (cons (clem:val cxy 0 0) (clem:val cxy 1 0))
|
|
125 |
cw?
|
|
126 |
theta1
|
|
127 |
dtheta
|
|
128 |
)
|
|
129 |
)))))
|
126 | 130 |
|
127 | 131 |
(defun splat-pairs (head pairs)
|
128 | 132 |
(cond
|
|
188 | 192 |
)))
|
189 | 193 |
lines))
|
190 | 194 |
|
|
195 |
(defun interpolate-ellipse (arc-args svgm)
|
|
196 |
(labels
|
|
197 |
((eval-ellipse (theta rx ry) (cons (* rx (cos theta)) (* ry (sin theta)))))
|
|
198 |
(multiple-value-bind (cxy cw? theta1 dtheta) (arc-center-xy arc-args (svgm-current svgm))
|
|
199 |
(loop for theta in (linspace theta1 (+ theta1 dtheta) (/ tau 60))
|
|
200 |
collect
|
|
201 |
(let ((xy (vec+ (eval-ellipse theta (first arc-args) (second arc-args)) cxy)))
|
|
202 |
(list #\L (car xy) (cdr xy))))
|
|
203 |
)))
|
|
204 |
|
191 | 205 |
(defun to-abs (s svgm)
|
192 | 206 |
(labels ((from-pairs (mode ps)
|
193 | |
(splat-pairs mode (pairs-to-abs-xy svgm ps)))
|
|
207 |
(list (splat-pairs mode (pairs-to-abs-xy svgm ps))))
|
194 | 208 |
(auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s))))
|
195 | 209 |
)
|
196 | 210 |
(alexandria:switch ((first s))
|
|
201 | 215 |
(#\q (auto-pairs))
|
202 | 216 |
(#\t (auto-pairs))
|
203 | 217 |
(#\h (from-pairs #\L (list (cons (second s) 0))))
|
204 | |
(#\H (list #\L (second s) (cdr (svgm-current svgm))))
|
|
218 |
(#\H (list (list #\L (second s) (cdr (svgm-current svgm)))))
|
205 | 219 |
(#\v (from-pairs #\L (list (cons 0 (second s)))))
|
206 | |
(#\V (list #\L (car (svgm-current svgm)) (second s)))
|
|
220 |
(#\V (list (list #\L (car (svgm-current svgm)) (second s))))
|
207 | 221 |
|
208 | 222 |
(#\a (let* ((args (rest s))
|
209 | 223 |
(xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args)))))
|
|
219 | 233 |
; if it's not a perfect circle, we convert it to lines. Ellipses aren't
|
220 | 234 |
; supported by G-Code, so instead of trying to bake the xform into a special
|
221 | 235 |
; format to pass on, we just interpolate
|
222 | |
(error "ellipses not supported yet")
|
|
236 |
(interpolate-ellipse args svgm)
|
223 | 237 |
; otherwise we leave it as a circle so we can use the G-Code arc commands
|
224 | 238 |
; Since it's a circle, we can set phi to zero (because there is no major/minor axis)
|
225 | |
(list #\A rx ry 0.0d0 (fourth args) (fifth args) x y)
|
|
239 |
(list (list #\A rx ry 0.0d0 (fourth args) (fifth args) x y))
|
226 | 240 |
)))
|
227 | |
(#\z '(#\Z)) ; z and Z are the same, but we upcase it to make conditionals simpler later
|
228 | |
(otherwise s)
|
|
241 |
|
|
242 |
(#\z '((#\Z))) ; z and Z are the same, but we upcase it to make conditionals simpler later
|
|
243 |
(otherwise (list s))
|
229 | 244 |
)))
|
230 | 245 |
|
231 | 246 |
(defun gcode-goto (xy &key (mode 1))
|
|
291 | 306 |
|
292 | 307 |
; quadratic beziers
|
293 | 308 |
(#\Q (let* ((c (cons (first args) (second args)))
|
294 | |
(p2 (cons (fifth args) (sixth args)))
|
|
309 |
(p2 (cons (third args) (fourth args)))
|
295 | 310 |
(svg-poly (push-polyline svgm (loop for theta in (linspace 0 1 0.05)
|
296 | 311 |
collect (eval-bezier-quadratic theta cur-xy c p2)))))
|
297 | 312 |
(make-svg-machine
|
|
327 | 342 |
)))
|
328 | 343 |
|
329 | 344 |
(defun run-stanzas (stanzas svgm)
|
330 | |
(reduce (lambda (svgm s) (push-stanza svgm (to-abs s svgm))) stanzas :initial-value svgm))
|
|
345 |
(reduce
|
|
346 |
(lambda (isvgm s) (reduce (lambda (insvgm sabs) (push-stanza insvgm sabs))
|
|
347 |
(to-abs s isvgm)
|
|
348 |
:initial-value isvgm))
|
|
349 |
stanzas :initial-value svgm))
|
331 | 350 |
|
332 | 351 |
(defun normalize-stanza (s)
|
333 | 352 |
"Takes a stanza of the form (MODE ARG0 ARG1 ARG2 ... ARGN) and returns a list of stanzas
|
|
417 | 436 |
(normalize-stanza (cons #\L (cddr points))))
|
418 | 437 |
svgm)
|
419 | 438 |
))
|
|
439 |
(defun load-unxf-rect (svgm d)
|
|
440 |
(let ((x (a "x" d))
|
|
441 |
(y (a "y" d))
|
|
442 |
(w (a "width" d))
|
|
443 |
(h (a "height" d)))
|
|
444 |
(run-stanzas (list (list #\M x y)
|
|
445 |
(list #\l w 0)
|
|
446 |
(list #\l 0 h)
|
|
447 |
(list #\l (- w) 0)
|
|
448 |
'(#\Z))
|
|
449 |
svgm)))
|
|
450 |
(defun load-unxf-ellipse (svgm d)
|
|
451 |
(let* ((rx (a "rx" d))
|
|
452 |
(ry (a "ry" d))
|
|
453 |
(sx (+ (a "cx" d) rx))
|
|
454 |
(mx (- (a "cx" d) rx))
|
|
455 |
(sy (a "cy" d)))
|
|
456 |
(run-stanzas (list (list #\M sx sy)
|
|
457 |
(list #\A rx ry 0 0 0 mx sy)
|
|
458 |
(list #\A rx ry 0 0 0 sx sy)
|
|
459 |
)
|
|
460 |
svgm)
|
|
461 |
))
|
420 | 462 |
|
421 | 463 |
(defun load-unxf-gcode (svgm data)
|
422 | 464 |
(funcall (alexandria:switch ((caar data) :test #'string-equal)
|
423 | 465 |
("path" #'load-unxf-path)
|
424 | 466 |
("line" #'load-unxf-line)
|
425 | 467 |
("circle" #'load-unxf-circle)
|
|
468 |
("ellipse" #'load-unxf-ellipse)
|
426 | 469 |
("polygon" #'load-unxf-polygon)
|
|
470 |
("rect" #'load-unxf-rect)
|
427 | 471 |
(otherwise (lambda (svgm &rest _) svgm))
|
428 | 472 |
)
|
429 | 473 |
svgm data))
|
|
474 |
|
|
475 |
(defun print-xform-stack (xforms)
|
|
476 |
(format t "[~%")
|
|
477 |
(mapcar (lambda (x) (clem:print-matrix x) (format t "~%")) xforms)
|
|
478 |
(format t "]~%")
|
|
479 |
xforms)
|
430 | 480 |
|
431 | 481 |
(defun load-svg-from-xml (data svgm xform-stack)
|
432 | 482 |
(if (listp data)
|
|
436 | 486 |
(new-xform-stack (if (null xform-attr)
|
437 | 487 |
xform-stack
|
438 | 488 |
(cons (parse-transform (cadr xform-attr)) xform-stack)))
|
439 | |
(xform (reduce #'clem:mat-mult new-xform-stack
|
|
489 |
(xform (reduce #'clem:mat-mult (reverse new-xform-stack)
|
440 | 490 |
:initial-value (clem:identity-matrix 3)))
|
441 | 491 |
(children (cddr data))
|
442 | 492 |
(svgm-unxf (load-unxf-gcode svgm data))
|
|
449 | 499 |
)
|
450 | 500 |
svgm))
|
451 | 501 |
|
452 | |
(defun svg-to-gcode (fname)
|
453 | |
(let* ((svgtxt (alexandria:read-file-into-string fname))
|
454 | |
(svgdata (xmls:parse svgtxt)))
|
455 | |
(svgm-emit-gcode (load-svg-from-xml svgdata (make-svg-machine) nil))))
|
456 | |
|
457 | |
(defun svgm-emit-gcode (svgm)
|
|
502 |
(defun svg-to-gcode (fname gcode-out)
|
|
503 |
(with-open-file (outf gcode-out :direction :output :if-exists :supersede)
|
|
504 |
(let* ((svgtxt (alexandria:read-file-into-string fname))
|
|
505 |
(svgdata (xmls:parse svgtxt)))
|
|
506 |
(svgm-emit-gcode outf (load-svg-from-xml svgdata (make-svg-machine) (list point-to-mm-xform))))))
|
|
507 |
|
|
508 |
(defun svgm-emit-gcode (outstream svgm)
|
458 | 509 |
(labels ((gcode-number (n) (if (< (abs (- (round n) n)) 0.001)
|
459 | 510 |
(format nil "~D" (round n))
|
460 | 511 |
(format nil "~,2F" n)))
|
461 | 512 |
(emit-assignment (reg) (format nil "~A~A" (car reg) (gcode-number (cdr reg))))
|
462 | 513 |
(emit-line (line) (format nil "~{~A~^ ~}" (mapcar #'emit-assignment line))))
|
463 | |
(format nil "~{~A~^~%~}" (mapcar #'emit-line (append (svgm-gcode svgm) gcode-postamble)))))
|
|
514 |
(format outstream "~{~A~^~%~}" (mapcar #'emit-line (append (svgm-gcode svgm) gcode-postamble)))))
|