fix double-transform issue
Haldean Brown
4 years ago
27 | 27 | |
28 | 28 | (defun make-matrix (a b c d e f) (reshape-to-2x3 (list a b c d e f))) |
29 | 29 | (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))) | |
30 | 31 | (defun make-scale (x &optional (y nil)) (reshape-to-2x3 (list x 0 0 0 (if (null y) x y) 0))) |
31 | 32 | (defun make-rotate (a &optional (x 0) (y 0)) |
32 | 33 | (clem:m* (make-translate x y) |
133 | 134 | (defun apply-xform (xform p &key (pfunc #'point)) |
134 | 135 | (clem-to-list (clem:mat-mult xform (funcall pfunc p)))) |
135 | 136 | (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)) | |
137 | 138 | |
138 | 139 | (defun to-abs (s xform svgm) |
139 | 140 | (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)))) | |
141 | 142 | (auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s)))) |
142 | 143 | ) |
143 | 144 | (alexandria:switch ((first s)) |
180 | 181 | (defun gcode-goto (xy &key (mode 1)) |
181 | 182 | (list (cons :G mode) (cons :X (car xy)) (cons :Y (cdr xy)))) |
182 | 183 | |
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)) | |
185 | 186 | |
186 | 187 | (defun linspace (a b step) |
187 | 188 | (let* ((steps (abs (ceiling (/ (- b a) step)))) |
188 | 189 | (s (/ (- b a) steps))) |
189 | 190 | (loop for i from 0 to steps collect (+ a (* s i))))) |
190 | 191 | |
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)) | |
195 | 195 | (args (rest s)) |
196 | 196 | (cur-xy (svgm-current svgm)) |
197 | 197 | (ls (svgm-last-start svgm)) |
198 | 198 | (gcode (svgm-gcode svgm)) |
199 | 199 | (rb (svgm-rel-base svgm)) |
200 | 200 | ) |
201 | (format t "---~%~A~%~A~%" sraw s) | |
202 | 201 | (alexandria:switch (mode) |
203 | 202 | ; path start/end |
204 | 203 | (#\M (let ((p (cons (first args) (second args)))) |
206 | 205 | :current p :last-start p :rel-base rb |
207 | 206 | :gcode (append gcode (list '((:G . 0) (:Z . 1)) |
208 | 207 | (gcode-goto p :mode 0) |
209 | '((:G . 0) (:Z . -1)))) | |
208 | '((:G . 1) (:Z . -1)))) | |
210 | 209 | ))) |
211 | 210 | (#\Z (progn |
212 | 211 | (when (null ls) |
227 | 226 | (#\C (let* ((c1 (cons (first args) (second args))) |
228 | 227 | (c2 (cons (third args) (fourth args))) |
229 | 228 | (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))))) | |
232 | 231 | (make-svg-machine |
233 | 232 | :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly) |
234 | 233 | :gcode (svgm-gcode svg-poly) :last-ctrl-point c2 :rel-base rb |
236 | 235 | (#\S (let* ((lcp? (svgm-last-ctrl-point svgm)) |
237 | 236 | (lcp (if (null lcp?) cur-xy lcp?)) |
238 | 237 | (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)))) | |
240 | 239 | |
241 | 240 | ; quadratic beziers |
242 | 241 | (#\Q (let* ((c (cons (first args) (second args))) |
243 | 242 | (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))))) | |
246 | 245 | (make-svg-machine |
247 | 246 | :current (svgm-current svg-poly) :last-start (svgm-last-start svg-poly) |
248 | 247 | :gcode (svgm-gcode svg-poly) :last-ctrl-point c :rel-base rb |
250 | 249 | (#\T (let* ((lcp? (svgm-last-ctrl-point svgm)) |
251 | 250 | (lcp (if (null lcp?) cur-xy lcp?)) |
252 | 251 | (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)))) | |
254 | 253 | |
255 | 254 | ; arcs |
256 | 255 | (#\A |
257 | 256 | (multiple-value-bind (center-xy cw?) (arc-center-xy args cur-xy) |
258 | 257 | (let ((xy (cons (sixth args) (seventh args))) |
259 | (ij (vec- center-xy cur-xy))) | |
258 | (ij (vec- cur-xy center-xy))) | |
260 | 259 | (make-svg-machine |
261 | 260 | :current xy :last-start ls :rel-base rb |
262 | 261 | :gcode (append gcode (list (list (cons :G (if cw? 2 3)) |
271 | 270 | |
272 | 271 | (otherwise (error "unsupported mode ~A" mode)) |
273 | 272 | ))) |
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))) | |
274 | 277 | |
275 | 278 | (defun run-stanzas (stanzas xform svgm) |
276 | 279 | (reduce (lambda (svgm s) (push-stanza svgm s xform)) stanzas :initial-value svgm)) |
352 | 355 | (defun svgm-emit-gcode (svgm) |
353 | 356 | (labels ((gcode-number (n) (if (< (abs (- (round n) n)) 0.001) |
354 | 357 | (format nil "~D" (round n)) |
355 | (format nil "~,3F" n))) | |
358 | (format nil "~,2F" n))) | |
356 | 359 | (emit-assignment (reg) (format nil "~A~A" (car reg) (gcode-number (cdr reg)))) |
357 | 360 | (emit-line (line) (format nil "~{~A~^ ~}" (mapcar #'emit-assignment line)))) |
358 | 361 | (format nil "~{~A~^~%~}" (mapcar #'emit-line (svgm-gcode svgm))))) |