add support for transformation stacks
Haldean Brown
4 years ago
11 | 11 | (make-array '(2 3) |
12 | 12 | :initial-contents (list (list (first vs) (second vs) (third vs)) |
13 | 13 | (list (fourth vs) (fifth vs) (sixth vs)))))) |
14 | (defun point (xy) (clem:array->matrix | |
15 | (make-array '(3 1) | |
16 | :initial-contents (list (list (car xy)) | |
17 | (list (cdr xy)) | |
18 | '(1))))) | |
19 | ||
20 | (defun vec (xy) (clem:array->matrix | |
21 | (make-array '(3 1) | |
22 | :initial-contents (list (list (car xy)) | |
23 | (list (cdr xy)) | |
24 | '(0))))) | |
25 | ||
26 | (defun clem-to-list (v) (list (clem:val v 0 0) (clem:val v 1 0))) | |
14 | 27 | |
15 | 28 | (defun make-matrix (a b c d e f) (reshape-to-2x3 (list a b c d e f))) |
16 | 29 | (defun make-translate (x &optional (y 0)) (reshape-to-2x3 (list 1 0 x 0 1 y))) |
53 | 66 | )) |
54 | 67 | )) |
55 | 68 | |
56 | (defun to-abs (s svgm) | |
57 | (macrolet ((pairs () `(to-abs-xy svgm (char-upcase (first s)) (rest s)))) | |
69 | (defun apply-xforms (xform s) | |
70 | (let* ((mode (first s)) | |
71 | (args (rest s)) | |
72 | (pairs (loop for i from 0 to (- (length args) 1) by 2 | |
73 | collect (cons (nth i args) (nth (+ i 1) args))))) | |
74 | (cons mode | |
75 | (reduce #'append | |
76 | (mapcar (lambda (p) (clem-to-list (clem:mat-mult xform (point p)))) pairs))))) | |
77 | ||
78 | (defun to-abs (s xform svgm) | |
79 | (macrolet ((pairs () `(apply-xforms xform (to-abs-xy svgm (char-upcase (first s)) (rest s))))) | |
58 | 80 | (alexandria:switch ((first s)) |
59 | 81 | (#\m (pairs)) |
60 | 82 | (#\l (pairs)) |
65 | 87 | (#\h (to-abs-xy svgm #\L (list (second s) 0))) |
66 | 88 | (#\v (to-abs-xy svgm #\L (list 0 (second s)))) |
67 | 89 | (#\a (error "relative arc moves not supported yet")) |
90 | (#\A s) | |
68 | 91 | (#\z '(#\Z)) ; z and Z are the same, but we upcase it to make conditionals simpler later |
69 | (otherwise s) | |
92 | (otherwise (apply-xforms xform s)) | |
70 | 93 | ))) |
71 | 94 | |
72 | 95 | (defun gcode-goto (xy &key (mode 1)) |
73 | 96 | (list (cons :G mode) (cons :X (first xy)) (cons :Y (second xy)))) |
74 | 97 | |
75 | (defun push-stanza (svgm sraw) | |
98 | (defun push-stanza (svgm sraw xform) | |
76 | 99 | "Creates and returns a new svg machine that includes the result of interpreting the given stanza" |
77 | (let* ((s (to-abs sraw svgm)) | |
100 | (let* ((s (to-abs sraw xform svgm)) | |
78 | 101 | (mode (first s)) |
79 | 102 | (args (rest s)) |
80 | 103 | (cur-xy (svgm-current svgm)) |
102 | 125 | (otherwise (error "unsupported mode ~A" mode)) |
103 | 126 | ))) |
104 | 127 | |
105 | (defun run-stanzas (stanzas svgm) | |
106 | (reduce #'push-stanza stanzas :initial-value svgm)) | |
128 | (defun run-stanzas (stanzas xform svgm) | |
129 | (reduce (lambda (svgm s) (push-stanza svgm s xform)) stanzas :initial-value svgm)) | |
107 | 130 | |
108 | 131 | (defun normalize-stanza (s) |
109 | 132 | "Takes a stanza of the form (MODE ARG0 ARG1 ARG2 ... ARGN) and returns a list of stanzas |