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