92f292ab4a00b3859bbc6207f4b0a94e4611e0a2
[clnl] / src / main / interface.lisp
1 (in-package #:clnl-interface)
2
3 (defvar *patch-size* 13d0)
4 (defvar *world-dims* '(:xmin -5 :xmax 5 :ymin -5 :ymax 5))
5
6 (defvar *turtle-list* nil)
7
8 ; It may be useful to keep windows around
9 (defvar *glut-window-opened* nil)
10
11 (defvar *colors*
12  '((140 140 140) ; gray       (5)
13    (215 48 39) ; red       (15)
14    (241 105 19) ; orange    (25)
15    (156 109 70) ; brown     (35)
16    (237 237 47) ; yellow    (45)
17    (87 176 58) ; green     (55)
18    (42 209 57) ; lime      (65)
19    (27 158 119) ; turquoise (75)
20    (82 196 196) ; cyan      (85)
21    (43 140 190) ; sky       (95)
22    (50 92 168) ; blue     (105)
23    (123 78 163) ; violet   (115)
24    (166 25 105) ; magenta  (125)
25    (224 126 149) ; pink     (135)
26    (0 0 0) ; black
27    (255 255 255))) ; white
28
29 (defun nl-color->rgb (color)
30  (let*
31   ((step (+ (/ (- (mod (floor (* color 10)) 100) 50) 50.48) 0.012)))
32   (mapcar
33    (lambda (x) (/ (+ x (floor (* (if (< step 0d0) x (- 255 x)) step))) 255))
34    (nth (floor color 10) *colors*))))
35
36 (defun render-scene ()
37  (gl:clear :color-buffer-bit :depth-buffer-bit)
38  (gl:matrix-mode :projection)
39  (gl:load-identity)
40  (gl:ortho -71 71 -71 71 1 5000)
41  (gl:matrix-mode :modelview)
42  (gl:load-identity)
43  (mapcar
44   (lambda (turtle)
45    (let
46     ((color (nl-color->rgb (getf turtle :color))))
47     (gl:color (car color) (cadr color) (caddr color)))
48    (gl:with-pushed-matrix
49     (gl:translate (* (getf turtle :xcor) *patch-size*) (* (getf turtle :ycor) *patch-size*) 0)
50     (gl:rotate (getf turtle :heading) 0 0 -1)
51     (gl:call-list *turtle-list*)))
52   (clnl-nvm:current-state))
53  (gl:flush))
54
55 (defun display ()
56  (render-scene)
57  (cl-glut:swap-buffers))
58
59 (defun idle ()
60  (cl-glut:post-redisplay))
61
62 (defun close-func ()
63  (sb-ext:exit))
64
65 (defun reshape (width height)
66  (when (and (/= 0 width) (/= 0 height))
67   (gl:viewport 0 0 width height)))
68
69 (cffi:defcallback display :void () (display))
70 (cffi:defcallback idle :void () (idle))
71 (cffi:defcallback close-func :void () (close-func))
72 (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height))
73
74 (defun set-turtle-list ()
75  (setf *turtle-list* (gl:gen-lists 1))
76  (gl:with-new-list (*turtle-list* :compile)
77   (gl:rotate 180 0 0 -1)
78   (gl:scale (* (/ 1d0 300d0) 13) (* (/ 1d0 300d0) 13) 1)
79   (gl:translate -150 -150 -4.0)
80   (gl:begin :polygon)
81   (gl:vertex 150 5 0)
82   (gl:vertex 40 250 0)
83   (gl:vertex 150 205 0)
84   (gl:vertex 260 250 0)
85   (gl:end)))
86
87 (defun run ()
88  "RUN => RESULT
89
90 ARGUMENTS AND VALUES:
91
92   RESULT: undefined, should never get here
93
94 DESCRIPTION:
95
96   RUN runs the view in an external window.
97
98   This should be run inside another thread as it starts the glut main-loop.
99   Closing this window will then cause the entire program to terminate."
100  ; I do this because I don't know who or what in the many layers
101  ; is causing the floating point errors, but I definitely don't
102  ; want to investigate until simply ignoring them becomes a problem.
103  (sb-int:with-float-traps-masked (:invalid)
104   (cl-glut:init)
105   (gl:clear-color 0 0 0 1)
106   (cl-glut:init-window-size
107    (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin)))))
108    (floor (* *patch-size* (1+ (- (getf *world-dims* :ymax) (getf *world-dims* :ymin))))))
109   (setf *glut-window-opened* t)
110   (cl-glut:create-window "CLNL Test Window")
111   (cl-glut:init-display-mode :double :rgba)
112   (cl-glut:display-func (cffi:get-callback 'display))
113   (glut:reshape-func (cffi:callback reshape))
114   (cl-glut:idle-func (cffi:get-callback 'idle))
115   (cl-glut:close-func (cffi:get-callback 'close-func))
116   (set-turtle-list)
117   (cl-glut:main-loop)))
118
119 (defun export-view ()
120  "EXPORT-VIEW => IMAGE-DATA
121
122 ARGUMENTS AND VALUES:
123
124   IMAGE-DATA: A vector, pixel data as returned by opengls readPixels
125
126 DESCRIPTION:
127
128   EXPORT-VIEW returns the current view in raw data of RGBA pixels.
129
130   Each pixel is made up of 4 bytes of data, which an be walked over.  The number
131   of pixels is the current width x height.  Converting to some other image format
132   is a matter of pulling that information out and putting it into whatever format
133   you like.
134
135   This requires opengl to run, but can be used with xvfb in a headless mode."
136  (sb-int:with-float-traps-masked (:invalid)
137   (when (not *glut-window-opened*)
138    (cl-glut:init)
139    (gl:clear-color 0 0 0 1)
140    (cl-glut:init-window-size 1 1)
141    (cl-glut:create-window "CLNL Test Window")
142    (set-turtle-list)
143    (setf *glut-window-opened* t))
144   (let
145    ((fbo (first (gl:gen-framebuffers 1)))
146     (render-buf (first (gl:gen-renderbuffers 1)))
147    ;(width (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin))))))
148    ;(height (floor (* *patch-size* (1+ (- (getf *world-dims* :ymax) (getf *world-dims* :ymin))))))
149     (width 143)  ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
150     (height 143))
151    (gl:bind-framebuffer :framebuffer fbo)
152    (gl:bind-renderbuffer :renderbuffer render-buf)
153    (gl:renderbuffer-storage :renderbuffer :rgba8 width height)
154    (gl:framebuffer-renderbuffer :draw-framebuffer :color-attachment0 :renderbuffer render-buf)
155    (gl:viewport 0 0 width height)
156    (render-scene)
157    (gl:read-pixels 0 0 width height :rgba :unsigned-byte))))