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