fixed a bunch of arc issues, took out transforms
Haldean Brown
3 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)) |