0 | |
(load "package.lisp")
|
1 | |
(load "bezier.lisp")
|
2 | |
(load "stringutil.lisp")
|
3 | |
(in-package :so3-cnc)
|
4 | |
|
5 | |
(ql:quickload :alexandria)
|
6 | |
(ql:quickload :cl-ppcre)
|
7 | |
(ql:quickload :jsown)
|
8 | |
(ql:quickload :parse-float)
|
9 | |
(ql:quickload :s-http-client)
|
10 | |
|
11 | |
; width of the work area, in stepper steps
|
12 | |
(defparameter *width* 0)
|
13 | |
; height of the work area, in stepper steps
|
14 | |
(defparameter *height* 0)
|
15 | |
|
16 | |
(defparameter *steps-per-mm* 46)
|
17 | |
|
18 | |
; these are the states that cncserver recognizes
|
19 | |
(defparameter *pen-states* '("up" "draw"))
|
20 | |
|
21 | |
(defparameter *cnc-host* "192.168.1.129")
|
22 | |
(defun api-url (e) (format nil "http://~a:4242/~a" *cnc-host* e))
|
23 | |
|
24 | |
(defun extract (d v) (cdr (assoc v d :test #'equal)))
|
25 | |
|
26 | |
(defun init ()
|
27 | |
(let* ((settings (jsown:parse (s-http-client:do-http-request (api-url "v1/settings/bot"))))
|
28 | |
(max-area (jsown:val settings "maxArea")))
|
29 | |
(setf *width* (parse-integer (jsown:val max-area "width")))
|
30 | |
(setf *height* (parse-integer (jsown:val max-area "height")))
|
31 | |
(send-put-request (api-url "v1/settings/global")
|
32 | |
(jsown:new-js ("invertAxis" (jsown:new-js ("x" :f) ("y" :f)))))
|
33 | |
(send-put-request (api-url "v1/settings/bot")
|
34 | |
(jsown:new-js ("speed:drawing" 8) ("speed:moving" 50)))
|
35 | |
settings
|
36 | |
))
|
37 | |
|
38 | |
(defun rel-x (x) (when (= *width* 0) (init)) (* 100 (/ x *width*)))
|
39 | |
(defun rel-y (y) (when (= *width* 0) (init)) (* 100 (/ y *height*)))
|
40 | |
(defun abs-x (x) (when (= *width* 0) (init)) (/ (* x *width*) 100))
|
41 | |
(defun abs-y (y) (when (= *width* 0) (init)) (/ (* y *height*) 100))
|
42 | |
|
43 | |
(defun get-pen-raw () (cdr (jsown:parse (s-http-client:do-http-request (api-url "v1/pen")))))
|
44 | |
(defun get-pen ()
|
45 | |
(let* ((pen-data (get-pen-raw))
|
46 | |
(extract-xyz
|
47 | |
(lambda (d) (list (extract d "x")
|
48 | |
(extract d "y")
|
49 | |
(position (extract d "state") *pen-states* :test #'equal)))))
|
50 | |
(funcall extract-xyz pen-data)))
|
51 | |
|
52 | |
(defun send-put-request (url js)
|
53 | |
(s-http-client:do-http-request
|
54 | |
url :method :PUT :content (jsown:to-json js) :content-type "application/json; charset=UTF-8"))
|
55 | |
|
56 | |
(defun set-pen-rel (x y z &key (wait-time 0))
|
57 | |
(send-put-request (api-url "v1/pen") (jsown:new-js ("state" (nth z *pen-states*))))
|
58 | |
(send-put-request (api-url "v1/pen") (jsown:new-js ("x" x) ("y" y))))
|
59 | |
|
60 | |
(defun disable-motors ()
|
61 | |
(s-http-client:do-http-request (api-url "v1/motors") :method :DELETE))
|
62 | |
|
63 | |
(defun set-zero ()
|
64 | |
(send-put-request (api-url "v1/motors") (jsown:new-js ("reset" 1))))
|
65 | |
|
66 | |
(defun start-buffer ()
|
67 | |
(send-put-request (api-url "v1/buffer") (jsown:new-js ("paused" t))))
|
68 | |
(defun flush-buffer ()
|
69 | |
(send-put-request (api-url "v1/buffer") (jsown:new-js ("paused" :f))))
|
70 | |
|
71 | |
(defun gcode-remove-comments (line)
|
72 | |
(if (equal (char line 0) #\#) ""
|
73 | |
(string-trim '(#\Space #\Newline #\Linefeed #\Return)
|
74 | |
(cl-ppcre:regex-replace-all "\\([^)]*\\)" line ""))))
|
75 | |
|
76 | |
(defun gcode-assign-parse (dirty-line)
|
77 | |
(let ((line (gcode-remove-comments dirty-line)))
|
78 | |
(if (= (length line) 0)
|
79 | |
nil
|
80 | |
(remove-if
|
81 | |
(lambda (pair) (null (car pair)))
|
82 | |
(mapcar (lambda (term)
|
83 | |
(let* ((register (char term 0))
|
84 | |
(reg (cond
|
85 | |
((equal register #\G) :G)
|
86 | |
((equal register #\X) :X)
|
87 | |
((equal register #\Y) :Y)
|
88 | |
((equal register #\Z) :Z)
|
89 | |
((equal register #\I) :I)
|
90 | |
((equal register #\J) :J)
|
91 | |
(t nil)
|
92 | |
)))
|
93 | |
(if (null reg) (cons nil nil)
|
94 | |
(cons reg
|
95 | |
(funcall (if (eq reg :G) #'parse-integer #'parse-float:parse-float)
|
96 | |
(subseq term 1))))))
|
97 | |
(split-by-one-space (gcode-remove-comments line)))))))
|
98 | |
|
99 | |
(defstruct (gvm (:conc-name gvm-))
|
100 | |
(mode 1 :type integer)
|
101 | |
(i 0.0 :type float)
|
102 | |
(j 0.0 :type float)
|
103 | |
(x 0.0 :type float)
|
104 | |
(y 0.0 :type float)
|
105 | |
(z "unknown" :type string)
|
106 | |
(global-translate '(0 . 0))
|
107 | |
(dummy-file nil)
|
108 | |
)
|
109 | |
|
110 | |
(defun x-from-gcode (x-mm) (rel-x (* x-mm *steps-per-mm*)))
|
111 | |
(defun y-from-gcode (y-mm) (rel-y (* y-mm *steps-per-mm*)))
|
112 | |
|
113 | |
(defun theta-steps-ccw (start end)
|
114 | |
(cond
|
115 | |
((< end start) (theta-steps-ccw start (+ end tau)))
|
116 | |
; if start and end are the same, we're making a full circle.
|
117 | |
((< (abs (- end start)) 0.0001) (theta-steps-ccw start (+ end tau)))
|
118 | |
(t (loop for theta from start to end
|
119 | |
by (min (/ (- end start) 4) (* tau (/ 15 360)))
|
120 | |
collect theta))))
|
121 | |
|
122 | |
(defun theta-steps-cw (start end)
|
123 | |
(reverse (theta-steps-ccw end start)))
|
124 | |
|
125 | |
(defun theta-steps (mode start end)
|
126 | |
(let* ((thetas (funcall (alexandria:switch (mode)
|
127 | |
(2 #'theta-steps-cw)
|
128 | |
(3 #'theta-steps-ccw)) start end))
|
129 | |
(nt (length thetas)))
|
130 | |
(mapcar (lambda (i th) (cons (/ i (float nt)) th))
|
131 | |
(loop for i from 0 to nt collect i)
|
132 | |
thetas)))
|
133 | |
|
134 | |
(defun run-gcode-circle (g x y i j old-x old-y)
|
135 | |
(let* ((cx (+ old-x i))
|
136 | |
(cy (+ old-y j))
|
137 | |
(r (sqrt (+ (expt i 2) (expt j 2))))
|
138 | |
(r-end (sqrt (+ (expt (- x cx) 2) (expt (- y cy) 2))))
|
139 | |
(ni (- cx x))
|
140 | |
(nj (- cy y))
|
141 | |
(theta-end (atan (- nj) (- ni)))
|
142 | |
(theta-start (atan (- j) (- i)))
|
143 | |
)
|
144 | |
(progn
|
145 | |
(loop for ft in (theta-steps (gvm-mode g) theta-start theta-end)
|
146 | |
do (let* ((theta (cdr ft))
|
147 | |
(rad (+ r (* (car ft) (- r-end r))))
|
148 | |
(tx (+ cx (* rad (cos theta))))
|
149 | |
(ty (+ cy (* rad (sin theta)))))
|
150 | |
(run-gcode-linear g tx ty)))
|
151 | |
(run-gcode-linear g x y))))
|
152 | |
|
153 | |
(defun send-goto (xrel yrel)
|
154 | |
(format t "send ~a ~a~%" xrel yrel)
|
155 | |
(send-put-request
|
156 | |
(api-url "v1/pen")
|
157 | |
(jsown:new-js ("x" xrel) ("y" yrel) ("ignoreTimeout" 1))))
|
158 | |
|
159 | |
(defun run-gcode-linear (g x y)
|
160 | |
(if (null (gvm-dummy-file g))
|
161 | |
(send-goto (x-from-gcode (+ (car (gvm-global-translate g)) x))
|
162 | |
(y-from-gcode (+ (cdr (gvm-global-translate g)) y)))
|
163 | |
(format (gvm-dummy-file g) "G1 X~f Y~f~%" (x-from-gcode x) (y-from-gcode y))
|
164 | |
))
|
165 | |
|
166 | |
(defun run-gcode-movement (g old-x old-y)
|
167 | |
(alexandria:switch ((gvm-mode g))
|
168 | |
(0 (run-gcode-linear g (gvm-x g) (gvm-y g)))
|
169 | |
(1 (run-gcode-linear g (gvm-x g) (gvm-y g)))
|
170 | |
(2 (run-gcode-circle g (gvm-x g) (gvm-y g) (gvm-i g) (gvm-j g) old-x old-y))
|
171 | |
(3 (run-gcode-circle g (gvm-x g) (gvm-y g) (gvm-i g) (gvm-j g) old-x old-y))
|
172 | |
))
|
173 | |
|
174 | |
(defun update-state-from-gcode (g state)
|
175 | |
(let ((new-state-name (nth (if (> state 0) 0 1) *pen-states*)))
|
176 | |
(unless (or (not (null (gvm-dummy-file g))) (eq new-state-name (gvm-z g)))
|
177 | |
(send-put-request (api-url "v1/pen") (jsown:new-js ("state" new-state-name)))
|
178 | |
)))
|
179 | |
|
180 | |
(defun run-gcode-line (terms g)
|
181 | |
(let* ((new-mode (assoc :G terms))
|
182 | |
(new-state (assoc :Z terms))
|
183 | |
(new-x (assoc :X terms))
|
184 | |
(new-y (assoc :Y terms))
|
185 | |
(new-i (assoc :I terms))
|
186 | |
(new-j (assoc :J terms))
|
187 | |
(old-x (gvm-x g))
|
188 | |
(old-y (gvm-y g)))
|
189 | |
(unless (null new-mode) (setf (gvm-mode g) (cdr new-mode)))
|
190 | |
(unless (null new-state) (update-state-from-gcode g (cdr new-state)))
|
191 | |
(unless (null new-x) (setf (gvm-x g) (cdr new-x)))
|
192 | |
(unless (null new-y) (setf (gvm-y g) (cdr new-y)))
|
193 | |
(unless (null new-i) (setf (gvm-i g) (cdr new-i)))
|
194 | |
(unless (null new-j) (setf (gvm-j g) (cdr new-j)))
|
195 | |
(run-gcode-movement g old-x old-y)))
|
196 | |
|
197 | |
(defun gcode-bounds (terms)
|
198 | |
(let ((xs (remove nil (mapcar (lambda (g) (cdr (assoc :X g))) terms)))
|
199 | |
(ys (remove nil (mapcar (lambda (g) (cdr (assoc :Y g))) terms))))
|
200 | |
(list
|
201 | |
(alexandria:extremum xs #'<) (alexandria:extremum ys #'<)
|
202 | |
(alexandria:extremum xs #'>) (alexandria:extremum ys #'>))))
|
203 | |
|
204 | |
(defun find-gcode-translate (terms)
|
205 | |
(when (null *width*) (init))
|
206 | |
(let* ((bounds (gcode-bounds terms))
|
207 | |
(width-mm (/ *width* *steps-per-mm*))
|
208 | |
(xdiff (- width-mm (- (third bounds) (first bounds)))))
|
209 | |
(cons (- (/ xdiff 2) (first bounds)) 0)))
|
210 | |
|
211 | |
(defun run-gcode-file-on-gvm (g fname)
|
212 | |
(with-open-file (stream fname :direction :input)
|
213 | |
(let* ((lines (loop for line = (read-line stream nil 'eof)
|
214 | |
while (not (equal line 'eof)) collect line))
|
215 | |
(termslist (mapcar #'gcode-assign-parse lines)))
|
216 | |
(progn
|
217 | |
(setf (gvm-global-translate g) (find-gcode-translate termslist))
|
218 | |
(format t "global offset set to ~a for x-centering~%" (gvm-global-translate g))
|
219 | |
(loop for terms in termslist do (run-gcode-line terms g))
|
220 | |
))))
|
221 | |
|
222 | |
(defun run-gcode-file (file &key (dummy-file nil))
|
223 | |
(if (null dummy-file) (run-gcode-file-on-gvm (make-gvm) file)
|
224 | |
(with-open-file (output dummy-file :direction :output :if-exists :supersede)
|
225 | |
(run-gcode-file-on-gvm (make-gvm :dummy-file output) file))
|
226 | |
))
|
|
0 |
(load "package.lisp")
|
|
1 |
(load "bezier.lisp")
|
|
2 |
(load "stringutil.lisp")
|
|
3 |
(in-package :so3-cnc)
|
|
4 |
|
|
5 |
(ql:quickload :alexandria)
|
|
6 |
(ql:quickload :cl-ppcre)
|
|
7 |
(ql:quickload :jsown)
|
|
8 |
(ql:quickload :parse-float)
|
|
9 |
(ql:quickload :s-http-client)
|
|
10 |
|
|
11 |
; width of the work area, in stepper steps
|
|
12 |
(defparameter *width* 0)
|
|
13 |
; height of the work area, in stepper steps
|
|
14 |
(defparameter *height* 0)
|
|
15 |
|
|
16 |
(defparameter *steps-per-mm* 46)
|
|
17 |
|
|
18 |
; these are the states that cncserver recognizes
|
|
19 |
(defparameter *pen-states* '("up" "draw"))
|
|
20 |
|
|
21 |
(defparameter *cnc-host* "192.168.1.129")
|
|
22 |
(defun api-url (e) (format nil "http://~a:4242/~a" *cnc-host* e))
|
|
23 |
|
|
24 |
(defun extract (d v) (cdr (assoc v d :test #'equal)))
|
|
25 |
|
|
26 |
(defun init ()
|
|
27 |
(let* ((settings (jsown:parse (s-http-client:do-http-request (api-url "v1/settings/bot"))))
|
|
28 |
(max-area (jsown:val settings "maxArea")))
|
|
29 |
(setf *width* (parse-integer (jsown:val max-area "width")))
|
|
30 |
(setf *height* (parse-integer (jsown:val max-area "height")))
|
|
31 |
(send-put-request (api-url "v1/settings/global")
|
|
32 |
(jsown:new-js ("invertAxis" (jsown:new-js ("x" :f) ("y" :f)))))
|
|
33 |
(send-put-request (api-url "v1/settings/bot")
|
|
34 |
(jsown:new-js ("speed:drawing" 8) ("speed:moving" 50)))
|
|
35 |
settings
|
|
36 |
))
|
|
37 |
|
|
38 |
(defun rel-x (x) (when (= *width* 0) (init)) (* 100 (/ x *width*)))
|
|
39 |
(defun rel-y (y) (when (= *width* 0) (init)) (* 100 (/ y *height*)))
|
|
40 |
(defun abs-x (x) (when (= *width* 0) (init)) (/ (* x *width*) 100))
|
|
41 |
(defun abs-y (y) (when (= *width* 0) (init)) (/ (* y *height*) 100))
|
|
42 |
|
|
43 |
(defun get-pen-raw () (cdr (jsown:parse (s-http-client:do-http-request (api-url "v1/pen")))))
|
|
44 |
(defun get-pen ()
|
|
45 |
(let* ((pen-data (get-pen-raw))
|
|
46 |
(extract-xyz
|
|
47 |
(lambda (d) (list (extract d "x")
|
|
48 |
(extract d "y")
|
|
49 |
(position (extract d "state") *pen-states* :test #'equal)))))
|
|
50 |
(funcall extract-xyz pen-data)))
|
|
51 |
|
|
52 |
(defun send-put-request (url js)
|
|
53 |
(s-http-client:do-http-request
|
|
54 |
url :method :PUT :content (jsown:to-json js) :content-type "application/json; charset=UTF-8"))
|
|
55 |
|
|
56 |
(defun set-pen-rel (x y z &key (wait-time 0))
|
|
57 |
(send-put-request (api-url "v1/pen") (jsown:new-js ("state" (nth z *pen-states*))))
|
|
58 |
(send-put-request (api-url "v1/pen") (jsown:new-js ("x" x) ("y" y))))
|
|
59 |
|
|
60 |
(defun disable-motors ()
|
|
61 |
(s-http-client:do-http-request (api-url "v1/motors") :method :DELETE))
|
|
62 |
|
|
63 |
(defun set-zero ()
|
|
64 |
(send-put-request (api-url "v1/motors") (jsown:new-js ("reset" 1))))
|
|
65 |
|
|
66 |
(defun start-buffer ()
|
|
67 |
(send-put-request (api-url "v1/buffer") (jsown:new-js ("paused" t))))
|
|
68 |
(defun flush-buffer ()
|
|
69 |
(send-put-request (api-url "v1/buffer") (jsown:new-js ("paused" :f))))
|
|
70 |
|
|
71 |
(defun gcode-remove-comments (line)
|
|
72 |
(if (equal (char line 0) #\#) ""
|
|
73 |
(string-trim '(#\Space #\Newline #\Linefeed #\Return)
|
|
74 |
(cl-ppcre:regex-replace-all "\\([^)]*\\)" line ""))))
|
|
75 |
|
|
76 |
(defun gcode-assign-parse (dirty-line)
|
|
77 |
(let ((line (gcode-remove-comments dirty-line)))
|
|
78 |
(if (= (length line) 0)
|
|
79 |
nil
|
|
80 |
(remove-if
|
|
81 |
(lambda (pair) (null (car pair)))
|
|
82 |
(mapcar (lambda (term)
|
|
83 |
(let* ((register (char term 0))
|
|
84 |
(reg (cond
|
|
85 |
((equal register #\G) :G)
|
|
86 |
((equal register #\X) :X)
|
|
87 |
((equal register #\Y) :Y)
|
|
88 |
((equal register #\Z) :Z)
|
|
89 |
((equal register #\I) :I)
|
|
90 |
((equal register #\J) :J)
|
|
91 |
(t nil)
|
|
92 |
)))
|
|
93 |
(if (null reg) (cons nil nil)
|
|
94 |
(cons reg
|
|
95 |
(funcall (if (eq reg :G) #'parse-integer #'parse-float:parse-float)
|
|
96 |
(subseq term 1))))))
|
|
97 |
(split-by-one-space (gcode-remove-comments line)))))))
|
|
98 |
|
|
99 |
(defstruct (gvm (:conc-name gvm-))
|
|
100 |
(mode 1 :type integer)
|
|
101 |
(i 0.0 :type float)
|
|
102 |
(j 0.0 :type float)
|
|
103 |
(x 0.0 :type float)
|
|
104 |
(y 0.0 :type float)
|
|
105 |
(z "unknown" :type string)
|
|
106 |
(global-translate '(0 . 0))
|
|
107 |
(dummy-file nil)
|
|
108 |
)
|
|
109 |
|
|
110 |
(defun x-from-gcode (x-mm) (rel-x (* x-mm *steps-per-mm*)))
|
|
111 |
(defun y-from-gcode (y-mm) (rel-y (* y-mm *steps-per-mm*)))
|
|
112 |
|
|
113 |
(defun theta-steps-ccw (start end)
|
|
114 |
(cond
|
|
115 |
((< end start) (theta-steps-ccw start (+ end tau)))
|
|
116 |
; if start and end are the same, we're making a full circle.
|
|
117 |
((< (abs (- end start)) 0.0001) (theta-steps-ccw start (+ end tau)))
|
|
118 |
(t (loop for theta from start to end
|
|
119 |
by (min (/ (- end start) 4) (* tau (/ 15 360)))
|
|
120 |
collect theta))))
|
|
121 |
|
|
122 |
(defun theta-steps-cw (start end)
|
|
123 |
(reverse (theta-steps-ccw end start)))
|
|
124 |
|
|
125 |
(defun theta-steps (mode start end)
|
|
126 |
(let* ((thetas (funcall (alexandria:switch (mode)
|
|
127 |
(2 #'theta-steps-cw)
|
|
128 |
(3 #'theta-steps-ccw)) start end))
|
|
129 |
(nt (length thetas)))
|
|
130 |
(mapcar (lambda (i th) (cons (/ i (float nt)) th))
|
|
131 |
(loop for i from 0 to nt collect i)
|
|
132 |
thetas)))
|
|
133 |
|
|
134 |
(defun run-gcode-circle (g x y i j old-x old-y)
|
|
135 |
(let* ((cx (+ old-x i))
|
|
136 |
(cy (+ old-y j))
|
|
137 |
(r (sqrt (+ (expt i 2) (expt j 2))))
|
|
138 |
(r-end (sqrt (+ (expt (- x cx) 2) (expt (- y cy) 2))))
|
|
139 |
(ni (- cx x))
|
|
140 |
(nj (- cy y))
|
|
141 |
(theta-end (atan (- nj) (- ni)))
|
|
142 |
(theta-start (atan (- j) (- i)))
|
|
143 |
)
|
|
144 |
(progn
|
|
145 |
(loop for ft in (theta-steps (gvm-mode g) theta-start theta-end)
|
|
146 |
do (let* ((theta (cdr ft))
|
|
147 |
(rad (+ r (* (car ft) (- r-end r))))
|
|
148 |
(tx (+ cx (* rad (cos theta))))
|
|
149 |
(ty (+ cy (* rad (sin theta)))))
|
|
150 |
(run-gcode-linear g tx ty)))
|
|
151 |
(run-gcode-linear g x y))))
|
|
152 |
|
|
153 |
(defun send-goto (xrel yrel)
|
|
154 |
(send-put-request
|
|
155 |
(api-url "v1/pen")
|
|
156 |
(jsown:new-js ("x" xrel) ("y" yrel) ("ignoreTimeout" 1))))
|
|
157 |
|
|
158 |
(defun run-gcode-linear (g x y)
|
|
159 |
(if (null (gvm-dummy-file g))
|
|
160 |
(send-goto (x-from-gcode (+ (car (gvm-global-translate g)) x))
|
|
161 |
(y-from-gcode (+ (cdr (gvm-global-translate g)) y)))
|
|
162 |
(format (gvm-dummy-file g) "G1 X~f Y~f~%" (x-from-gcode x) (y-from-gcode y))
|
|
163 |
))
|
|
164 |
|
|
165 |
(defun run-gcode-movement (g old-x old-y)
|
|
166 |
(alexandria:switch ((gvm-mode g))
|
|
167 |
(0 (run-gcode-linear g (gvm-x g) (gvm-y g)))
|
|
168 |
(1 (run-gcode-linear g (gvm-x g) (gvm-y g)))
|
|
169 |
(2 (run-gcode-circle g (gvm-x g) (gvm-y g) (gvm-i g) (gvm-j g) old-x old-y))
|
|
170 |
(3 (run-gcode-circle g (gvm-x g) (gvm-y g) (gvm-i g) (gvm-j g) old-x old-y))
|
|
171 |
))
|
|
172 |
|
|
173 |
(defun send-pen-up () (send-put-request (api-url "v1/pen") (jsown:new-js ("state" "up"))))
|
|
174 |
(defun send-pen-draw () (send-put-request (api-url "v1/pen") (jsown:new-js ("state" "draw"))))
|
|
175 |
|
|
176 |
(defun update-state-from-gcode (g state)
|
|
177 |
(let ((new-state-name (nth (if (> state 0) 0 1) *pen-states*)))
|
|
178 |
(unless (or (not (null (gvm-dummy-file g))) (eq new-state-name (gvm-z g)))
|
|
179 |
(send-put-request (api-url "v1/pen") (jsown:new-js ("state" new-state-name)))
|
|
180 |
)))
|
|
181 |
|
|
182 |
(defun run-gcode-line (terms g)
|
|
183 |
(let* ((new-mode (assoc :G terms))
|
|
184 |
(new-state (assoc :Z terms))
|
|
185 |
(new-x (assoc :X terms))
|
|
186 |
(new-y (assoc :Y terms))
|
|
187 |
(new-i (assoc :I terms))
|
|
188 |
(new-j (assoc :J terms))
|
|
189 |
(old-x (gvm-x g))
|
|
190 |
(old-y (gvm-y g)))
|
|
191 |
(unless (null new-mode) (setf (gvm-mode g) (cdr new-mode)))
|
|
192 |
(unless (null new-state) (update-state-from-gcode g (cdr new-state)))
|
|
193 |
(unless (null new-x) (setf (gvm-x g) (cdr new-x)))
|
|
194 |
(unless (null new-y) (setf (gvm-y g) (cdr new-y)))
|
|
195 |
(unless (null new-i) (setf (gvm-i g) (cdr new-i)))
|
|
196 |
(unless (null new-j) (setf (gvm-j g) (cdr new-j)))
|
|
197 |
(run-gcode-movement g old-x old-y)))
|
|
198 |
|
|
199 |
(defun gcode-bounds (terms)
|
|
200 |
(let ((xs (remove nil (mapcar (lambda (g) (cdr (assoc :X g))) terms)))
|
|
201 |
(ys (remove nil (mapcar (lambda (g) (cdr (assoc :Y g))) terms))))
|
|
202 |
(list
|
|
203 |
(alexandria:extremum xs #'<) (alexandria:extremum ys #'<)
|
|
204 |
(alexandria:extremum xs #'>) (alexandria:extremum ys #'>))))
|
|
205 |
|
|
206 |
(defun find-gcode-translate (terms)
|
|
207 |
(when (null *width*) (init))
|
|
208 |
(let* ((bounds (gcode-bounds terms))
|
|
209 |
(width-mm (/ *width* *steps-per-mm*))
|
|
210 |
(xdiff (- width-mm (- (third bounds) (first bounds)))))
|
|
211 |
(cons (- (/ xdiff 2) (first bounds)) 0)))
|
|
212 |
|
|
213 |
(defun run-gcode-file-on-gvm (g fname)
|
|
214 |
(with-open-file (stream fname :direction :input)
|
|
215 |
(let* ((lines (loop for line = (read-line stream nil 'eof)
|
|
216 |
while (not (equal line 'eof)) collect line))
|
|
217 |
(termslist (mapcar #'gcode-assign-parse lines)))
|
|
218 |
(progn
|
|
219 |
(setf (gvm-global-translate g) (find-gcode-translate termslist))
|
|
220 |
(format t "global offset set to ~a for x-centering~%" (gvm-global-translate g))
|
|
221 |
(loop for terms in termslist do (run-gcode-line terms g))
|
|
222 |
))))
|
|
223 |
|
|
224 |
(defun run-gcode-file (file &key (dummy-file nil))
|
|
225 |
(if (null dummy-file) (run-gcode-file-on-gvm (make-gvm) file)
|
|
226 |
(with-open-file (output dummy-file :direction :output :if-exists :supersede)
|
|
227 |
(run-gcode-file-on-gvm (make-gvm :dummy-file output) file))
|
|
228 |
))
|