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

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