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

   1 (in-package #:clnl-interface)
   2
   3 (defvar *turtle-lists* nil)
   4 (defvar *patch-list* nil)
   5
   6 (defvar *glut-window-opened* nil)
   7 (defvar *dimensions* nil) ; This is a useful placeholder for other view properties
   8 (defvar *window-width* 1024)
   9 (defvar *window-height* 768)
  10
  11 (defvar *default-shapes* nil)
  12
  13 (defvar *textbox* nil)
  14 (defvar *inputbox* nil)
  15
  16 (defvar *widgets* nil) ; this is going to be pairs to save the original definition
  17
  18 ; For now, shapes can live in here
  19 ; header is
  20 ; * name <like default>
  21 ; * rotatable (equal to "true" if yes)
  22 ;
  23 ; then after, the elements are like so:
  24 ;
  25 ; filled == filled in (always for now, ha)
  26 ; marked == use the turtle color instead of a color
  27 ; polygon -> Polygon <color> <filled> <marked> <alternating x y coords>
  28 ; circle -> Circle <color> <filled> <marked> <left> <top> <diameter> ; here, the left and top are NOT the center
  29 ; rectangle -> Rectangle <color> <filled> <marked> <left> <top> <right> <bottom>
  30 ;
  31 ; then ends with an empty string
  32
  33 (defun parse-circle (sections)
  34  (list :circle
  35   :color (parse-integer (car sections))
  36   :filled (string= (nth 1 sections) "true")
  37   :marked (string= (nth 2 sections) "true")
  38   :left (parse-integer (nth 3 sections))
  39   :top (parse-integer (nth 4 sections))
  40   :diameter (parse-integer (nth 5 sections))))
  41
  42 (defun parse-rectangle (sections)
  43  (list
  44   :rectangle
  45   :color (parse-integer (car sections))
  46   :filled (string= (nth 1 sections) "true")
  47   :marked (string= (nth 2 sections) "true")
  48   :left (parse-integer (nth 3 sections))
  49   :top (parse-integer (nth 4 sections))
  50   :right (parse-integer (nth 5 sections))
  51   :bottom (parse-integer (nth 6 sections))))
  52
  53 (defun parse-polygon (sections)
  54  (labels
  55   ((parse-points (sections)
  56     (when sections
  57      (cons
  58       (list (- 300 (parse-integer (car sections))) (parse-integer (cadr sections)))
  59       (parse-points (cddr sections))))))
  60   (list
  61    :polygon
  62    :color (parse-integer (car sections))
  63    :filled (string= (nth 1 sections) "true")
  64    :marked (string= (nth 2 sections) "true")
  65    :coords (parse-points (nthcdr 3 sections)))))
  66
  67 (defun parse-shape (str)
  68  (labels
  69   ((parse-element (line)
  70     (let
  71      ((sections (cl-ppcre:split " " line)))
  72      (cond
  73       ((string= (car sections) "Circle") (parse-circle (cdr sections)))
  74       ((string= (car sections) "Rectangle") (parse-rectangle (cdr sections)))
  75       ((string= (car sections) "Polygon") (parse-polygon (cdr sections))))))
  76    (parse-elements ()
  77     (let
  78      ((line (read-line str nil)))
  79      (when (and line (string/= line ""))
  80       (cons
  81        (parse-element line)
  82        (parse-elements))))))
  83   (let
  84    ((next-line (read-line str nil)))
  85    (when next-line
  86     (list
  87      :name next-line
  88      :rotatable (string= "true" (read-line str))
  89      :rgb (read-line str) ; this is ignored for now, I think
  90      :elements (parse-elements))))))
  91
  92 ; Clipping ears algorithm.  This can be slow due to the fact that it will only be run once.
  93 (defun triangulate (points &optional (ccw :unknown))
  94  (labels
  95   ((tri-is-ccw (x y z)
  96     (< 0 (- (* (- (car y) (car x)) (- (cadr z) (cadr x))) (* (- (car z) (car x)) (- (cadr y) (cadr x))))))
  97    (tri-is-concave (x y z) (if (tri-is-ccw x y z) (not ccw) ccw))
  98    (poly-is-ccw (points &optional cur-tri)
  99     (cond
 100      ((not cur-tri)
 101       (poly-is-ccw (append points (list (car points))) (list (car (last points)) (car points) (cadr points))))
 102      ((eql (length points) 2)
 103       (apply #'tri-is-ccw cur-tri))
 104      ((or
 105        (< (car (cadr points)) (car (cadr cur-tri)))
 106        (and
 107         (= (car (cadr points)) (car (cadr cur-tri)))
 108         (< (cadr (cadr points)) (cadr (cadr cur-tri)))))
 109       (poly-is-ccw (cdr points) (subseq points 0 3)))
 110      (t (poly-is-ccw (cdr points) cur-tri))))
 111    (point-in-tri (x y z p)
 112     ; Barycentric system test
 113     (let*
 114      ((denom (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z)))))
 115       (a (/ (+ (* (- (cadr y) (cadr z)) (- (car p) (car z))) (* (- (car z) (car y)) (- (cadr p) (cadr z)))) denom))
 116       (b (/ (+ (* (- (cadr z) (cadr x)) (- (car p) (car z))) (* (- (car x) (car z)) (- (cadr p) (cadr z)))) denom))
 117       (c (- 1 a b)))
 118      (and (<= 0 a 1) (<= 0 b 1) (<= 0 c 1))))
 119    (no-points-in-tri (tri points)
 120     (every (lambda (point) (not (point-in-tri (car tri) (cadr tri) (caddr tri) point))) points))
 121    (tri-is-actually-line (x y z)
 122     (zerop (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z)))))))
 123   (cond
 124    ((not (find :end points)) (triangulate (append points (list :end)) ccw))
 125    ((< (length points) 4) (error "Must have at least 3 points..."))
 126    ((= (length points) 4) (list (remove :end points)))
 127    ((eql ccw :unknown) (triangulate points (poly-is-ccw (remove :end points))))
 128    ((eql :end (car points)) (error "This polygon may not be triangulateable"))
 129    (t
 130     (let*
 131      ((endless (remove :end points))
 132       (tri (subseq endless 0 3)))
 133      (cond
 134       ((apply #'tri-is-actually-line tri)
 135        (triangulate (cons (car endless) (cddr endless)) ccw))
 136       ((apply #'tri-is-concave tri)
 137        (triangulate (append (cdr points) (list (car points))) ccw))
 138       ((no-points-in-tri tri (nthcdr 3 endless))
 139        (cons tri (triangulate (cons (car endless) (cddr endless)) ccw)))
 140       (t (triangulate (append (cdr points) (list (car points))) ccw))))))))
 141
 142 (defun element->gl-list (shape)
 143  (progn
 144   (when (not (getf (cdr shape) :marked))
 145    (gl:push-attrib :all-attrib-bits)
 146    (gl:color
 147     (/ (ash (ldb (byte 24 0) (getf (cdr shape) :color)) -16) 255)
 148     (/ (ash (ldb (byte 16 0) (getf (cdr shape) :color)) -8) 255)
 149     (/ (ldb (byte 8 0) (getf (cdr shape) :color)) 255)))
 150   (gl:begin :triangles)
 151   (case (car shape)
 152    (:polygon
 153     (mapcar
 154      (lambda (point) (gl:vertex (car point) (cadr point) 0))
 155      (apply #'append (triangulate (getf (cdr shape) :coords)))))
 156    (:rectangle
 157     (mapcar
 158      (lambda (point) (gl:vertex (car point) (cadr point) 0))
 159      (apply #'append
 160       (triangulate
 161        (list
 162         (list (- 300 (getf (cdr shape) :left)) (getf (cdr shape) :top))
 163         (list (- 300 (getf (cdr shape) :right)) (getf (cdr shape) :top))
 164         (list (- 300 (getf (cdr shape) :right)) (getf (cdr shape) :bottom))
 165         (list (- 300 (getf (cdr shape) :left)) (getf (cdr shape) :bottom)))))))
 166    (:circle
 167     (mapcar
 168      (lambda (point) (gl:vertex (car point) (cadr point) 0))
 169      (apply #'append
 170       (triangulate
 171        (loop
 172         :repeat 360
 173         :with c := (strictmath:cos (strictmath:to-radians 1))
 174         :with s := (strictmath:sin (strictmath:to-radians 1))
 175         :with r := (/ (getf (cdr shape) :diameter) 2)
 176         :with left := (getf (cdr shape) :left)
 177         :with top := (getf (cdr shape) :top)
 178         :for n := 0 :then x
 179         :for x := r :then (- (* c x) (* s y))
 180         :for y := 0 :then (+ (* s n) (* c y))
 181         :collect (list (- 300 (+ (+ x left) r)) (+ (+ y top) r))))))))
 182   (gl:end)
 183   (when (not (getf (cdr shape) :marked))
 184    (gl:pop-attrib))))
 185
 186 (defun parse-shapes (str)
 187  (let
 188   ((shape (parse-shape str)))
 189   (when shape (cons shape (parse-shapes str)))))
 190
 191 (defun default-shapes ()
 192  (with-open-file (str "resources/defaultshapes") (parse-shapes str)))
 193
 194 (eval-when (:load-toplevel)
 195  (when (probe-file "resources/defaultshapes")
 196   (setf *default-shapes* (default-shapes))))
 197
 198 (defvar *colors*
 199  '((140 140 140) ; gray       (5)
 200    (215 48 39) ; red       (15)
 201    (241 105 19) ; orange    (25)
 202    (156 109 70) ; brown     (35)
 203    (237 237 47) ; yellow    (45)
 204    (87 176 58) ; green     (55)
 205    (42 209 57) ; lime      (65)
 206    (27 158 119) ; turquoise (75)
 207    (82 196 196) ; cyan      (85)
 208    (43 140 190) ; sky       (95)
 209    (50 92 168) ; blue     (105)
 210    (123 78 163) ; violet   (115)
 211    (166 25 105) ; magenta  (125)
 212    (224 126 149) ; pink     (135)
 213    (0 0 0) ; black
 214    (255 255 255))) ; white
 215
 216 (defun nl-color->rgb (color)
 217  (let*
 218   ((step (+ (/ (- (mod (floor (* color 10)) 100) 50) 50.48) 0.012)))
 219   (mapcar
 220    (lambda (x) (/ (+ x (floor (* (if (< step 0d0) x (- 255 x)) step))) 255))
 221    (nth (floor color 10) *colors*))))
 222
 223 (defun render-scene ()
 224  (gl:matrix-mode :projection)
 225  (gl:with-pushed-matrix
 226   (gl:load-identity)
 227   (gl:ortho
 228    (floor (* (- (getf *dimensions* :xmin) 0.5) (patch-size)))
 229    (floor (* (+ (getf *dimensions* :xmax) 0.5) (patch-size)))
 230    (floor (* (- (getf *dimensions* :ymin) 0.5) (patch-size)))
 231    (floor (* (+ (getf *dimensions* :ymax) 0.5) (patch-size)))
 232    0 5000)
 233   (gl:matrix-mode :modelview)
 234   (gl:with-pushed-matrix
 235    (gl:load-identity)
 236    (destructuring-bind (turtles patches) (clnl-nvm:current-state)
 237     (mapcar
 238      (lambda (patch)
 239       (let
 240        ((color (nl-color->rgb (getf patch :color))))
 241        (gl:color (car color) (cadr color) (caddr color)))
 242       (gl:with-pushed-matrix
 243        (gl:translate (* (getf patch :xcor) (patch-size)) (* (getf patch :ycor) (patch-size)) 0)
 244        (gl:translate (floor (* -.5d0 (patch-size))) (floor (* -.5d0 (patch-size))) 0)
 245        (gl:scale (patch-size) (patch-size) 1)
 246        (gl:call-list *patch-list*)))
 247      patches)
 248     (mapcar
 249      (lambda (turtle)
 250       (let
 251        ((color (nl-color->rgb (getf turtle :color))))
 252        (gl:color (car color) (cadr color) (caddr color)))
 253       (mapcar
 254        (lambda (x-modification y-modification)
 255         (gl:with-pushed-matrix
 256          (gl:translate (* (getf turtle :xcor) (patch-size)) (* (getf turtle :ycor) (patch-size)) 0)
 257          (gl:translate x-modification y-modification 0)
 258          (let
 259           ((turtle-list (find (getf turtle :shape) *turtle-lists* :test #'string= :key #'car)))
 260           (when turtle-list
 261            (when (second turtle-list)
 262             (gl:rotate (getf turtle :heading) 0 0 -1))
 263            (gl:scale (patch-size) (patch-size) 1)
 264            (gl:scale (getf turtle :size) (getf turtle :size) 1)
 265            (gl:call-list (third turtle-list))))))
 266        (list 0 (1- (world-width-in-pixels)) (- (1- (world-width-in-pixels))) 0 0)
 267        (list 0 0 0 (1- (world-height-in-pixels)) (- (1- (world-height-in-pixels))))))
 268      turtles)))
 269   (gl:matrix-mode :projection))
 270  (gl:flush))
 271
 272 (defun render-widgets ()
 273  (clnl-gltk:render *textbox*)
 274  (clnl-gltk:render *inputbox*)
 275  (mapcar #'clnl-gltk:render (mapcar #'cadr *widgets*)))
 276
 277 (defun render ()
 278  (gl:clear :color-buffer-bit :depth-buffer-bit)
 279  (let
 280   ((width (world-width-in-pixels))
 281    (height (world-height-in-pixels)))
 282   (gl:viewport 0 0 *window-width* *window-height*)
 283
 284   (gl:matrix-mode :projection)
 285   (let*
 286    ((left (getf *dimensions* :left))
 287     (top (getf *dimensions* :top))
 288     (view-x1 left)
 289     (view-x2 (+ view-x1 width))
 290     (view-y1 (- *window-height* height top))
 291     (view-y2 (- *window-height* top)))
 292
 293    (gl:with-pushed-matrix
 294     (gl:load-identity)
 295     (gl:ortho 0 *window-width* 0 *window-height* 0 5000)
 296     (render-widgets)
 297
 298     (gl:begin :lines)
 299     (gl:vertex view-x1 view-y1)
 300     (gl:vertex view-x1 (+ view-y2 1))
 301
 302     (gl:vertex view-x1 (+ view-y2 1))
 303     (gl:vertex (+ view-x2 1) (+ view-y2 1))
 304
 305     (gl:vertex (+ view-x2 1) (+ view-y2 1))
 306     (gl:vertex (+ view-x2 1) (- view-y1 1))
 307
 308     (gl:vertex (+ view-x2 1) view-y1)
 309     (gl:vertex (- view-x1 1) view-y1)
 310     (gl:end))
 311
 312    (gl:viewport view-x1 view-y1 width height)
 313    (render-scene))))
 314
 315 (defun display ()
 316  (render)
 317  (cl-glut:swap-buffers))
 318
 319 (defun idle ()
 320  (cl-glut:post-redisplay))
 321
 322 (defun close-func ()
 323  ;(glut:leave-main-loop)
 324  (sb-ext:exit :abort t))
 325
 326 (defun reshape (width height)
 327  (when (and (/= 0 width) (/= 0 height))
 328   (setf *window-width* width)
 329   (setf *window-height* height)
 330   (let
 331    ((box-width (truncate (- width 12) clnl-gltk:*font-width*)))
 332    (clnl-gltk:resize *textbox* box-width 12)
 333    (clnl-gltk:resize *inputbox* box-width 1))
 334   (mapcar
 335    (lambda (pair)
 336     (clnl-gltk:reposition (cadr pair)
 337      (getf (car pair) :left)
 338      (- *window-height* (getf (car pair) :height) (getf (car pair) :top))))
 339    *widgets*)))
 340
 341 (defun execute (str)
 342  (setf
 343   (clnl-gltk:textbox-text *textbox*)
 344   (format nil "> ~A~%~%~A" str
 345    (handler-case
 346     (with-output-to-string (*standard-output*)
 347      (clnl:run-commands str))
 348     (error (e) (format nil "Ok, something went wrong: ~A~%Try :help" e))))))
 349
 350 (defun key-pressed (key x y)
 351  (declare (ignore x y))
 352  (if (eql key 13)
 353   (progn
 354    (execute (clnl-gltk:value *inputbox*))
 355    (clnl-gltk:clear *inputbox*))
 356   (clnl-gltk:key-pressed *inputbox* key)))
 357
 358 (defun mouse (button state x y)
 359  (declare (ignore button))
 360  (mapcar
 361   (lambda (w)
 362    (when (eql state :down) (clnl-gltk:mousedown w x (- *window-height* y)))
 363    (when (eql state :up) (clnl-gltk:mouseup w x (- *window-height* y))))
 364   (mapcar #'cadr *widgets*)))
 365
 366 (defun motion (x y)
 367  (mapcar
 368   (lambda (w) (clnl-gltk:mousemove w x (- *window-height* y)))
 369   (mapcar #'cadr *widgets*)))
 370
 371 (cffi:defcallback display :void () (display))
 372 (cffi:defcallback idle :void () (idle))
 373 (cffi:defcallback close-func :void () (close-func))
 374 (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height))
 375 (cffi:defcallback key-pressed :void ((key :uchar) (x :int) (y :int)) (key-pressed key x y))
 376 (cffi:defcallback special-key-pressed :void ((key glut:special-keys) (x :int) (y :int)) (key-pressed key x y))
 377 (cffi:defcallback mouse :void ((button cl-glut:mouse-button) (state cl-glut:mouse-button-state) (x :int) (y :int))
 378  (mouse button state x y))
 379
 380 (cffi:defcallback motion :void ((x :int) (y :int)) (motion x y))
 381
 382 (defun set-turtle-lists ()
 383  (setf
 384   *turtle-lists*
 385   (mapcar
 386    (lambda (shape)
 387     (let
 388      ((turtle-list
 389        (list
 390         (getf shape :name)
 391         (getf shape :rotatable)
 392         (gl:gen-lists 1))))
 393      (gl:with-new-list ((third turtle-list) :compile)
 394       (gl:rotate 180d0 0d0 0d0 -1d0)
 395       (gl:scale (/ 1d0 300d0) (/ 1d0 300d0) 1)
 396       (gl:translate -150d0 -150d0 -0.0d0)
 397       (mapcar #'element->gl-list (getf shape :elements)))
 398      turtle-list))
 399    (or *default-shapes* (default-shapes)))))
 400
 401 (defun set-patch-list ()
 402  (setf *patch-list* (gl:gen-lists 1))
 403  (gl:with-new-list (*patch-list* :compile)
 404   (gl:begin :polygon)
 405   (gl:vertex 0 0 0)
 406   (gl:vertex 0 1 0)
 407   (gl:vertex 1 1 0)
 408   (gl:vertex 1 0 0)
 409   (gl:end)))
 410
 411 (defvar *initial-banner*
 412  "
 413      / \\
 414     /   \\     Welcome to CLNL version ~A!
 415    /     \\
 416   /_______\\
 417
 418 CLNL is an experiment at creating an alternate implementation of NetLogo.
 419
 420 You can enter in various netlogo commands below, or use :q to quit the program.
 421
 422 See http://github.com/frankduncan/clnl for more information about CLNL and to
 423 keep apprised of any updates that may happen.")
 424
 425 (defun initialize (&key dims view buttons)
 426  "INITIALIZE &key DIMS VIEW BUTTONS => RESULT
 427
 428   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
 429   VIEW: (:left LEFT :top TOP)
 430   BUTTONS: BUTTON-DEF*
 431   BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
 432
 433 ARGUMENTS AND VALUES:
 434
 435   RESULT: undefined
 436   XMIN: An integer representing the minimum patch coord in X
 437   XMAX: An integer representing the maximum patch coord in X
 438   YMIN: An integer representing the minimum patch coord in Y
 439   YMAX: An integer representing the maximum patch coord in Y
 440   PATCH-SIZE: A double representing the size of the patches in pixels
 441   LEFT: An integer representing the left position
 442   TOP: An integer representing the top position
 443   HEIGHT: An integer representing height
 444   WIDTH: An integer representing width
 445   DISPLAY: A string representing display name
 446
 447 DESCRIPTION:
 448
 449   This is where the initialization of the interface that sits behind
 450   the interface lives.  From here, one can go into headless or running
 451   mode, but for certain things this interface will still need to act,
 452   and also allows for bringing up and taking down of visual elements."
 453  (setf *dimensions* (append dims view))
 454  (let
 455   ((known-button-names nil))
 456   (setf *widgets*
 457    (mapcar
 458     (lambda (button-def)
 459      (let
 460       ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal))))
 461       (push (getf button-def :display) known-button-names)
 462       (list
 463        button-def
 464        (clnl-gltk:button
 465         (getf button-def :left)
 466         (- *window-height* (getf button-def :height) (getf button-def :top))
 467         (getf button-def :width)
 468         (getf button-def :height)
 469         (getf button-def :display)
 470         (lambda ()
 471          (execute
 472           (format nil ":button \"~A\"~A"
 473            (getf button-def :display)
 474            (if (zerop idx) "" (format nil " ~A" idx)))))))))
 475     buttons))))
 476
 477 (defun run ()
 478  "RUN => RESULT
 479
 480 ARGUMENTS AND VALUES:
 481
 482   RESULT: undefined, should never get here
 483
 484 DESCRIPTION:
 485
 486   RUN runs the view in an external window.
 487
 488   This should be run inside another thread as it starts the glut main-loop.
 489   Closing this window will then cause the entire program to terminate."
 490  ; I do this because I don't know who or what in the many layers
 491  ; is causing the floating point errors, but I definitely don't
 492  ; want to investigate until simply ignoring them becomes a problem.
 493  (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow)
 494   (cl-glut:init)
 495   (cl-glut:init-window-size *window-width* *window-height*)
 496   (cl-glut:init-display-mode :double :rgba)
 497   (cl-glut:create-window "CLNL Test Window")
 498   (setf *glut-window-opened* t)
 499   (gl:clear-color 0 0 0 1)
 500   (cl-glut:display-func (cffi:get-callback 'display))
 501   (glut:reshape-func (cffi:callback reshape))
 502   (cl-glut:idle-func (cffi:get-callback 'idle))
 503   (cl-glut:close-func (cffi:get-callback 'close-func))
 504   (cl-glut:keyboard-func (cffi:get-callback 'key-pressed))
 505   (cl-glut:special-func (cffi:get-callback 'special-key-pressed))
 506   (cl-glut:motion-func (cffi:get-callback 'motion)) ; while mouse is down
 507   (cl-glut:passive-motion-func (cffi:get-callback 'motion)) ; while mouse is up
 508   (cl-glut:mouse-func (cffi:get-callback 'mouse)) ; state is up/down, button is button
 509   (gl:depth-func :lequal)
 510   (gl:blend-func :src-alpha :one-minus-src-alpha)
 511   (gl:enable :blend)
 512   (set-turtle-lists)
 513   (set-patch-list)
 514   (clnl-gltk:setup)
 515   (setf *textbox*
 516    (clnl-gltk:textbox
 517     5 (+ clnl-gltk:*font-height* 14)
 518     10 12
 519     (format nil *initial-banner* (asdf:component-version (asdf:find-system :clnl)))))
 520   (setf *inputbox* (clnl-gltk:inputbox 5 5 10))
 521   (cl-glut:main-loop)))
 522
 523 (defun patch-size () (getf *dimensions* :patch-size))
 524
 525 (defun world-width-in-pixels ()
 526  (floor (* (patch-size) (1+ (- (getf *dimensions* :xmax) (getf *dimensions* :xmin))))))
 527
 528 (defun world-height-in-pixels ()
 529  (floor (* (patch-size) (1+ (- (getf *dimensions* :ymax) (getf *dimensions* :ymin))))))
 530
 531 (defun export-view ()
 532  "EXPORT-VIEW => IMAGE-DATA
 533
 534 ARGUMENTS AND VALUES:
 535
 536   IMAGE-DATA: A vector, pixel data as returned by opengls readPixels
 537
 538 DESCRIPTION:
 539
 540   EXPORT-VIEW returns the current view in raw data of RGBA pixels.
 541
 542   Each pixel is made up of 4 bytes of data, which an be walked over.  The number
 543   of pixels is the current width x height.  Converting to some other image format
 544   is a matter of pulling that information out and putting it into whatever format
 545   you like.
 546
 547   This requires opengl to run, but can be used with xvfb in a headless mode."
 548  (sb-int:with-float-traps-masked (:invalid)
 549   (when (not *glut-window-opened*)
 550    (cl-glut:init)
 551    (cl-glut:init-window-size 1 1)
 552    (cl-glut:create-window "CLNL Test Window")
 553    (gl:clear-color 0 0 0 1)
 554    (set-turtle-lists)
 555    (set-patch-list)
 556    (setf *glut-window-opened* t))
 557   (let
 558    ((fbo (first (gl:gen-framebuffers 1)))
 559     (render-buf (first (gl:gen-renderbuffers 1)))
 560     (width (world-width-in-pixels))
 561     (height (world-height-in-pixels)))
 562    (gl:bind-framebuffer :framebuffer fbo)
 563    (gl:bind-renderbuffer :renderbuffer render-buf)
 564    (gl:renderbuffer-storage :renderbuffer :rgba8 width height)
 565    (gl:framebuffer-renderbuffer :draw-framebuffer :color-attachment0 :renderbuffer render-buf)
 566    (gl:viewport 0 0 width height)
 567    (render-scene)
 568    (gl:read-pixels 0 0 width height :rgba :unsigned-byte))))