git.haldean.org plotter / e9a0fbc
fix double-transform issue Haldean Brown 4 years ago
1 changed file(s) with 21 addition(s) and 18 deletion(s). Raw diff Collapse all Expand all
+21
-18
svgcam.lisp less more
2727
2828 (defun make-matrix (a b c d e f) (reshape-to-2x3 (list a b c d e f)))
2929 (defun make-translate (x &optional (y 0)) (reshape-to-2x3 (list 1 0 x 0 1 y)))
30 (defun make-identity () (reshape-to-2x3 (list 1 0 0 0 1 0)))
3031 (defun make-scale (x &optional (y nil)) (reshape-to-2x3 (list x 0 0 0 (if (null y) x y) 0)))
3132 (defun make-rotate (a &optional (x 0) (y 0))
3233 (clem:m* (make-translate x y)
133134 (defun apply-xform (xform p &key (pfunc #'point))
134135 (clem-to-list (clem:mat-mult xform (funcall pfunc p))))
135136 (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 (defun apply-xforms (xform args &key (pfunc #'point)) (mapcar (make-xformer xform :pfunc pfunc) args))
137138
138139 (defun to-abs (s xform svgm)
139140 (labels ((from-pairs (mode ps)
140 (splat-pairs mode (pairs-to-abs-xy svgm (apply-xforms xform ps))))
141 (splat-pairs mode (pairs-to-abs-xy svgm (apply-xforms xform ps :pfunc #'vec))))
141142 (auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s))))
142143 )
143144 (alexandria:switch ((first s))
180181 (defun gcode-goto (xy &key (mode 1))
181182 (list (cons :G mode) (cons :X (car xy)) (cons :Y (cdr xy))))
182183
183 (defun push-polyline (svgm xform pts)
184 (reduce (lambda (svgm p) (push-stanza svgm (list #\L (car p) (cdr p)) xform)) pts :initial-value svgm))
184 (defun push-polyline (svgm pts)
185 (reduce (lambda (svgm p) (push-final-stanza svgm (list #\L (car p) (cdr p)))) pts :initial-value svgm))
185186
186187 (defun linspace (a b step)
187188 (let* ((steps (abs (ceiling (/ (- b a) step))))
188189 (s (/ (- b a) steps)))
189190 (loop for i from 0 to steps collect (+ a (* s i)))))
190191
191 (defun push-stanza (svgm sraw xform)
192 "Creates and returns a new svg machine that includes the result of interpreting the given stanza"
193 (let* ((s (to-abs sraw xform svgm))
194 (mode (first s))
192 (defun push-final-stanza (svgm s)
193 "Creates and returns a new svg machine that includes the result of interpreting the given stanza. Stanza must be 'final', meaning that it's already transformed and in absolute coordinates."
194 (let* ((mode (first s))
195195 (args (rest s))
196196 (cur-xy (svgm-current svgm))
197197 (ls (svgm-last-start svgm))
198198 (gcode (svgm-gcode svgm))
199199 (rb (svgm-rel-base svgm))
200200 )
201 (format t "---~%~A~%~A~%" sraw s)
202201 (alexandria:switch (mode)
203202 ; path start/end
204203 (#\M (let ((p (cons (first args) (second args))))
206205 :current p :last-start p :rel-base rb
207206 :gcode (append gcode (list '((:G . 0) (:Z . 1))
208207 (gcode-goto p :mode 0)
209 '((:G . 0) (:Z . -1))))
208 '((:G . 1) (:Z . -1))))
210209 )))
211210 (#\Z (progn
212211 (when (null ls)
227226 (#\C (let* ((c1 (cons (first args) (second args)))
228227 (c2 (cons (third args) (fourth args)))
229228 (p2 (cons (fifth args) (sixth args)))
230 (svg-poly (push-polyline svgm xform (loop for theta in (linspace 0 1 0.05)
231 collect (eval-bezier-cubic theta cur-xy c1 c2 p2)))))
229 (svg-poly (push-polyline svgm (loop for theta in (linspace 0 1 0.05)
230 collect (eval-bezier-cubic theta cur-xy c1 c2 p2)))))
232231 (make-svg-machine
233232 :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
234233 :gcode (svgm-gcode svg-poly) :last-ctrl-point c2 :rel-base rb
236235 (#\S (let* ((lcp? (svgm-last-ctrl-point svgm))
237236 (lcp (if (null lcp?) cur-xy lcp?))
238237 (c1 (vec+ cur-xy (vec- cur-xy lcp))))
239 (push-stanza svgm (append (list #\C (car c1) (cdr c1)) args) xform)))
238 (push-final-stanza svgm (append (list #\C (car c1) (cdr c1)) args))))
240239
241240 ; quadratic beziers
242241 (#\Q (let* ((c (cons (first args) (second args)))
243242 (p2 (cons (fifth args) (sixth args)))
244 (svg-poly (push-polyline svgm xform (loop for theta in (linspace 0 1 0.05)
245 collect (eval-bezier-quadratic theta cur-xy c p2)))))
243 (svg-poly (push-polyline svgm (loop for theta in (linspace 0 1 0.05)
244 collect (eval-bezier-quadratic theta cur-xy c p2)))))
246245 (make-svg-machine
247246 :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly)
248247 :gcode (svgm-gcode svg-poly) :last-ctrl-point c :rel-base rb
250249 (#\T (let* ((lcp? (svgm-last-ctrl-point svgm))
251250 (lcp (if (null lcp?) cur-xy lcp?))
252251 (c (vec+ cur-xy (vec- cur-xy lcp))))
253 (push-stanza svgm (append (list #\Q (car c) (cdr c)) args) xform)))
252 (push-final-stanza svgm (append (list #\Q (car c) (cdr c)) args))))
254253
255254 ; arcs
256255 (#\A
257256 (multiple-value-bind (center-xy cw?) (arc-center-xy args cur-xy)
258257 (let ((xy (cons (sixth args) (seventh args)))
259 (ij (vec- center-xy cur-xy)))
258 (ij (vec- cur-xy center-xy)))
260259 (make-svg-machine
261260 :current xy :last-start ls :rel-base rb
262261 :gcode (append gcode (list (list (cons :G (if cw? 2 3))
271270
272271 (otherwise (error "unsupported mode ~A" mode))
273272 )))
273
274 (defun push-stanza (svgm sraw xform)
275 "Creates and returns a new svg machine that includes the result of interpreting the given stanza"
276 (push-final-stanza svgm (to-abs sraw xform svgm)))
274277
275278 (defun run-stanzas (stanzas xform svgm)
276279 (reduce (lambda (svgm s) (push-stanza svgm s xform)) stanzas :initial-value svgm))
352355 (defun svgm-emit-gcode (svgm)
353356 (labels ((gcode-number (n) (if (< (abs (- (round n) n)) 0.001)
354357 (format nil "~D" (round n))
355 (format nil "~,3F" n)))
358 (format nil "~,2F" n)))
356359 (emit-assignment (reg) (format nil "~A~A" (car reg) (gcode-number (cdr reg))))
357360 (emit-line (line) (format nil "~{~A~^ ~}" (mapcar #'emit-assignment line))))
358361 (format nil "~{~A~^~%~}" (mapcar #'emit-line (svgm-gcode svgm)))))