1 (in-package #:clnl-interface)
3 (defvar *turtle-lists* nil)
4 (defvar *patch-list* nil)
6 (defvar *glut-window-opened* nil)
7 (defvar *dimensions* nil)
9 ; For now, shapes can live in here
11 ; * name <like default>
12 ; * rotatable (equal to "true" if yes)
14 ; then after, the elements are like so:
16 ; filled == filled in (always for now, ha)
17 ; marked == use the turtle color instead of a color
18 ; polygon -> Polygon <color> <filled> <marked> <alternating x y coords>
19 ; circle -> Circle <color> <filled> <marked> <left> <top> <diameter> ; here, the left and top are NOT the center
20 ; rectangle -> Rectangle <color> <filled> <marked> <left> <top> <right> <bottom>
22 ; then ends with an empty string
24 (defun parse-circle (sections)
26 :color (parse-integer (car sections))
27 :filled (string= (nth 1 sections) "true")
28 :marked (string= (nth 2 sections) "true")
29 :left (parse-integer (nth 3 sections))
30 :top (parse-integer (nth 4 sections))
31 :diameter (parse-integer (nth 5 sections))))
33 (defun parse-rectangle (sections)
36 :color (parse-integer (car sections))
37 :filled (string= (nth 1 sections) "true")
38 :marked (string= (nth 2 sections) "true")
39 :left (parse-integer (nth 3 sections))
40 :top (parse-integer (nth 4 sections))
41 :right (parse-integer (nth 5 sections))
42 :bottom (parse-integer (nth 6 sections))))
44 (defun parse-polygon (sections)
46 ((parse-points (sections)
49 (list (parse-integer (car sections)) (parse-integer (cadr sections)))
50 (parse-points (cddr sections))))))
53 :color (parse-integer (car sections))
54 :filled (string= (nth 1 sections) "true")
55 :marked (string= (nth 2 sections) "true")
56 :coords (parse-points (nthcdr 3 sections)))))
58 (defun parse-shape (str)
60 ((parse-element (line)
62 ((sections (cl-ppcre:split " " line)))
64 ((string= (car sections) "Circle") (parse-circle (cdr sections)))
65 ((string= (car sections) "Rectangle") (parse-rectangle (cdr sections)))
66 ((string= (car sections) "Polygon") (parse-polygon (cdr sections))))))
69 ((line (read-line str nil)))
70 (when (and line (string/= line ""))
75 ((next-line (read-line str nil)))
79 :rotatable (string= "true" (read-line str))
80 :rgb (read-line str) ; this is ignored for now, I think
81 :elements (parse-elements))))))
83 ; Clipping ears algorithm. This can be slow due to the fact that it will only be run once.
84 (defun triangulate (points &optional (ccw :unknown))
87 (< 0 (- (* (- (car y) (car x)) (- (cadr z) (cadr x))) (* (- (car z) (car x)) (- (cadr y) (cadr x))))))
88 (tri-is-concave (x y z) (if (tri-is-ccw x y z) (not ccw) ccw))
89 (poly-is-ccw (points &optional cur-tri)
92 (poly-is-ccw (append points (list (car points))) (list (car (last points)) (car points) (cadr points))))
93 ((eql (length points) 2)
94 (apply #'tri-is-ccw cur-tri))
96 (< (car (cadr points)) (car (cadr cur-tri)))
98 (= (car (cadr points)) (car (cadr cur-tri)))
99 (< (cadr (cadr points)) (cadr (cadr cur-tri)))))
100 (poly-is-ccw (cdr points) (subseq points 0 3)))
101 (t (poly-is-ccw (cdr points) cur-tri))))
102 (point-in-tri (x y z p)
103 ; Barycentric system test
105 ((denom (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z)))))
106 (a (/ (+ (* (- (cadr y) (cadr z)) (- (car p) (car z))) (* (- (car z) (car y)) (- (cadr p) (cadr z)))) denom))
107 (b (/ (+ (* (- (cadr z) (cadr x)) (- (car p) (car z))) (* (- (car x) (car z)) (- (cadr p) (cadr z)))) denom))
109 (and (<= 0 a 1) (<= 0 b 1) (<= 0 c 1))))
110 (no-points-in-tri (tri points)
111 (every (lambda (point) (not (point-in-tri (car tri) (cadr tri) (caddr tri) point))) points))
112 (tri-is-actually-line (x y z)
113 (zerop (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z)))))))
115 ((not (find :end points)) (triangulate (append points (list :end)) ccw))
116 ((< (length points) 4) (error "Must have at least 3 points..."))
117 ((= (length points) 4) (list (remove :end points)))
118 ((eql ccw :unknown) (triangulate points (poly-is-ccw (remove :end points))))
119 ((eql :end (car points)) (error "This polygon may not be triangulateable"))
122 ((endless (remove :end points))
123 (tri (subseq endless 0 3)))
125 ((apply #'tri-is-actually-line tri)
126 (triangulate (cons (car endless) (cddr endless)) ccw))
127 ((apply #'tri-is-concave tri)
128 (triangulate (append (cdr points) (list (car points))) ccw))
129 ((no-points-in-tri tri (nthcdr 3 endless))
130 (cons tri (triangulate (cons (car endless) (cddr endless)) ccw)))
131 (t (triangulate (append (cdr points) (list (car points))) ccw))))))))
133 (defun element->gl-list (shape)
137 (gl:begin :triangles)
139 (lambda (point) (gl:vertex (car point) (cadr point) 0))
140 (apply #'append (triangulate (getf (cdr shape) :coords))))
144 (gl:begin :triangles)
146 (lambda (point) (gl:vertex (car point) (cadr point) 0))
150 (list (getf (cdr shape) :left) (getf (cdr shape) :top))
151 (list (getf (cdr shape) :right) (getf (cdr shape) :top))
152 (list (getf (cdr shape) :right) (getf (cdr shape) :bottom))
153 (list (getf (cdr shape) :left) (getf (cdr shape) :bottom))))))
157 (gl:begin :triangles)
159 (lambda (point) (gl:vertex (car point) (cadr point) 0))
164 :with c := (strictmath:cos (strictmath:to-radians 1))
165 :with s := (strictmath:sin (strictmath:to-radians 1))
166 :with r := (/ (getf (cdr shape) :diameter) 2)
167 :with left := (getf (cdr shape) :left)
168 :with top := (getf (cdr shape) :top)
170 :for x := r :then (- (* c x) (* s y))
171 :for y := 0 :then (+ (* s n) (* c y))
172 :collect (list (+ (+ x left) r) (+ (+ y top) r))))))
175 (defun parse-shapes (str)
177 ((shape (parse-shape str)))
178 (when shape (cons shape (parse-shapes str)))))
180 (defun default-shapes ()
181 (with-open-file (str "resources/defaultshapes") (parse-shapes str)))
184 '((140 140 140) ; gray (5)
185 (215 48 39) ; red (15)
186 (241 105 19) ; orange (25)
187 (156 109 70) ; brown (35)
188 (237 237 47) ; yellow (45)
189 (87 176 58) ; green (55)
190 (42 209 57) ; lime (65)
191 (27 158 119) ; turquoise (75)
192 (82 196 196) ; cyan (85)
193 (43 140 190) ; sky (95)
194 (50 92 168) ; blue (105)
195 (123 78 163) ; violet (115)
196 (166 25 105) ; magenta (125)
197 (224 126 149) ; pink (135)
199 (255 255 255))) ; white
201 (defun nl-color->rgb (color)
203 ((step (+ (/ (- (mod (floor (* color 10)) 100) 50) 50.48) 0.012)))
205 (lambda (x) (/ (+ x (floor (* (if (< step 0d0) x (- 255 x)) step))) 255))
206 (nth (floor color 10) *colors*))))
208 (defun render-scene ()
209 (gl:clear :color-buffer-bit :depth-buffer-bit)
210 (gl:matrix-mode :projection)
213 (floor (* (- (getf *dimensions* :xmin) 0.5) (patch-size)))
214 (floor (* (+ (getf *dimensions* :xmax) 0.5) (patch-size)))
215 (floor (* (- (getf *dimensions* :ymin) 0.5) (patch-size)))
216 (floor (* (+ (getf *dimensions* :ymax) 0.5) (patch-size)))
218 (gl:matrix-mode :modelview)
220 (destructuring-bind (turtles patches) (clnl-nvm:current-state)
224 ((color (nl-color->rgb (getf patch :color))))
225 (gl:color (car color) (cadr color) (caddr color)))
226 (gl:with-pushed-matrix
227 (gl:translate (* (getf patch :xcor) (patch-size)) (* (getf patch :ycor) (patch-size)) 0)
228 (gl:translate (floor (* -.5d0 (patch-size))) (floor (* -.5d0 (patch-size))) 0)
229 (gl:scale (patch-size) (patch-size) 1)
230 (gl:call-list *patch-list*)))
235 ((color (nl-color->rgb (getf turtle :color))))
236 (gl:color (car color) (cadr color) (caddr color)))
238 (lambda (x-modification y-modification)
239 (gl:with-pushed-matrix
240 (gl:translate (* (getf turtle :xcor) (patch-size)) (* (getf turtle :ycor) (patch-size)) 0)
241 (gl:translate x-modification y-modification 0)
243 ((turtle-list (find (getf turtle :shape) *turtle-lists* :test #'string= :key #'car)))
245 (when (second turtle-list)
246 (gl:rotate (getf turtle :heading) 0 0 -1))
247 (gl:scale (patch-size) (patch-size) 1)
248 (gl:scale (getf turtle :size) (getf turtle :size) 1)
249 (gl:call-list (third turtle-list))))))
250 (list 0 (1- (world-width-in-pixels)) (- (1- (world-width-in-pixels))) 0 0)
251 (list 0 0 0 (1- (world-height-in-pixels)) (- (1- (world-height-in-pixels))))))
257 (cl-glut:swap-buffers))
260 (cl-glut:post-redisplay))
263 (sb-ext:exit :abort t))
265 (defun reshape (width height)
266 (when (and (/= 0 width) (/= 0 height))
267 (gl:viewport 0 0 width height)))
269 (cffi:defcallback display :void () (display))
270 (cffi:defcallback idle :void () (idle))
271 (cffi:defcallback close-func :void () (close-func))
272 (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height))
274 (defun set-turtle-lists ()
283 (getf shape :rotatable)
285 (gl:with-new-list ((third turtle-list) :compile)
286 (gl:rotate 180d0 0d0 0d0 -1d0)
287 (gl:scale (/ 1d0 300d0) (/ 1d0 300d0) 1)
288 (gl:translate -150d0 -150d0 -0.0d0)
289 (mapcar #'element->gl-list (getf shape :elements)))
293 (defun set-patch-list ()
294 (setf *patch-list* (gl:gen-lists 1))
295 (gl:with-new-list (*patch-list* :compile)
303 (defun initialize (&key dims)
304 "INITIALIZE &key DIMS => RESULT
306 DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
308 ARGUMENTS AND VALUES:
311 XMIN: An integer representing the minimum patch coord in X
312 XMAX: An integer representing the maximum patch coord in X
313 YMIN: An integer representing the minimum patch coord in Y
314 YMAX: An integer representing the maximum patch coord in Y
315 PATCH-SIZE: A double representing the size of the patches in pixels
319 This is where the initialization of the interface that sits behind
320 the interface lives. From here, one can go into headless or running
321 mode, but for certain things this interface will still need to act,
322 and also allows for bringing up and taking down of visual elements."
323 (setf *dimensions* dims)
324 (when *glut-window-opened*
325 (cl-glut:reshape-window (world-width-in-pixels) (world-height-in-pixels))))
330 ARGUMENTS AND VALUES:
332 RESULT: undefined, should never get here
336 RUN runs the view in an external window.
338 This should be run inside another thread as it starts the glut main-loop.
339 Closing this window will then cause the entire program to terminate."
340 ; I do this because I don't know who or what in the many layers
341 ; is causing the floating point errors, but I definitely don't
342 ; want to investigate until simply ignoring them becomes a problem.
343 (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow)
345 (cl-glut:init-window-size
346 (world-width-in-pixels)
347 (world-height-in-pixels))
348 (cl-glut:init-display-mode :double :rgba)
349 (cl-glut:create-window "CLNL Test Window")
350 (setf *glut-window-opened* t)
351 (gl:clear-color 0 0 0 1)
352 (cl-glut:display-func (cffi:get-callback 'display))
353 (glut:reshape-func (cffi:callback reshape))
354 (cl-glut:idle-func (cffi:get-callback 'idle))
355 (cl-glut:close-func (cffi:get-callback 'close-func))
358 (cl-glut:main-loop)))
360 (defun patch-size () (getf *dimensions* :patch-size))
362 (defun world-width-in-pixels ()
363 (floor (* (patch-size) (1+ (- (getf *dimensions* :xmax) (getf *dimensions* :xmin))))))
365 (defun world-height-in-pixels ()
366 (floor (* (patch-size) (1+ (- (getf *dimensions* :ymax) (getf *dimensions* :ymin))))))
368 (defun export-view ()
369 "EXPORT-VIEW => IMAGE-DATA
371 ARGUMENTS AND VALUES:
373 IMAGE-DATA: A vector, pixel data as returned by opengls readPixels
377 EXPORT-VIEW returns the current view in raw data of RGBA pixels.
379 Each pixel is made up of 4 bytes of data, which an be walked over. The number
380 of pixels is the current width x height. Converting to some other image format
381 is a matter of pulling that information out and putting it into whatever format
384 This requires opengl to run, but can be used with xvfb in a headless mode."
385 (sb-int:with-float-traps-masked (:invalid)
386 (when (not *glut-window-opened*)
388 (cl-glut:init-window-size 1 1)
389 (cl-glut:create-window "CLNL Test Window")
390 (gl:clear-color 0 0 0 1)
393 (setf *glut-window-opened* t))
395 ((fbo (first (gl:gen-framebuffers 1)))
396 (render-buf (first (gl:gen-renderbuffers 1)))
398 ; (floor (* (patch-size) (1+ (-
399 ; (getf *dimensions* :ymax)
400 ; (getf *dimensions* :ymin))))))
402 ; (floor (* (patch-size) (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin))))))
403 ; (floor (* (patch-size) (1+ (-
404 ; (getf *dimensions* :xmax)
405 ; (getf *dimensions* :xmin)))))
406 (width (world-width-in-pixels)) ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
407 (height (world-height-in-pixels)))
408 (gl:bind-framebuffer :framebuffer fbo)
409 (gl:bind-renderbuffer :renderbuffer render-buf)
410 (gl:renderbuffer-storage :renderbuffer :rgba8 width height)
411 (gl:framebuffer-renderbuffer :draw-framebuffer :color-attachment0 :renderbuffer render-buf)
412 (gl:viewport 0 0 width height)
414 (gl:read-pixels 0 0 width height :rgba :unsigned-byte))))