git.haldean.org plotter / b5b73ad
starting to turn SVGs into g-code Haldean Brown 4 years ago
3 changed file(s) with 192 addition(s) and 11 deletion(s). Raw diff Collapse all Expand all
+17
-8
cnc.lisp less more
1313 (ql:quickload :parse-float)
1414 (ql:quickload :s-http-client)
1515
16 ; a more useful constant
1617 (setq tau (* 2 pi))
1718
19 ; width of the work area, in stepper steps
1820 (setf *width* 0)
21 ; height of the work area, in stepper steps
1922 (setf *height* 0)
20 (setf *units-per-mm* 50)
23
24 (setf *steps-per-mm* 50)
25
26 ; these are the states that cncserver recognizes
2127 (setq *pen-states* '("up" "draw"))
2228
2329 (defun api-url (e) (format nil "http://saito:4242/~a" e))
111117 (dummy-file nil)
112118 )
113119
114 (defun x-from-gcode (x-mm) (- 100 (rel-x (* x-mm *units-per-mm*))))
115 (defun y-from-gcode (y-mm) (rel-y (* y-mm *units-per-mm*)))
120 (defun x-from-gcode (x-mm) (- 100 (rel-x (* x-mm *steps-per-mm*))))
121 (defun y-from-gcode (y-mm) (rel-y (* y-mm *steps-per-mm*)))
116122
117123 (defun theta-steps-ccw (start end)
118 (if (< end start)
119 (theta-steps-ccw start (+ end tau))
120 (loop for theta from start to end
121 by (min (/ (- end start) 4) (* tau (/ 15 360)))
122 collect theta)))
124 (cond
125 ((< end start) (theta-steps-ccw start (+ end tau)))
126 ; if start and end are the same, we're making a full circle.
127 ((< (abs (- end start)) 0.0001) (theta-steps-ccw start (+ end tau)))
128 (t (loop for theta from start to end
129 by (min (/ (- end start) 4) (* tau (/ 15 360)))
130 collect theta))))
131
123132 (defun theta-steps-cw (start end)
124133 (reverse (theta-steps-ccw end start)))
125134
+0
-3
runcnc.lisp less more
0 (load "cnc.lisp")
1
2 (so3-cnc:run-gcode-file (third *posix-argv*))
+175
-0
svgcam.lisp less more
0 (load "cnc.lisp")
1 (in-package :so3-cnc)
2
3 (ql:quickload :alexandria)
4 (ql:quickload :clem)
5 (ql:quickload :cl-ppcre)
6 (ql:quickload :parse-float)
7 (ql:quickload :xmls)
8
9 (defun reshape-to-2x3 (vs)
10 (clem:array->matrix
11 (make-array '(2 3)
12 :initial-contents (list (list (first vs) (second vs) (third vs))
13 (list (fourth vs) (fifth vs) (sixth vs))))))
14
15 (defun make-matrix (a b c d e f) (reshape-to-2x3 (list a b c d e f)))
16 (defun make-translate (x &optional (y 0)) (reshape-to-2x3 (list 1 0 x 0 1 y)))
17 (defun make-scale (x &optional (y nil)) (reshape-to-2x3 (list x 0 0 0 (if (null y) x y) 0)))
18 (defun make-rotate (a &optional (x 0) (y 0))
19 (clem:m* (make-translate x y)
20 (reshape-to-2x3 (list (cos a) (- (sin a)) (sin a) (cos a) 0 0))
21 (make-translate (- x) (- y))
22 ))
23 (defun make-skew-x (a) (reshape-to-2x3 (list 1 (tan a) 0 0 1 0)))
24 (defun make-skew-y (a) (reshape-to-2x3 (list 1 0 0 (tan a) 1 0)))
25
26 (defun parse-transform (xform-str)
27 (cl-ppcre:register-groups-bind (fun argstr) ("([a-zA-Z]+)\\(([^)]*)\\)" xform-str)
28 (apply
29 (alexandria:switch (fun :test #'string-equal)
30 ("matrix" #'make-matrix)
31 ("translate" #'make-translate)
32 ("scale" #'make-scale)
33 ("rotate" #'make-rotate)
34 ("skewX" #'make-skew-x)
35 ("skewY" #'make-skew-y)
36 )
37 (mapcar #'parse-float:parse-float (cl-ppcre:split "[\\s,]+" argstr))
38 )))
39
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
45 )
46
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 (defun to-abs-xy (svgm mode pairs)
54 (let* ((cur-xy (svgm-cur-xy svgm))
55 (cur-x (first cur-xy))
56 (cur-y (second cur-xy)))
57 (cons mode (loop for i from 1 to (length pairs)
58 for j in pairs
59 collect (+ j (if (= (mod i 2) 1) cur-x cur-y))
60 ))
61 ))
62
63 (defun to-abs (s svgm)
64 (macrolet ((pairs () `(to-abs-xy svgm (char-upcase (first s)) (rest s))))
65 (alexandria:switch ((first s))
66 (#\m (pairs))
67 (#\l (pairs))
68 (#\c (pairs))
69 (#\s (pairs))
70 (#\q (pairs))
71 (#\t (pairs))
72 (#\h (to-abs-xy svgm #\L (list (second s) 0)))
73 (#\v (to-abs-xy svgm #\L (list 0 (second s))))
74 (#\a (error "relative arc moves not supported yet"))
75 (#\z '(#\Z)) ; z and Z are the same, but we upcase it to make conditionals simpler later
76 (otherwise s)
77 )))
78
79 (defun push-stanza (svgm sraw)
80 "Creates and returns a new svg machine that includes the result of interpreting the given stanza"
81 (let* ((s (to-abs sraw svgm))
82 (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))
87 )
88 (alexandria:switch (mode)
89 (#\M (make-svg-machine
90 :finished-paths (if (null current) finished (cons (reverse current) finished))
91 :current-path-rev (list (cdr s))
92 ))
93 (#\L (make-svg-machine
94 :finished-paths finished
95 :current-path-rev (cons (cdr s) nonempty-current)))
96 (#\Z (progn
97 (when (null current)
98 (error "got Z (close path) when there's no current path"))
99 (make-svg-machine
100 :current-path-rev '()
101 :finished-paths (cons (reverse (cons (car (last current)) current)) finished)
102 )))
103 (otherwise (error "unsupported mode ~A" mode))
104 )))
105
106 (defun run-stanzas (stanzas svgm)
107 (reduce #'push-stanza stanzas :initial-value svgm))
108
109 (defun normalize-stanza (s)
110 "Takes a stanza of the form (MODE ARG0 ARG1 ARG2 ... ARGN) and returns a list of stanzas
111 in which each stanza contains only one move with a mode modifier."
112 (let* ((mode (car s))
113 (target-len (alexandria:switch ((char-downcase mode))
114 (#\m 2) (#\z 0) (#\l 2) (#\h 1) (#\v 1) (#\c 6)
115 (#\s 4) (#\q 4) (#\t 2) (#\a 7)))
116 (args (cdr s))
117 (args-len (length args))
118 ; some modes switch after the first set of arguments; this captures
119 ; that.
120 (mode2 (cond
121 ((equal mode #\m) #\l)
122 ((equal mode #\M) #\L)
123 (t mode)
124 ))
125 )
126 (if (= target-len 0)
127 (if (= 0 args-len)
128 (list (list mode))
129 (error "bad number of arguments for zero-length mode ~A: ~A" mode args-len))
130 (progn
131 (unless (= 0 (mod args-len target-len))
132 (error "bad number of arguments in mode ~A: ~A" mode args-len))
133 (labels ((split (a is-first)
134 (when (> (length a) 0)
135 (cons (cons (if is-first mode mode2) (subseq a 0 target-len))
136 (split (subseq a target-len) nil)))))
137 (split args t)
138 )))))
139
140 (defun load-path-args (stz)
141 (when (> (length stz) 0)
142 (multiple-value-bind (st end) (cl-ppcre:scan "[\\-]?[0-9]*(\\.[0-9]+|[0-9]*)" stz)
143 (cons (parse-float:parse-float (subseq stz st end))
144 (load-path-args (string-trim ", " (subseq stz end)))))))
145
146 (defun load-path-stanzas (d)
147 (when (> (length d) 0)
148 (multiple-value-bind (st end) (cl-ppcre:scan "^[a-zA-Z][^a-zA-Z]*" d)
149 (cons
150 (cons (char d 0) (load-path-args (subseq d (+ st 1) end)))
151 (load-path-stanzas (subseq d end)))
152 )))
153
154 (defun load-path-data (d xform-stack)
155 (reduce #'append (mapcar #'normalize-stanza (load-path-stanzas d))))
156
157 (defun load-svg-from-xml (data &key (xform-stack nil))
158 (when (listp data)
159 (let* ((tag (car data))
160 (attributes (cadr data))
161 (xform-attr (assoc "transform" attributes :test #'string-equal))
162 (new-xform-stack (if (null xform-attr)
163 xform-stack
164 (cons (parse-transform (cadr xform-attr)) xform-stack)))
165 (children (cddr data))
166 (pathdata (when (string-equal (car tag) "path")
167 (load-path-data (cadr (assoc "d" attributes :test #'string-equal)) new-xform-stack))))
168 (append pathdata (reduce #'append (mapcar #'load-svg-from-xml children)))
169 )))
170
171 (defun load-svg (fname)
172 (let* ((svgtxt (alexandria:read-file-into-string fname))
173 (svgdata (xmls:parse svgtxt)))
174 (load-svg-from-xml svgdata)))