git.haldean.org plotter / bab38b1
i have no idea what is happening Haldean Brown 2 years ago
2 changed file(s) with 360 addition(s) and 358 deletion(s). Raw diff Collapse all Expand all
+229
-227
cnc.lisp less more
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 ))
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)))
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)))