fixed a bunch of arc issues, took out transforms
Haldean Brown
4 years ago
6 | 6 | (ql:quickload :cl-ppcre) |
7 | 7 | (ql:quickload :parse-float) |
8 | 8 | (ql:quickload :xmls) |
9 | ||
10 | (defparameter gcode-preamble '(((:G . 1) (:X . 0) (:Y . 0) (:F . 100)) | |
11 | )) | |
9 | 12 | |
10 | 13 | (defun reshape-to-2x3 (vs) |
11 | 14 | (clem:array->matrix |
56 | 59 | (rel-base '(0 . 0)) ; the position we base relative moves off of, updated at the end of each stanza |
57 | 60 | (last-start nil) ; last path start position |
58 | 61 | (last-ctrl-point nil) ; the last control point used in any curve operation, for S paths |
59 | (gcode '()) | |
62 | (gcode gcode-preamble) | |
60 | 63 | ) |
61 | 64 | |
62 | 65 | (defun point-add (a b) |
67 | 70 | (defun arc-center-xy (a xy1p) |
68 | 71 | "Finds and returns (cx, cy), is-clockwise, theta1, theta2 - theta1, in that |
69 | 72 | order, as specified by the SVG arc implementation notes" |
73 | (print a) | |
74 | (print xy1p) | |
70 | 75 | (let* ((rx (abs (first a))) |
71 | 76 | (ry (abs (second a))) |
72 | 77 | (rx2 (expt rx 2)) |
138 | 143 | |
139 | 144 | (defun to-abs (s xform svgm) |
140 | 145 | (labels ((from-pairs (mode ps) |
141 | (splat-pairs mode (pairs-to-abs-xy svgm (apply-xforms xform ps :pfunc #'vec)))) | |
146 | (splat-pairs mode (pairs-to-abs-xy svgm ps))) | |
142 | 147 | (auto-pairs () (from-pairs (char-upcase (first s)) (build-pairs (rest s)))) |
143 | 148 | ) |
144 | 149 | (alexandria:switch ((first s)) |
149 | 154 | (#\q (auto-pairs)) |
150 | 155 | (#\t (auto-pairs)) |
151 | 156 | (#\h (from-pairs #\L (list (cons (second s) 0)))) |
152 | (#\H (splat-pairs #\L (list (apply-xform xform (cons (second s) 0))))) | |
157 | (#\H (splat-pairs #\L (list (vec+ (svgm-current svgm) (cons (second s) 0))))) | |
153 | 158 | (#\v (from-pairs #\L (list (cons 0 (second s))))) |
154 | (#\V (splat-pairs #\L (list (apply-xform xform (cons 0 (second s)))))) | |
159 | (#\V (splat-pairs #\L (list (vec+ (svgm-current svgm) (cons 0 (second s)))))) | |
155 | 160 | |
156 | 161 | (#\a (let* ((args (rest s)) |
157 | 162 | (xy (pair-to-abs-xy svgm (cons (sixth args) (seventh args))))) |
170 | 175 | (error "ellipses not supported yet") |
171 | 176 | ; otherwise we leave it as a circle so we can use the G-Code arc commands |
172 | 177 | ; Since it's a circle, we can set phi to zero (because there is no major/minor axis) |
173 | (let ((xformed-xy (apply-xform xform (cons x y)))) | |
174 | (list #\A rx ry 0.0d0 (fourth args) (fifth args) (car xformed-xy) (cdr xformed-xy))) | |
178 | (list #\A rx ry 0.0d0 (fourth args) (fifth args) x y) | |
175 | 179 | ))) |
176 | 180 | (#\z '(#\Z)) ; z and Z are the same, but we upcase it to make conditionals simpler later |
177 | (otherwise (splat-pairs (first s) | |
178 | (apply-xforms xform (build-pairs (rest s))))) | |
181 | (otherwise s) | |
179 | 182 | ))) |
180 | 183 | |
181 | 184 | (defun gcode-goto (xy &key (mode 1)) |
255 | 258 | (#\A |
256 | 259 | (multiple-value-bind (center-xy cw?) (arc-center-xy args cur-xy) |
257 | 260 | (let ((xy (cons (sixth args) (seventh args))) |
258 | (ij (vec- cur-xy center-xy))) | |
261 | (ij (vec- center-xy cur-xy))) | |
259 | 262 | (make-svg-machine |
260 | 263 | :current xy :last-start ls :rel-base rb |
261 | :gcode (append gcode (list (list (cons :G (if cw? 2 3)) | |
264 | :gcode (append gcode (list (list (cons :G (if cw? 3 2)) | |
262 | 265 | (cons :I (car ij)) |
263 | 266 | (cons :J (cdr ij)) |
264 | 267 | (cons :X (car xy)) |