Commit bab38b1238c1e4b62e9371685973ee6bfda1a2c6 - plotter

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	))

+131

-131

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)))
	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)))