git.haldean.org plotter / 4324e3a
paths working! Haldean Brown 4 years ago
1 changed file(s) with 98 addition(s) and 31 deletion(s). Raw diff Collapse all Expand all
+98
-31
svgcam.lisp less more
5959 (rel-base '(0 . 0)) ; the position we base relative moves off of, updated at the end of each stanza
6060 (last-start nil) ; last path start position
6161 (last-ctrl-point nil) ; the last control point used in any curve operation, for S paths
62 (gcode gcode-preamble)
62 (gcode gcode-preamble) ; transformed, complete gcode
63 (gcode-unxf nil) ; untransformed gcode that is being generated
6364 )
6465
6566 (defun point-add (a b)
7071 (defun arc-center-xy (a xy1p)
7172 "Finds and returns (cx, cy), is-clockwise, theta1, theta2 - theta1, in that
7273 order, as specified by the SVG arc implementation notes"
73 (print a)
74 (print xy1p)
7574 (let* ((rx (abs (first a)))
7675 (ry (abs (second a)))
7776 (rx2 (expt rx 2))
8887 (Lambda (+ (/ (expt x-prime 2) rx2) (/ (expt y-prime 2) ry2))))
8988 (if (> Lambda 1.0d0)
9089 (let ((scale (+ (sqrt Lambda) 0.0001)))
90 (when (> scale 2)
91 (error "poorly formed arc, maybe? ~A ~A" a xy1p))
9192 (arc-center-xy (append (list (* scale rx) (* scale ry)) (subseq a 2)) xy1p))
9293 (let* ((cxy-rc (* (if (equal large-arc? cw?) -1.0 1.0)
9394 (sqrt (/ (- (* rx2 ry2) (* rx2 (expt y-prime 2)) (* ry2 (expt x-prime 2)))
138139
139140 (defun apply-xform (xform p &key (pfunc #'point))
140141 (clem-to-list (clem:mat-mult xform (funcall pfunc p))))
141 (defun make-xformer (xform &key (pfunc #'point)) (lambda (p) (apply-xform xform p :pfunc pfunc)))
142 (defun apply-xforms (xform args &key (pfunc #'point)) (mapcar (make-xformer xform :pfunc pfunc) args))
143
144 (defun to-abs (s xform svgm)
142
143 (defun update-assoc (alist &rest update)
144 (labels
145 ((update-assoc-1 (alist k v)
146 (cond
147 ((null alist) (cons (cons k v) nil))
148 ((eq (caar alist) k) (cons (cons k v) (cdr alist)))
149 (t (cons (car alist) (update-assoc-1 (cdr alist) k v)))
150 )))
151 (reduce (lambda (al up) (update-assoc-1 al (car up) (cdr up)))
152 update :initial-value alist)))
153
154 (defun xform-gcode-xy (xform line)
155 (let ((x (cdr (assoc :X line)))
156 (y (cdr (assoc :Y line))))
157 (cond
158 ((and (null x) (null y)) line)
159 ((or (null x) (null y)) (error "must specify either both x and y or neither, got " line))
160 (t (let ((xformed (apply-xform xform (cons x y))))
161 (update-assoc line (cons :X (car xformed)) (cons :Y (cdr xformed))))))))
162
163 (defun xform-gcode-arc (xform line)
164 (let ((x (cdr (assoc :X line)))
165 (y (cdr (assoc :Y line)))
166 (i (cdr (assoc :I line)))
167 (j (cdr (assoc :J line))))
168 (let ((xfxy (apply-xform xform (cons x y)))
169 (xfij (apply-xform xform (cons i j) :pfunc #'vec)))
170 (update-assoc line
171 (cons :X (car xfxy))
172 (cons :Y (cdr xfxy))
173 (cons :I (car xfij))
174 (cons :J (cdr xfij))
175 ))))
176
177 (defun xform-gcode (xform lines)
178 (mapcar (lambda (line)
179 (let ((mode (cdr (assoc :G line))))
180 (alexandria:switch (mode)
181 (0 (xform-gcode-xy xform line))
182 (1 (xform-gcode-xy xform line))
183 (2 (xform-gcode-arc xform line))
184 (3 (xform-gcode-arc xform line))
185 (otherwise line)
186 )))
187 lines))
188
189 (defun to-abs (s svgm)
145190 (labels ((from-pairs (mode ps)
146191 (splat-pairs mode (pairs-to-abs-xy svgm ps)))
147192 (auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s))))
154199 (#\q (auto-pairs))
155200 (#\t (auto-pairs))
156201 (#\h (from-pairs #\L (list (cons (second s) 0))))
157 (#\H (splat-pairs #\L (list (vec+ (svgm-current svgm) (cons (second s) 0)))))
202 (#\H (list #\L (second s) (cdr (svgm-current svgm))))
158203 (#\v (from-pairs #\L (list (cons 0 (second s)))))
159 (#\V (splat-pairs #\L (list (vec+ (svgm-current svgm) (cons 0 (second s))))))
204 (#\V (list #\L (car (svgm-current svgm)) (second s)))
160205
161206 (#\a (let* ((args (rest s))
162207 (xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args)))))
163208 ; send the abs version through to-abs again to be transformed
164 (to-abs (append '(#\A) (subseq s 1 6) (list (car xy) (cdr xy))) xform svgm)))
209 (to-abs (append '(#\A) (subseq s 1 6) (list (car xy) (cdr xy))) svgm)))
165210 (#\A (let* ((args (rest s))
166211 (rx (first args))
167212 (ry (second args))
185230 (list (cons :G mode) (cons :X (car xy)) (cons :Y (cdr xy))))
186231
187232 (defun push-polyline (svgm pts)
188 (reduce (lambda (svgm p) (push-final-stanza svgm (list #\L (car p) (cdr p)))) pts :initial-value svgm))
233 (reduce (lambda (svgm p) (push-final-stanza svgm (list #\L (car p) (cdr p))))
234 pts :initial-value svgm))
189235
190236 (defun linspace (a b step)
191237 (let* ((steps (abs (ceiling (/ (- b a) step))))
199245 (cur-xy (svgm-current svgm))
200246 (ls (svgm-last-start svgm))
201247 (gcode (svgm-gcode svgm))
248 (gunxf (svgm-gcode-unxf svgm))
202249 (rb (svgm-rel-base svgm))
203250 )
204251 (alexandria:switch (mode)
206253 (#\M (let ((p (cons (first args) (second args))))
207254 (make-svg-machine
208255 :current p :last-start p :rel-base rb
209 :gcode (append gcode (list '((:G . 0) (:Z . 1))
210 (gcode-goto p :mode 0)
211 '((:G . 1) (:Z . -1))))
256 :gcode-unxf (append gunxf (list '((:G . 0) (:Z . 1)) (gcode-goto p :mode 0) '((:G . 1) (:Z . -1))))
257 :gcode gcode
212258 )))
213259 (#\Z (progn
214260 (when (null ls)
215261 (error "got Z (close path) when there's no current path"))
216262 (make-svg-machine
217263 :current ls :last-start ls :rel-base rb
218 :gcode (append gcode (list (gcode-goto ls)))
264 :gcode-unxf (append gunxf (list (gcode-goto ls))) :gcode gcode
219265 )))
220266
221267 ; lines
222268 (#\L (let ((p (cons (first args) (second args))))
223269 (make-svg-machine
224 :current p :last-start (if (null ls) cur-xy ls)
225 :gcode (append gcode (list (gcode-goto p))) :rel-base rb
270 :current p :last-start (if (null ls) cur-xy ls) :rel-base rb
271 :gcode-unxf (append gunxf (list (gcode-goto p))) :gcode gcode
226272 )))
227273
228274 ; cubic beziers
233279 collect (eval-bezier-cubic theta cur-xy c1 c2 p2)))))
234280 (make-svg-machine
235281 :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
236 :gcode (svgm-gcode svg-poly) :last-ctrl-point c2 :rel-base rb
282 :gcode (svgm-gcode svg-poly) :gcode-unxf (svgm-gcode-unxf svg-poly)
283 :last-ctrl-point c2 :rel-base rb
237284 )))
238285 (#\S (let* ((lcp? (svgm-last-ctrl-point svgm))
239286 (lcp (if (null lcp?) cur-xy lcp?))
244291 (#\Q (let* ((c (cons (first args) (second args)))
245292 (p2 (cons (fifth args) (sixth args)))
246293 (svg-poly (push-polyline svgm (loop for theta in (linspace 0 1 0.05)
247 collect (eval-bezier-quadratic theta cur-xy c p2)))))
294 collect (eval-bezier-quadratic theta cur-xy c p2)))))
248295 (make-svg-machine
249296 :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
250 :gcode (svgm-gcode svg-poly) :last-ctrl-point c :rel-base rb
297 :gcode (svgm-gcode svg-poly) :gcode-unxf (svgm-gcode-unxf svg-poly)
298 :last-ctrl-point c :rel-base rb
251299 )))
252300 (#\T (let* ((lcp? (svgm-last-ctrl-point svgm))
253301 (lcp (if (null lcp?) cur-xy lcp?))
261309 (ij (vec- center-xy cur-xy)))
262310 (make-svg-machine
263311 :current xy :last-start ls :rel-base rb
264 :gcode (append gcode (list (list (cons :G (if cw? 3 2))
265 (cons :I (car ij))
266 (cons :J (cdr ij))
267 (cons :X (car xy))
268 (cons :Y (cdr xy)))))
312 :gcode gcode
313 :gcode-unxf (append gunxf (list (list (cons :G (if cw? 3 2))
314 (cons :I (car ij))
315 (cons :J (cdr ij))
316 (cons :X (car xy))
317 (cons :Y (cdr xy)))))
269318 ))))
270319
271320 ; rel-base update
272 (:end-stanza (make-svg-machine :current cur-xy :last-start ls :rel-base cur-xy :gcode gcode))
321 (:end-stanza (make-svg-machine :current cur-xy :last-start ls :rel-base cur-xy
322 :gcode gcode :gcode-unxf gunxf))
273323
274324 (otherwise (error "unsupported mode ~A" mode))
275325 )))
276326
277327 (defun push-stanza (svgm sraw xform)
278328 "Creates and returns a new svg machine that includes the result of interpreting the given stanza"
279 (push-final-stanza svgm (to-abs sraw xform svgm)))
329 (push-final-stanza svgm (to-abs sraw svgm)))
280330
281331 (defun run-stanzas (stanzas xform svgm)
282332 (reduce (lambda (svgm s) (push-stanza svgm s xform)) stanzas :initial-value svgm))
314364
315365 (defun load-path-args (stz)
316366 (when (> (length stz) 0)
317 (multiple-value-bind (st end) (cl-ppcre:scan "[\\-]?[0-9]*(\\.[0-9]+|[0-9]*)" stz)
318 (cons (parse-float:parse-float (subseq stz st end))
319 (load-path-args (string-trim ", " (subseq stz end)))))))
367 (let ((stz-clean (string-trim '(#\Space #\Newline #\Tab #\Linefeed #\Return #\,) stz)))
368 (multiple-value-bind (st end) (cl-ppcre:scan "[\\-]?[0-9]*(\\.[0-9]+|[0-9]*)" stz-clean)
369 (cons (parse-float:parse-float (subseq stz-clean st end))
370 (load-path-args (subseq stz-clean end)))))))
320371
321372 (defun load-path-stanzas (d)
322373 (when (> (length d) 0)
328379
329380 (defun load-path-data (d)
330381 (reduce #'append (mapcar #'normalize-stanza (load-path-stanzas d))))
382
383 (defun update-struct (struct &rest bindings)
384 (loop
385 with copy = (copy-structure struct)
386 for (slot value) on bindings by #'cddr
387 do (setf (slot-value copy slot) value)
388 finally (return copy)))
389
390 (defun xform-svgm (svgm xform)
391 "Transforms gcode-unxf and appends it onto the gcode list"
392 (update-struct svgm
393 'gcode-unxf nil
394 'gcode (append (svgm-gcode svgm)
395 (xform-gcode xform (svgm-gcode-unxf svgm)))))
331396
332397 (defun load-svg-from-xml (data svgm xform-stack)
333398 (if (listp data)
342407 (children (cddr data))
343408 (pathdata (when (string-equal (car tag) "path")
344409 (load-path-data (cadr (assoc "d" attributes :test #'string-equal)))))
345 (svgm-new (if (null pathdata) svgm (run-stanzas pathdata xform svgm))))
410 (svgm-unxf (if (null pathdata) svgm (run-stanzas pathdata xform svgm)))
411 (svgm-new (xform-svgm svgm-unxf xform))
412 )
346413 (reduce (lambda (asvgm child)
347414 (load-svg-from-xml child asvgm new-xform-stack))
348415 children