Commit b2a479c76e954e2c309fab6a98c9be89604091f5 - plotter

fix for relative coordinates in multi-stanza statements haldean 4 years ago

2 changed file(s) with 51 addition(s) and 44 deletion(s). Raw diff Collapse all Expand all

-1

~~.#svgcam.lisp~~ less more

willh@hiro.9100:1524679355⏎

+51

-43

svgcam.lisp less more

52	52
53	53	(defstruct (svg-machine (:conc-name svgm-))
54	54	(current '(0 . 0)) ; current position
	55	(rel-base '(0 . 0)) ; the position we base relative moves off of, updated at the end of each stanza
55	56	(last-start nil) ; last path start position
56	57	(last-ctrl-point nil) ; the last control point used in any curve operation, for S paths
57	58	(gcode '())
58	59	)
59
60		(defun pair-to-abs-xy (svgm p) (vec+ p (svgm-current svgm)))
61		(defun pairs-to-abs-xy (svgm mode pairs)
62		(let* ((cur-xy (svgm-current svgm))
63		(cur-x (car cur-xy))
64		(cur-y (cdr cur-xy)))
65		(cons mode (loop for i from 1 to (length pairs)
66		for j in pairs
67		collect (+ j (if (= (mod i 2) 1) cur-x cur-y))
68		))
69		))
70
71		(defun apply-xform (xform p &key (pfunc #'point))
72		(clem-to-list (clem:mat-mult xform (funcall pfunc p))))
73		(defun make-xformer (xform &key (pfunc #'point)) (lambda (p) (apply-xform xform p :pfunc pfunc)))
74		(defun apply-xforms (xform s)
75		(let* ((mode (first s))
76		(args (rest s))
77		(pairs (loop for i from 0 to (- (length args) 1) by 2
78		collect (cons (nth i args) (nth (1+ i) args)))))
79		(cons mode (reduce (lambda (l p) (append l (list (car p) (cdr p))))
80		(mapcar (make-xformer xform) pairs)
81		:initial-value '()))))
82	60
83	61	(defun point-add (a b)
84	62	(point (cons (+ (clem:val a 0 0) (clem:val b 0 0)) (+ (clem:val a 1 0) (clem:val b 1 0)))))

137	115	)
138	116	))))
139	117
	118	(defun splat-pairs (head pairs)
	119	(cond
	120	((consp head) (cons (car head) (splat-pairs (cdr head) pairs)))
	121	((null pairs) (list head))
	122	((null head) (splat-pairs (car pairs) (cdr pairs)))
	123	(t (cons head (splat-pairs (car pairs) (cdr pairs))))))
	124
	125	(defun build-pairs (args)
	126	(loop for i from 0 to (1- (length args)) by 2
	127	collect (cons (nth i args) (nth (1+ i) args))))
	128
	129	(defun pair-to-abs-xy (svgm p) (vec+ p (svgm-current svgm)))
	130	(defun pairs-to-abs-xy (svgm pairs)
	131	(mapcar (lambda (p) (pair-to-abs-xy svgm p)) pairs))
	132
	133	(defun apply-xform (xform p &key (pfunc #'point))
	134	(clem-to-list (clem:mat-mult xform (funcall pfunc p))))
	135	(defun make-xformer (xform &key (pfunc #'point)) (lambda (p) (apply-xform xform p :pfunc pfunc)))
	136	(defun apply-xforms (xform args) (mapcar (make-xformer xform) args))
	137
140	138	(defun to-abs (s xform svgm)
141		(macrolet ((pairs () `(apply-xforms xform (pairs-to-abs-xy svgm (char-upcase (first s)) (rest s)))))
	139	(labels ((from-pairs (mode ps)
	140	(splat-pairs mode (pairs-to-abs-xy svgm (apply-xforms xform ps))))
	141	(auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s))))
	142	)
142	143	(alexandria:switch ((first s))
143		(#\m (pairs))
144		(#\l (pairs))
145		(#\c (pairs))
146		(#\s (pairs))
147		(#\q (pairs))
148		(#\t (pairs))
149		(#\h (apply-xforms xform (pairs-to-abs-xy svgm #\L (list (second s) 0))))
150		(#\v (apply-xforms xform (pairs-to-abs-xy svgm #\L (list 0 (second s)))))
151		(#\H (apply-xforms xform (list #\L (second s) 0)))
152		(#\V (apply-xforms xform (list #\L 0 (second s))))
	144	(#\m (auto-pairs))
	145	(#\l (auto-pairs))
	146	(#\c (auto-pairs))
	147	(#\s (auto-pairs))
	148	(#\q (auto-pairs))
	149	(#\t (auto-pairs))
	150	(#\h (from-pairs #\L (list (cons (second s) 0))))
	151	(#\H (splat-pairs #\L (list (apply-xform xform (cons (second s) 0)))))
	152	(#\v (from-pairs #\L (list (cons 0 (second s)))))
	153	(#\V (splat-pairs #\L (list (apply-xform xform (cons 0 (second s))))))
	154
153	155	(#\a (let* ((args (rest s))
154	156	(xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args)))))
155	157	; send the abs version through to-abs again to be transformed

171	173	(list #\A rx ry 0.0d0 (fourth args) (fifth args) (car xformed-xy) (cdr xformed-xy)))
172	174	)))
173	175	(#\z '(#\Z)) ; z and Z are the same, but we upcase it to make conditionals simpler later
174		(otherwise (apply-xforms xform s))
	176	(otherwise (splat-pairs (first s)
	177	(apply-xforms xform (build-pairs (rest s)))))
175	178	)))
176	179
177	180	(defun gcode-goto (xy &key (mode 1))

193	196	(cur-xy (svgm-current svgm))
194	197	(ls (svgm-last-start svgm))
195	198	(gcode (svgm-gcode svgm))
	199	(rb (svgm-rel-base svgm))
196	200	)
	201	(format t "---~%~A~%~A~%" sraw s)
197	202	(alexandria:switch (mode)
198	203	; path start/end
199	204	(#\M (let ((p (cons (first args) (second args))))
200	205	(make-svg-machine
201		:current p :last-start p
	206	:current p :last-start p :rel-base rb
202	207	:gcode (append gcode (list '((:G . 0) (:Z . 1))
203	208	(gcode-goto p :mode 0)
204	209	'((:G . 0) (:Z . -1))))

207	212	(when (null ls)
208	213	(error "got Z (close path) when there's no current path"))
209	214	(make-svg-machine
210		:current ls :last-start ls
	215	:current ls :last-start ls :rel-base rb
211	216	:gcode (append gcode (list (gcode-goto ls)))
212	217	)))
213	218

215	220	(#\L (let ((p (cons (first args) (second args))))
216	221	(make-svg-machine
217	222	:current p :last-start (if (null ls) cur-xy ls)
218		:gcode (append gcode (list (gcode-goto p)))
	223	:gcode (append gcode (list (gcode-goto p))) :rel-base rb
219	224	)))
220	225
221	226	; cubic beziers

226	231	collect (eval-bezier-cubic theta cur-xy c1 c2 p2)))))
227	232	(make-svg-machine
228	233	:current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
229		:gcode (svgm-gcode svg-poly) :last-ctrl-point c2
	234	:gcode (svgm-gcode svg-poly) :last-ctrl-point c2 :rel-base rb
230	235	)))
231	236	(#\S (let* ((lcp? (svgm-last-ctrl-point svgm))
232	237	(lcp (if (null lcp?) cur-xy lcp?))

240	245	collect (eval-bezier-quadratic theta cur-xy c p2)))))
241	246	(make-svg-machine
242	247	:current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
243		:gcode (svgm-gcode svg-poly) :last-ctrl-point c
	248	:gcode (svgm-gcode svg-poly) :last-ctrl-point c :rel-base rb
244	249	)))
245	250	(#\T (let* ((lcp? (svgm-last-ctrl-point svgm))
246	251	(lcp (if (null lcp?) cur-xy lcp?))

253	258	(let ((xy (cons (sixth args) (seventh args)))
254	259	(ij (vec- center-xy cur-xy)))
255	260	(make-svg-machine
256		:current xy :last-start ls
	261	:current xy :last-start ls :rel-base rb
257	262	:gcode (append gcode (list (list (cons :G (if cw? 2 3))
258	263	(cons :I (car ij))
259	264	(cons :J (cdr ij))
260	265	(cons :X (car xy))
261	266	(cons :Y (cdr xy)))))
262	267	))))
	268
	269	; rel-base update
	270	(:end-stanza (make-svg-machine :current cur-xy :last-start ls :rel-base cur-xy :gcode gcode))
263	271
264	272	(otherwise (error "unsupported mode ~A" mode))
265	273	)))

295	303	(when (> (length a) 0)
296	304	(cons (cons (if is-first mode mode2) (subseq a 0 target-len))
297	305	(split (subseq a target-len) nil)))))
298		(split args t)
	306	(append (split args t) '((:end-stanza)))
299	307	)))))
300	308
301	309	(defun load-path-args (stz)

339	347	(defun svg-to-gcode (fname)
340	348	(let* ((svgtxt (alexandria:read-file-into-string fname))
341	349	(svgdata (xmls:parse svgtxt)))
342		(svgm-gcode (load-svg-from-xml svgdata (make-svg-machine) nil))))
	350	(svgm-emit-gcode (load-svg-from-xml svgdata (make-svg-machine) nil))))
343	351
344	352	(defun svgm-emit-gcode (svgm)
345	353	(labels ((gcode-number (n) (if (< (abs (- (round n) n)) 0.001)