git.haldean.org plotter / bef0fdf
plotterbots haldean 4 years ago
2 changed file(s) with 356 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+225
-0
cnc.lisp less more
0 (defpackage :so3-cnc
1 (:use :common-lisp)
2 (:export
3 :init
4 :get-pen
5 :set-pen-rel
6 :set-pen-abs
7 :disable-motors
8 :set-zero
9 :center-x
10 :center-y
11 :rel-x
12 :rel-y
13 :abs-x
14 :abs-y
15 :draw-circle
16 :start-buffer
17 :flush-buffer))
18
19 (in-package :so3-cnc)
20
21 (ql:quickload :alexandria)
22 (ql:quickload :cl-ppcre)
23 (ql:quickload :jsown)
24 (ql:quickload :parse-float)
25 (ql:quickload :s-http-client)
26
27 (setq tau (* 2 pi))
28
29 (setf *width* 0)
30 (setf *height* 0)
31 (setq *pen-states* '("up" "draw"))
32
33 (defun api-url (e) (format nil "http://saito:4242/~a" e))
34
35 (defun extract (d v) (cdr (assoc v d :test #'equal)))
36
37 (defun init ()
38 (let* ((settings (jsown:parse (s-http-client:do-http-request (api-url "v1/settings/bot"))))
39 (max-area (jsown:val settings "maxArea")))
40 (setf *width* (parse-integer (jsown:val max-area "width")))
41 (setf *height* (parse-integer (jsown:val max-area "height")))
42 (send-put-request (api-url "v1/settings/global")
43 (jsown:new-js ("invertAxis" (jsown:new-js ("x" :f) ("y" :f)))))
44 settings
45 ))
46
47 (defun center-x () (when (= *width* 0) (init)) (/ *width* 2))
48 (defun center-y () (when (= *width* 0) (init)) (/ *height* 2))
49 (defun rel-x (x) (when (= *width* 0) (init)) (* 100 (/ x *width*)))
50 (defun rel-y (y) (when (= *width* 0) (init)) (* 100 (/ y *height*)))
51 (defun abs-x (x) (when (= *width* 0) (init)) (/ (* x *width*) 100))
52 (defun abs-y (y) (when (= *width* 0) (init)) (/ (* y *height*) 100))
53
54 (defun get-pen-raw () (cdr (jsown:parse (s-http-client:do-http-request (api-url "v1/pen")))))
55
56 (defun get-pen ()
57 (let* ((pen-data (get-pen-raw))
58 (extract-xyz
59 (lambda (d) (list (extract d "x")
60 (extract d "y")
61 (position (extract d "state") *pen-states* :test #'equal)))))
62 (funcall extract-xyz pen-data)))
63
64 (defun send-put-request (url js)
65 (s-http-client:do-http-request
66 url :method :PUT :content (jsown:to-json js) :content-type "application/json; charset=UTF-8"))
67
68 (defun set-pen-rel (x y z &key (wait-time 0))
69 (send-put-request (api-url "v1/pen") (jsown:new-js ("state" (nth z *pen-states*))))
70 (send-put-request (api-url "v1/pen") (jsown:new-js ("x" x) ("y" y))))
71 (defun set-pen-abs (x y z &key (wait-time 0)) (set-pen-rel (rel-x x) (rel-y y) z :wait-time wait-time))
72
73 (defun disable-motors ()
74 (s-http-client:do-http-request (api-url "v1/motors") :method :DELETE))
75
76 (defun set-zero ()
77 (send-put-request (api-url "v1/motors") (jsown:new-js ("reset" 1))))
78
79 (defun draw-circle (cx cy r &key (seg 30))
80 (set-pen-abs cx (+ cy r) 0)
81 (set-pen-abs cx (+ cy r) 1)
82 (loop for theta from 0 to tau by (/ tau seg)
83 do (let ((x (+ cx (* r (sin theta))))
84 (y (+ cy (* r (cos theta)))))
85 (set-pen-abs x y 1)))
86 (set-pen-abs cx (+ cy r) 1)
87 )
88
89 (defun start-buffer ()
90 (send-put-request (api-url "v1/buffer") (jsown:new-js ("paused" t))))
91 (defun flush-buffer ()
92 (send-put-request (api-url "v1/buffer") (jsown:new-js ("paused" :f))))
93
94 (defun split-by-one-space (string)
95 (loop for i = 0 then (1+ j)
96 as j = (position #\Space string :start i)
97 collect (subseq string i j)
98 while j))
99
100 (defun gcode-remove-comments (line)
101 (if (equal (char line 0) #\#) ""
102 (string-trim '(#\Space #\Newline #\Linefeed #\Return)
103 (cl-ppcre:regex-replace-all "\\([^)]*\\)" line ""))))
104
105 (defun gcode-assign-parse (dirty-line)
106 (let ((line (gcode-remove-comments dirty-line)))
107 (if (= (length line) 0)
108 nil
109 (remove-if
110 (lambda (pair) (null (car pair)))
111 (mapcar (lambda (term)
112 (let* ((register (char term 0))
113 (reg (cond
114 ((equal register #\G) :G)
115 ((equal register #\X) :X)
116 ((equal register #\Y) :Y)
117 ((equal register #\Z) :Z)
118 ((equal register #\I) :I)
119 ((equal register #\J) :J)
120 (t nil)
121 )))
122 (if (null reg) (cons nil nil)
123 (cons reg
124 (funcall (if (eq reg :G) #'parse-integer #'parse-float:parse-float)
125 (subseq term 1))))))
126 (split-by-one-space (gcode-remove-comments line)))))))
127
128 (defstruct (gvm (:conc-name gvm-))
129 (mode 1 :type integer)
130 (i 0.0 :type float)
131 (j 0.0 :type float)
132 (x 0.0 :type float)
133 (y 0.0 :type float)
134 (z "unknown" :type string)
135 (dummy-file nil)
136 )
137
138 (setf *units-per-mm* 50)
139
140 (defun x-from-gcode (x-mm) (- 100 (rel-x (* x-mm *units-per-mm*))))
141 (defun y-from-gcode (y-mm) (rel-y (* y-mm *units-per-mm*)))
142
143 (defun theta-steps-ccw (start end)
144 (if (< end start)
145 (theta-steps-ccw start (+ end tau))
146 (loop for theta from start to end
147 by (min (/ (- end start) 4) (* tau (/ 15 360)))
148 collect theta)))
149 (defun theta-steps-cw (start end)
150 (reverse (theta-steps-ccw end start)))
151
152 (defun theta-steps (mode start end)
153 (funcall (alexandria:switch (mode)
154 (2 #'theta-steps-cw)
155 (3 #'theta-steps-ccw)) start end))
156
157 (defun run-gcode-circle (g x y i j old-x old-y)
158 (let* ((cx (+ old-x i))
159 (cy (+ old-y j))
160 (r (sqrt (+ (expt i 2) (expt j 2))))
161 (r-end (sqrt (+ (expt (- x cx) 2) (expt (- y cy) 2))))
162 (ni (- cx x))
163 (nj (- cy y))
164 (theta-end (atan (- nj) (- ni)))
165 (theta-start (atan (- j) (- i)))
166 )
167 (unless (> (abs (- r-end r)) 0.001)
168 (loop for theta in (theta-steps (gvm-mode g) theta-start theta-end)
169 do (let ((tx (+ cx (* r (cos theta))))
170 (ty (+ cy (* r (sin theta)))))
171 (run-gcode-linear g tx ty)))
172 (run-gcode-linear g x y))))
173
174 (defun run-gcode-linear (g x y)
175 (if (null (gvm-dummy-file g))
176 (send-put-request
177 (api-url "v1/pen")
178 (jsown:new-js ("x" (x-from-gcode x)) ("y" (y-from-gcode y)) ("ignoreTimeout" 1)))
179 (format (gvm-dummy-file g) "~f,~f~%" (x-from-gcode x) (y-from-gcode y))
180 ))
181
182 (defun run-gcode-movement (g old-x old-y)
183 (alexandria:switch ((gvm-mode g))
184 (0 (run-gcode-linear g (gvm-x g) (gvm-y g)))
185 (1 (run-gcode-linear g (gvm-x g) (gvm-y g)))
186 (2 (run-gcode-circle g (gvm-x g) (gvm-y g) (gvm-i g) (gvm-j g) old-x old-y))
187 (3 (run-gcode-circle g (gvm-x g) (gvm-y g) (gvm-i g) (gvm-j g) old-x old-y))
188 ))
189
190 (defun update-state-from-gcode (g state)
191 (let ((new-state-name (nth (if (> state 0) 0 1) *pen-states*)))
192 (unless (or (not (null (gvm-dummy-file g))) (eq new-state-name (gvm-z g)))
193 (send-put-request (api-url "v1/pen") (jsown:new-js ("state" new-state-name)))
194 (sleep 0.1))))
195
196 (defun run-gcode-line (line g)
197 (let* ((terms (gcode-assign-parse line))
198 (new-mode (assoc :G terms))
199 (new-state (assoc :Z terms))
200 (new-x (assoc :X terms))
201 (new-y (assoc :Y terms))
202 (new-i (assoc :I terms))
203 (new-j (assoc :J terms))
204 (old-x (gvm-x g))
205 (old-y (gvm-y g)))
206 (unless (null new-mode) (setf (gvm-mode g) (cdr new-mode)))
207 (unless (null new-state) (update-state-from-gcode g (cdr new-state)))
208 (unless (null new-x) (setf (gvm-x g) (cdr new-x)))
209 (unless (null new-y) (setf (gvm-y g) (cdr new-y)))
210 (unless (null new-i) (setf (gvm-i g) (cdr new-i)))
211 (unless (null new-j) (setf (gvm-j g) (cdr new-j)))
212 (run-gcode-movement g old-x old-y)))
213
214 (defun run-gcode-file-on-gvm (g fname)
215 (with-open-file (stream fname :direction :input)
216 (do ((l (read-line stream) (read-line stream nil 'eof)))
217 ((eq l 'eof) nil)
218 (run-gcode-line l g))))
219
220 (defun run-gcode-file (file &key (dummy-file nil))
221 (if (null dummy-file) (run-gcode-file-on-gvm (make-gvm) file)
222 (with-open-file (output dummy-file :direction :output :if-exists :supersede)
223 (run-gcode-file-on-gvm (make-gvm :dummy-file output) file))
224 ))
+131
-0
plot.lisp less more
0 (ql:quickload :cl-svg)
1 (ql:quickload :cl-randist)
2
3 (setf w 300)
4 (setf h 300)
5 (setf c-x (/ w 2))
6 (setf c-y (/ h 2))
7
8 (setf iso-x-delta 20)
9 (setf iso-y-delta 6)
10
11 (setf bg "#124")
12 (setf fg "#FF0")
13
14 (setf n-x-dots (floor (/ w iso-x-delta)))
15 (setf n-y-dots (floor (/ h iso-y-delta)))
16 (setf xdlo (+ 1 (ceiling (- (/ n-x-dots 3)))))
17 (setf xdhi (floor (/ n-x-dots 3)))
18 (setf ydlo (+ 2 (ceiling (- (/ n-y-dots 4)))))
19 (setf ydhi (- (floor (/ n-y-dots 4)) 1))
20
21 (defun line (scene p1 p2 ox oy color)
22 (let ((x1 (first p1)) (y1 (second p1))
23 (x2 (first p2)) (y2 (second p2)))
24 (cl-svg:draw
25 scene
26 (:line :x1 (+ x1 ox) :y1 (+ y1 oy) :x2 (+ x2 ox) :y2 (+ y2 oy))
27 :stroke color :stroke-width 1 :stroke-linecap :round)))
28
29 (defun line-end (l)
30 (let* ((i (caar l))
31 (j (cadar l))
32 (d (second l))
33 (dx (cond
34 ((= d 0) 0)
35 ((= d 1) 1)
36 ((= d 2) 1)
37 ((= d 3) 0)
38 ((= d 4) -1)
39 ((= d 5) -1)))
40 (dy (cond
41 ((= d 0) -1)
42 ((= d 1) 0)
43 ((= d 2) 0)
44 ((= d 3) 1)
45 ((= d 4) 0)
46 ((= d 5) 0)
47 )))
48 (list (+ i dx) (+ j dy))))
49
50 (defun gline (scene l &optional (ox 0) (oy 0) (c fg))
51 (let* ((le (line-end l))
52 (p1 (iso-grid (caar l) (cadar l)))
53 (p2 (iso-grid (first le) (second le))))
54 (line scene p1 p2 ox oy c)))
55
56 (defun dot (scene d)
57 (let ((p (iso-grid (first d) (second d))))
58 (let ((x (first p)) (y (second p)))
59 (cl-svg:draw
60 scene
61 (:circle :cx x :cy y :r 2.5)
62 :stroke fg :stroke-width 1 :fill bg))))
63
64 (defun iso-grid (x y)
65 (let ((x_ (* iso-x-delta x))
66 (y_ (* iso-y-delta (+ (* 2 y) (if (= (mod x 2) 0) 1 0)))))
67 (list (+ (/ w 2) x_) (+ (/ h 2) y_))))
68
69 (defun dist (p1 p2)
70 (sqrt (+ (expt (- (first p1) (first p2)) 2)
71 (expt (- (second p1) (second p2)) 2))))
72
73 (defun nearest-on-grid (x y)
74 (let* ((i (round (/ (- x (/ w 2)) iso-x-delta)))
75 (tst (loop for j from ydlo to ydhi
76 collect (list (dist (iso-grid i j) (list x y)) (list i j)))))
77 (second (reduce (lambda (a b) (if (< (first a) (first b)) a b)) tst))))
78
79 (defun random-point-normal ()
80 (let* ((angle (random (* 2 pi)))
81 (radius (randist:random-normal-ziggurat (/ (min w h) 3.0d0) 60.0d0)))
82 (nearest-on-grid
83 (+ c-x (* radius (cos angle)))
84 (+ c-y (* radius (sin angle))))))
85 (defun random-point-uniform ()
86 (list (+ xdlo (random (- xdhi xdlo)))
87 (+ ydlo (random (- ydhi ydlo)))))
88 (defun random-point () (random-point-normal))
89
90 (defun dedupe (x &optional (accum '()))
91 (cond
92 ((null x) accum)
93 ((member (car x) accum :test #'equal) (dedupe (cdr x) accum))
94 (t (dedupe (cdr x) (cons (car x) accum)))
95 ))
96
97 (defun gen-dots ()
98 (dedupe (loop for i from 0 to 200 collect (random-point))))
99
100 (defun random-choice (lst) (nth (random (length lst)) lst))
101
102 (defun random-line-point (dots lines)
103 (let ((line-ends (mapcar #'line-end lines)))
104 (cond
105 ((and (not (null line-ends)) (< (random 1.0) 0.4)) (random-choice line-ends))
106 ((< (random 1.0) 0.7) (random-choice dots))
107 (t (random-point))
108 )))
109
110 (defun gen-lines (dots n attach)
111 (dedupe
112 (reduce
113 (lambda (all ign) (cons (list (random-line-point dots all) (random 6)) all))
114 (loop for i from 0 to n collect i)
115 :initial-value nil)))
116
117 (defun gen (scene &key (use-dots t) (use-lines t))
118 (let* ((dots (gen-dots))
119 (root (cl-svg:make-group scene () nil)))
120 (when use-lines (mapcar (lambda (l) (gline root l)) (gen-lines dots 200 nil)))
121 (when use-dots (mapcar (lambda (d) (dot root d)) dots))
122 root
123 ))
124
125 (let ((scene (cl-svg:make-svg-toplevel 'cl-svg:svg-1.1-toplevel :height h :width w)))
126 ; draw background
127 (cl-svg:draw scene (:rect :x 0 :y 0 :width w :height h) :fill bg)
128 (gen scene)
129 (with-open-file (s #p"test.svg" :direction :output :if-exists :supersede)
130 (cl-svg:stream-out s scene)))