f59a242fcabd90c8e4f65903cb975bb08f3b0978
[clnl] / src / main / interface.lisp
1 (in-package #:clnl-interface)
2
3 (defvar *patch-size* 13d0)
4
5 (defvar *turtle-list* nil)
6
7 ; It may be useful to keep windows around
8 (defvar *glut-window-opened* nil)
9 (defvar *model* 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 :abort t))
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 initialize (model)
88  "INITIALIZE MODEL => RESULT
89
90 ARGUMENTS AND VALUES:
91
92   MODEL: A clnl-model:model to use to initialize the interface
93   RESULT: undefined
94
95 DESCRIPTION:
96
97   This is where the initialization of the interface that sits behind
98   the interface lives.  From here, one can go into headless or running
99   mode, but for certain things this interface will still need to act,
100   and also allows for bringing up and taking down of visual elements."
101  (setf *model* model))
102
103 (defun run ()
104  "RUN => RESULT
105
106 ARGUMENTS AND VALUES:
107
108   RESULT: undefined, should never get here
109
110 DESCRIPTION:
111
112   RUN runs the view in an external window.
113
114   This should be run inside another thread as it starts the glut main-loop.
115   Closing this window will then cause the entire program to terminate."
116  ; I do this because I don't know who or what in the many layers
117  ; is causing the floating point errors, but I definitely don't
118  ; want to investigate until simply ignoring them becomes a problem.
119  (sb-int:with-float-traps-masked (:invalid)
120   (cl-glut:init)
121   (cl-glut:init-window-size
122    (floor
123     (* *patch-size*
124      (1+ (- (getf (clnl-model:world-dimensions *model*) :xmax) (getf (clnl-model:world-dimensions *model*) :xmin)))))
125    (floor
126     (* *patch-size*
127      (1+ (- (getf (clnl-model:world-dimensions *model*) :ymax) (getf (clnl-model:world-dimensions *model*) :ymin))))))
128   (cl-glut:init-display-mode :double :rgba)
129   (cl-glut:create-window "CLNL Test Window")
130   (setf *glut-window-opened* t)
131   (gl:clear-color 0 0 0 1)
132   (cl-glut:display-func (cffi:get-callback 'display))
133   (glut:reshape-func (cffi:callback reshape))
134   (cl-glut:idle-func (cffi:get-callback 'idle))
135   (cl-glut:close-func (cffi:get-callback 'close-func))
136   (set-turtle-list)
137   (cl-glut:main-loop)))
138
139 (defun export-view ()
140  "EXPORT-VIEW => IMAGE-DATA
141
142 ARGUMENTS AND VALUES:
143
144   IMAGE-DATA: A vector, pixel data as returned by opengls readPixels
145
146 DESCRIPTION:
147
148   EXPORT-VIEW returns the current view in raw data of RGBA pixels.
149
150   Each pixel is made up of 4 bytes of data, which an be walked over.  The number
151   of pixels is the current width x height.  Converting to some other image format
152   is a matter of pulling that information out and putting it into whatever format
153   you like.
154
155   This requires opengl to run, but can be used with xvfb in a headless mode."
156  (sb-int:with-float-traps-masked (:invalid)
157   (when (not *glut-window-opened*)
158    (cl-glut:init)
159    (cl-glut:init-window-size 1 1)
160    (cl-glut:create-window "CLNL Test Window")
161    (gl:clear-color 0 0 0 1)
162    (set-turtle-list)
163    (setf *glut-window-opened* t))
164   (let
165    ((fbo (first (gl:gen-framebuffers 1)))
166     (render-buf (first (gl:gen-renderbuffers 1)))
167    ;(width
168    ; (floor (* *patch-size* (1+ (-
169    ;                             (getf (clnl-model:world-dimensions *model*) :ymax)
170    ;                             (getf (clnl-model:world-dimensions *model*) :ymin))))))
171    ;(height
172    ; (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin))))))
173    ; (floor (* *patch-size* (1+ (-
174    ;                            (getf (clnl-model:world-dimensions *model*) :xmax)
175    ;                            (getf (clnl-model:world-dimensions *model*) :xmin)))))
176     (width 143)  ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
177     (height 143))
178    (gl:bind-framebuffer :framebuffer fbo)
179    (gl:bind-renderbuffer :renderbuffer render-buf)
180    (gl:renderbuffer-storage :renderbuffer :rgba8 width height)
181    (gl:framebuffer-renderbuffer :draw-framebuffer :color-attachment0 :renderbuffer render-buf)
182    (gl:viewport 0 0 width height)
183    (render-scene)
184    (gl:read-pixels 0 0 width height :rgba :unsigned-byte))))