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