actually generate g-code
Haldean Brown
4 years ago
38 | 38 | ))) |
39 | 39 | |
40 | 40 | (defstruct (svg-machine (:conc-name svgm-)) |
41 | (finished-paths '()) | |
42 | (current-path-rev '()) ; note: current path is actually the reversed current path, | |
43 | ; with the most recent point being the first element. This is | |
44 | ; done so that it's fast to add new stuff onto the list | |
41 | (current '(0 0)) ; current position | |
42 | (last-start nil) ; last path start position | |
43 | (gcode '()) | |
45 | 44 | ) |
46 | 45 | |
47 | (defun svgm-cur-xy (svgm) | |
48 | (if (null (svgm-current-path-rev svgm)) | |
49 | (if (null (svgm-finished-paths svgm)) '(0.0 0.0) | |
50 | (car (last (first (svgm-finished-paths svgm))))) | |
51 | (first (svgm-current-path-rev svgm)))) | |
52 | ||
53 | 46 | (defun to-abs-xy (svgm mode pairs) |
54 | (let* ((cur-xy (svgm-cur-xy svgm)) | |
47 | (let* ((cur-xy (svgm-current svgm)) | |
55 | 48 | (cur-x (first cur-xy)) |
56 | 49 | (cur-y (second cur-xy))) |
57 | 50 | (cons mode (loop for i from 1 to (length pairs) |
76 | 69 | (otherwise s) |
77 | 70 | ))) |
78 | 71 | |
72 | (defun gcode-goto (xy &key (mode 1)) | |
73 | (list (cons :G mode) (cons :X (first xy)) (cons :Y (second xy)))) | |
74 | ||
79 | 75 | (defun push-stanza (svgm sraw) |
80 | 76 | "Creates and returns a new svg machine that includes the result of interpreting the given stanza" |
81 | 77 | (let* ((s (to-abs sraw svgm)) |
82 | 78 | (mode (first s)) |
83 | (finished (svgm-finished-paths svgm)) | |
84 | (current (svgm-current-path-rev svgm)) | |
85 | (cur-xy (svgm-cur-xy svgm)) | |
86 | (nonempty-current (if (null current) (list cur-xy) current)) | |
79 | (args (rest s)) | |
80 | (cur-xy (svgm-current svgm)) | |
81 | (ls (svgm-last-start svgm)) | |
82 | (gcode (svgm-gcode svgm)) | |
87 | 83 | ) |
88 | 84 | (alexandria:switch (mode) |
89 | 85 | (#\M (make-svg-machine |
90 | :finished-paths (if (null current) finished (cons (reverse current) finished)) | |
91 | :current-path-rev (list (cdr s)) | |
86 | :current args :last-start args | |
87 | :gcode (append gcode (list '((:G . 0) (:Z . 1)) | |
88 | (gcode-goto args :mode 0) | |
89 | '((:G . 0) (:Z . -1)))) | |
92 | 90 | )) |
93 | 91 | (#\L (make-svg-machine |
94 | :finished-paths finished | |
95 | :current-path-rev (cons (cdr s) nonempty-current))) | |
92 | :current args :last-start ls | |
93 | :gcode (append gcode (list (gcode-goto args))) | |
94 | )) | |
96 | 95 | (#\Z (progn |
97 | (when (null current) | |
96 | (when (null ls) | |
98 | 97 | (error "got Z (close path) when there's no current path")) |
99 | 98 | (make-svg-machine |
100 | :current-path-rev '() | |
101 | :finished-paths (cons (reverse (cons (car (last current)) current)) finished) | |
102 | ))) | |
99 | :current ls :last-start ls | |
100 | :gcode (append gcode (list (gcode-goto ls))) | |
101 | ))) | |
103 | 102 | (otherwise (error "unsupported mode ~A" mode)) |
104 | 103 | ))) |
105 | 104 |