code.consxy.com Git - clnl/blob - 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 (car clnl-nvm::*turtles*)
   8
   9 ; It may be useful to keep windows around
  10 (defvar *glut-window-opened* 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  (mapcar
  45   (lambda (turtle)
  46    (let
  47     ((color (nl-color->rgb (clnl-nvm::turtle-color turtle))))
  48     (gl:color (car color) (cadr color) (caddr color)))
  49    (gl:with-pushed-matrix
  50     (gl:translate (* (clnl-nvm::turtle-xcor turtle) *patch-size*) (* (clnl-nvm::turtle-ycor turtle) *patch-size*) 0)
  51     (gl:rotate (clnl-nvm::turtle-heading turtle) 0 0 -1)
  52     (gl:call-list *turtle-list*)))
  53   clnl-nvm::*turtles*)
  54  (gl:flush))
  55
  56 (defun display ()
  57  (render-scene)
  58  (cl-glut:swap-buffers))
  59
  60 (defun idle ()
  61  (cl-glut:post-redisplay))
  62
  63 (defun close-func ()
  64  (sb-ext:exit))
  65
  66 (defun reshape (width height)
  67  (when (and (/= 0 width) (/= 0 height))
  68   (gl:viewport 0 0 width height)))
  69
  70 (cffi:defcallback display :void () (display))
  71 (cffi:defcallback idle :void () (idle))
  72 (cffi:defcallback close-func :void () (close-func))
  73 (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height))
  74
  75 (defun set-turtle-list ()
  76  (setf *turtle-list* (gl:gen-lists 1))
  77  (gl:with-new-list (*turtle-list* :compile)
  78   (gl:rotate 180 0 0 -1)
  79   (gl:scale (* (/ 1d0 300d0) 13) (* (/ 1d0 300d0) 13) 1)
  80   (gl:translate -150 -150 -4.0)
  81   (gl:begin :polygon)
  82   (gl:vertex 150 5 0)
  83   (gl:vertex 40 250 0)
  84   (gl:vertex 150 205 0)
  85   (gl:vertex 260 250 0)
  86   (gl:end)))
  87
  88 (defun run ()
  89  ; I do this because I don't know who or what in the many layers
  90  ; is causing the floating point errors, but I definitely don't
  91  ; want to investigate until simply ignoring them becomes a problem.
  92  (sb-int:with-float-traps-masked (:invalid)
  93   (cl-glut:init)
  94   (gl:clear-color 0 0 0 1)
  95   (cl-glut:init-window-size
  96    (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin)))))
  97    (floor (* *patch-size* (1+ (- (getf *world-dims* :ymax) (getf *world-dims* :ymin))))))
  98   (setf *glut-window-opened* t)
  99   (cl-glut:create-window "CLNL Test Window")
 100   (cl-glut:init-display-mode :double :rgba)
 101   (cl-glut:display-func (cffi:get-callback 'display))
 102   (glut:reshape-func (cffi:callback reshape))
 103   (cl-glut:idle-func (cffi:get-callback 'idle))
 104   (cl-glut:close-func (cffi:get-callback 'close-func))
 105   (set-turtle-list)
 106   (cl-glut:main-loop)))
 107
 108 (defun export-view ()
 109  (sb-int:with-float-traps-masked (:invalid)
 110   (when (not *glut-window-opened*)
 111    (cl-glut:init)
 112    (gl:clear-color 0 0 0 1)
 113    (cl-glut:init-window-size 1 1)
 114    (cl-glut:create-window "CLNL Test Window")
 115    (set-turtle-list)
 116    (setf *glut-window-opened* t))
 117   (let
 118    ((fbo (first (gl:gen-framebuffers 1)))
 119     (render-buf (first (gl:gen-renderbuffers 1)))
 120     (width 143)  ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
 121     (height 143)
 122    ;(width (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin))))))
 123    ;(height (floor (* *patch-size* (1+ (- (getf *world-dims* :ymax) (getf *world-dims* :ymin))))))
 124     )
 125    (gl:bind-framebuffer :framebuffer fbo)
 126    (gl:bind-renderbuffer :renderbuffer render-buf)
 127    (gl:renderbuffer-storage :renderbuffer :rgba8 width height)
 128    (gl:framebuffer-renderbuffer :draw-framebuffer :color-attachment0 :renderbuffer render-buf)
 129    (gl:viewport 0 0 width height)
 130    (render-scene)
 131    (gl:read-pixels 0 0 width height :rgba :unsigned-byte))))