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

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