git.haldean.org plotter / b2a479c
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
+0
-1
.#svgcam.lisp less more
0 willh@hiro.9100:1524679355
5252
5353 (defstruct (svg-machine (:conc-name svgm-))
5454 (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
5556 (last-start nil) ; last path start position
5657 (last-ctrl-point nil) ; the last control point used in any curve operation, for S paths
5758 (gcode '())
5859 )
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 '()))))
8260
8361 (defun point-add (a b)
8462 (point (cons (+ (clem:val a 0 0) (clem:val b 0 0)) (+ (clem:val a 1 0) (clem:val b 1 0)))))
137115 )
138116 ))))
139117
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
140138 (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 )
142143 (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
153155 (#\a (let* ((args (rest s))
154156 (xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args)))))
155157 ; send the abs version through to-abs again to be transformed
171173 (list #\A rx ry 0.0d0 (fourth args) (fifth args) (car xformed-xy) (cdr xformed-xy)))
172174 )))
173175 (#\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)))))
175178 )))
176179
177180 (defun gcode-goto (xy &key (mode 1))
193196 (cur-xy (svgm-current svgm))
194197 (ls (svgm-last-start svgm))
195198 (gcode (svgm-gcode svgm))
199 (rb (svgm-rel-base svgm))
196200 )
201 (format t "---~%~A~%~A~%" sraw s)
197202 (alexandria:switch (mode)
198203 ; path start/end
199204 (#\M (let ((p (cons (first args) (second args))))
200205 (make-svg-machine
201 :current p :last-start p
206 :current p :last-start p :rel-base rb
202207 :gcode (append gcode (list '((:G . 0) (:Z . 1))
203208 (gcode-goto p :mode 0)
204209 '((:G . 0) (:Z . -1))))
207212 (when (null ls)
208213 (error "got Z (close path) when there's no current path"))
209214 (make-svg-machine
210 :current ls :last-start ls
215 :current ls :last-start ls :rel-base rb
211216 :gcode (append gcode (list (gcode-goto ls)))
212217 )))
213218
215220 (#\L (let ((p (cons (first args) (second args))))
216221 (make-svg-machine
217222 :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
219224 )))
220225
221226 ; cubic beziers
226231 collect (eval-bezier-cubic theta cur-xy c1 c2 p2)))))
227232 (make-svg-machine
228233 :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
230235 )))
231236 (#\S (let* ((lcp? (svgm-last-ctrl-point svgm))
232237 (lcp (if (null lcp?) cur-xy lcp?))
240245 collect (eval-bezier-quadratic theta cur-xy c p2)))))
241246 (make-svg-machine
242247 :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
244249 )))
245250 (#\T (let* ((lcp? (svgm-last-ctrl-point svgm))
246251 (lcp (if (null lcp?) cur-xy lcp?))
253258 (let ((xy (cons (sixth args) (seventh args)))
254259 (ij (vec- center-xy cur-xy)))
255260 (make-svg-machine
256 :current xy :last-start ls
261 :current xy :last-start ls :rel-base rb
257262 :gcode (append gcode (list (list (cons :G (if cw? 2 3))
258263 (cons :I (car ij))
259264 (cons :J (cdr ij))
260265 (cons :X (car xy))
261266 (cons :Y (cdr xy)))))
262267 ))))
268
269 ; rel-base update
270 (:end-stanza (make-svg-machine :current cur-xy :last-start ls :rel-base cur-xy :gcode gcode))
263271
264272 (otherwise (error "unsupported mode ~A" mode))
265273 )))
295303 (when (> (length a) 0)
296304 (cons (cons (if is-first mode mode2) (subseq a 0 target-len))
297305 (split (subseq a target-len) nil)))))
298 (split args t)
306 (append (split args t) '((:end-stanza)))
299307 )))))
300308
301309 (defun load-path-args (stz)
339347 (defun svg-to-gcode (fname)
340348 (let* ((svgtxt (alexandria:read-file-into-string fname))
341349 (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))))
343351
344352 (defun svgm-emit-gcode (svgm)
345353 (labels ((gcode-number (n) (if (< (abs (- (round n) n)) 0.001)