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