git.haldean.org plotter / d9f3e13
lots of work around ellipses, reliability Haldean Brown 3 years ago
4 changed file(s) with 165 addition(s) and 79 deletion(s). Raw diff Collapse all Expand all
+1
-0
bezier.lisp less more
77 (defun vec+ (v1 v2) (cons (+ (car v1) (car v2)) (+ (cdr v1) (cdr v2))))
88 (defun vec- (v1 v2) (cons (- (car v1) (car v2)) (- (cdr v1) (cdr v2))))
99 (defun vec* (s v) (cons (* s (car v)) (* s (cdr v))))
10 (defun vec= (v1 v2) (and (= (car v1) (car v2)) (= (cdr v1) (cdr v2))))
1011 (defun dot (v1 v2) (+ (* (car v1) (car v2)) (* (cdr v1) (cdr v2))))
1112 (defun norm (v) (sqrt (dot v v)))
1213 (defun normalize (v) (vec* (/ 1 (norm v)) v))
+3
-2
cnc.lisp less more
1717 ; these are the states that cncserver recognizes
1818 (setq *pen-states* '("up" "draw"))
1919
20 (defun api-url (e) (format nil "http://saito:4242/~a" e))
20 (defparameter *cnc-host* "192.168.1.129")
21 (defun api-url (e) (format nil "http://~a:4242/~a" *cnc-host* e))
2122
2223 (defun extract (d v) (cdr (assoc v d :test #'equal)))
2324
108109 (dummy-file nil)
109110 )
110111
111 (defun x-from-gcode (x-mm) (- 100 (rel-x (* x-mm *steps-per-mm*))))
112 (defun x-from-gcode (x-mm) (rel-x (* x-mm *steps-per-mm*)))
112113 (defun y-from-gcode (y-mm) (rel-y (* y-mm *steps-per-mm*)))
113114
114115 (defun theta-steps-ccw (start end)
+104
-53
svgcam.lisp less more
4141 ))
4242 (defun make-skew-x (a) (reshape-to-2x3 (list 1 (tan a) 0 0 1 0)))
4343 (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)))
4446
4547 (defun parse-transform (xform-str)
4648 (cl-ppcre:register-groups-bind (fun argstr) ("([a-zA-Z]+)\\(([^)]*)\\)" xform-str)
8789 (x-prime (clem:val xy1-prime 0 0))
8890 (y-prime (clem:val xy1-prime 1 0))
8991 (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 )))))
126130
127131 (defun splat-pairs (head pairs)
128132 (cond
188192 )))
189193 lines))
190194
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
191205 (defun to-abs (s svgm)
192206 (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))))
194208 (auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s))))
195209 )
196210 (alexandria:switch ((first s))
201215 (#\q (auto-pairs))
202216 (#\t (auto-pairs))
203217 (#\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)))))
205219 (#\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))))
207221
208222 (#\a (let* ((args (rest s))
209223 (xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args)))))
219233 ; if it's not a perfect circle, we convert it to lines. Ellipses aren't
220234 ; supported by G-Code, so instead of trying to bake the xform into a special
221235 ; format to pass on, we just interpolate
222 (error "ellipses not supported yet")
236 (interpolate-ellipse args svgm)
223237 ; otherwise we leave it as a circle so we can use the G-Code arc commands
224238 ; 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))
226240 )))
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))
229244 )))
230245
231246 (defun gcode-goto (xy &key (mode 1))
291306
292307 ; quadratic beziers
293308 (#\Q (let* ((c (cons (first args) (second args)))
294 (p2 (cons (fifth args) (sixth args)))
309 (p2 (cons (third args) (fourth args)))
295310 (svg-poly (push-polyline svgm (loop for theta in (linspace 0 1 0.05)
296311 collect (eval-bezier-quadratic theta cur-xy c p2)))))
297312 (make-svg-machine
327342 )))
328343
329344 (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))
331350
332351 (defun normalize-stanza (s)
333352 "Takes a stanza of the form (MODE ARG0 ARG1 ARG2 ... ARGN) and returns a list of stanzas
417436 (normalize-stanza (cons #\L (cddr points))))
418437 svgm)
419438 ))
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 ))
420462
421463 (defun load-unxf-gcode (svgm data)
422464 (funcall (alexandria:switch ((caar data) :test #'string-equal)
423465 ("path" #'load-unxf-path)
424466 ("line" #'load-unxf-line)
425467 ("circle" #'load-unxf-circle)
468 ("ellipse" #'load-unxf-ellipse)
426469 ("polygon" #'load-unxf-polygon)
470 ("rect" #'load-unxf-rect)
427471 (otherwise (lambda (svgm &rest _) svgm))
428472 )
429473 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)
430480
431481 (defun load-svg-from-xml (data svgm xform-stack)
432482 (if (listp data)
436486 (new-xform-stack (if (null xform-attr)
437487 xform-stack
438488 (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)
440490 :initial-value (clem:identity-matrix 3)))
441491 (children (cddr data))
442492 (svgm-unxf (load-unxf-gcode svgm data))
449499 )
450500 svgm))
451501
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)
458509 (labels ((gcode-number (n) (if (< (abs (- (round n) n)) 0.001)
459510 (format nil "~D" (round n))
460511 (format nil "~,2F" n)))
461512 (emit-assignment (reg) (format nil "~A~A" (car reg) (gcode-number (cdr reg))))
462513 (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)))))
+57
-24
tri.lisp less more
33
44 (ql:quickload :alexandria)
55
6 (defun choose-edge-hlen () (+ 10.0 (- (random 19.8) 9.9)))
6 (defconstant m 11)
7 (defconstant n 4)
8 (defconstant tspace 25)
9 (defconstant tcenter 5.0)
10 (defconstant tspread 3.5)
11 (defconstant tdiffmin 0.25)
12
13 (defun choose-edge-hlen (existing)
14 (let ((new-len (+ tcenter (- (random (* 2.0 tspread)) tspread))))
15 (if (< (abs (- existing new-len)) tdiffmin)
16 (choose-edge-hlen existing)
17 new-len)))
18
719 (defun base-len (edge-hlen) (* (tan (* pi (/ 60 180))) edge-hlen))
820 (defun random-ortho (v)
921 "randomly pick and return one of the two unit vectors orthogonal to the given unit vector"
1224 (cons (- (cdr v)) (car v))
1325 ))
1426
27 (defun random-signed (v)
28 (* (random v) (if (= 0 (random 2)) -1 1)))
29
30 (defun pick-base (hlen seed)
31 (let* ((seed-hlen (* 0.5 (norm (vec- (first seed) (second seed)))))
32 (slop (abs (- seed-hlen hlen)))
33 (offset (if (< slop 0) 0 (random-signed (float slop))))
34 (d (normalize (vec- (second seed) (first seed))))
35 (c (vec* 0.5 (vec+ (second seed) (first seed))))
36 )
37 (vec+ c (vec* offset d))
38 ))
39
1540 (defstruct state polys edges)
1641
1742 (defun add-tri (s p1 p2 p3)
1944 :edges (list* (list p1 p2) (list p2 p3) (list p3 p1) (state-edges s))))
2045
2146 (defun new-tri (s)
22 (let* ((seed (alexandria:random-elt (state-edges s)))
23 (edge-hlen (choose-edge-hlen))
24 (center (vec* 0.5 (vec+ (first seed) (second seed))))
25 (v (normalize (vec- (second seed) (first seed))))
26 (p1 (vec- center (vec* edge-hlen v)))
27 (p2 (vec+ center (vec* edge-hlen v)))
28 (p3 (vec+ center (vec* (base-len edge-hlen) (random-ortho v))))
29 )
30 (add-tri s p1 p2 p3)))
47 (if (null s)
48 (add-tri (make-state)
49 (cons (/ tcenter 2.0) 0)
50 (cons (/ tcenter -2.0) 0)
51 (cons 0 (- (base-len (/ tcenter 2.0)))))
52 (let* ((seed (alexandria:random-elt (state-edges s)))
53 (edge-hlen (choose-edge-hlen (* 0.5 (norm (vec- (first seed) (second seed))))))
54 (center (pick-base edge-hlen seed))
55 (v (normalize (vec- (second seed) (first seed))))
56 (p1 (vec- center (vec* edge-hlen v)))
57 (p2 (vec+ center (vec* edge-hlen v)))
58 (p3 (vec+ center (vec* (base-len edge-hlen) (random-ortho v))))
59 )
60 (add-tri s p1 p2 p3))))
3161
32 (defun base-state (origin)
33 (add-tri (make-state)
34 (vec- origin '(10 . 0))
35 (vec+ origin '(10 . 0))
36 (vec+ origin (cons 0 (base-len 10)))))
62 (defun translate-polys (v polys)
63 (mapcar (lambda (p) (mapcar (lambda (x) (vec+ x v)) p)) polys))
3764
38 (defun make-tris (origin)
65 (defun make-tris ()
3966 (reduce
4067 (lambda (s ig) (new-tri s))
4168 (loop for i from 0 to (+ 1 (random 4)) collect i)
42 :initial-value (base-state origin)
69 :initial-value (base-state)
4370 ))
4471
72 (defun space-fill-z (z) (cons (mod z n) (floor (/ z n))))
73
4574 (defun make-clusters ()
46 (reduce (lambda (polys ij)
47 (append polys
48 (state-polys (make-tris (cons (* 70 (1+ (car ij))) (* 70 (1+ (cdr ij))))))))
49 (gathering (loop for i from 0 to 4
50 do (loop for j from 0 to 4
51 do (gather (cons i j)))))
52 :initial-value nil))
75 (cdr (reduce (lambda (state-poly-pair z)
76 (let* ((old-state (car state-poly-pair))
77 (old-polys (cdr state-poly-pair))
78 (new-state (new-tri old-state))
79 (ij (space-fill-z z))
80 (Tij (cons (* tspace (1+ (car ij))) (* tspace (1+ (cdr ij)))))
81 (new-polys (translate-polys Tij (state-polys new-state)))
82 )
83 (cons new-state (append new-polys old-polys))))
84 (loop for z from 0 to (1- (* m n)) collect z)
85 :initial-value nil)))
5386
5487 (defun tri-x.svg() (x.svg (make-clusters)))