code.consxy.com Git - clnl/blob - src/main/interface.lisp

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