lambdamundo.lisp

   1
   2 (in-package :lambdamundo)
   3
   4
   5 (defmacro with-gensyms ((&rest names) &body body)
   6   `(let ,(loop for n in names collect `(,n (gensym)))
   7      ,@body))
   8
   9 (defmacro once-only ((&rest names) &body body)
  10   (let ((gensyms (loop for n in names collect (gensym))))
  11     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  12        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  13           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  14              ,@body)))))
  15
  16
  17 ;; gl init and de-init
  18
  19 (defun begin-gl ()
  20   (gl:enable gl:+depth-test+)
  21   (gl:disable gl:+cull-face+)
  22   (gl:disable gl:+lighting+))
  23
  24 (defun end-gl ())
  25
  26 ;; drawing --------------------
  27 ;; each cell will have to know how to cull itself
  28
  29 (eval-when ( :load-toplevel :compile-toplevel :execute )
  30   (defparameter *draw-fns* (make-hash-table :test 'equalp)
  31    "An table of functions called in order to render the scene")
  32
  33   (defparameter *draw-array* (make-array 0 :adjustable t :fill-pointer 0)
  34     "An array that indexes *draw-fns* to establish draw order" )
  35
  36   (defun extend-draw-array (name priority)
  37     "If the name is in the array, adjust priority, else add it to the array"
  38     (assert (not (null (gethash name *draw-fns*))) (name) "~S is not a drawable")
  39     (let
  40         ((draw-priority-pos
  41           (position-if #'(lambda (x) (equal (car x) name)) *draw-array*)))
  42       (if draw-priority-pos
  43           (setf (aref *draw-array* draw-priority-pos) (cons name priority))
  44         (vector-push-extend (cons name priority) *draw-array*)))))
  45
  46 (defmacro make-draw-function (name priority &body forms)
  47   `(progn
  48      (setf (gethash ,name *draw-fns*)
  49            (compile nil '(lambda ()  ,@forms)))
  50      (extend-draw-array ,name ,priority)
  51      (sort *draw-array* #'(lambda (a b)
  52                             (< (car a) (car b))))))
  53 (defun draw ()
  54   (with-camera *camera*
  55     (iterate
  56       (for entry in-vector *draw-array*)
  57       (funcall (gethash (car entry) *draw-fns*)))))
  58
  59 (make-draw-function
  60  "testcube" 1
  61  (let ((vertices
  62         (list
  63          '(1.0 1.0 1.0)
  64          '(1.0 1.0 -1.0)
  65          '(1.0 -1.0 1.0)
  66          '(1.0 -1.0 -1.0)
  67          '(-1.0 1.0 1.0)
  68          '(-1.0 1.0 -1.0)
  69          '(-1.0 -1.0 1.0)
  70          '(-1.0 -1.0 -1.0)))
  71        (polys
  72         (list
  73          '(2 1 3 4)
  74          '(5 6 7 8)
  75          '(1 2 6 5)
  76          '(4 3 7 8)
  77          '(3 1 5 7)
  78          '(2 4 8 6))))
  79    (gl:with-begin gl:+quads+
  80    (gl:color-3f 0.0 1.0 0.0)
  81    (iterate
  82     (for poly in polys)
  83     (iterate
  84      (for vertex in poly)
  85      (apply #'gl:vertex-3f (nth (1- vertex) vertices)))))))
  86
  87
  88 ;; animation --------------------
  89
  90 (defparameter *frames* 0)
  91 (defparameter t0 0.0)
  92 (defparameter t1 0.0)
  93
  94 (defun animate ()
  95   (incf *frames*)
  96   (setf t0 t1
  97         t1 (glfw:get-time)))
  98
  99 ;; main routine -------------------
 100
 101 (lambdamundo-window ("Lambdamundo"
 102                     :dimensions (640 480)
 103                     :colourbits (0 0 0 0)
 104                     :depthbits 32
 105                     :stencilbits 0
 106                     :mode glfw:+window+)
 107   :key-callback
 108   (:void ((key :int) (action :int)) (when-funcall (gethash key *key-fns*)))
 109   :resize-callback
 110   (:void ((width :int) (height :int))
 111          (let* ((h (/ height width))
 112                 (znear 5)
 113                 (zfar 30)
 114                 (xmax (* znear  0.5)))
 115
 116            (gl:viewport 0 0 width height)
 117            (gl:with-setup-projection
 118              (gl:frustum (- xmax) xmax (* (- xmax) h) (* xmax h) znear zfar))
 119
 120            (gl:load-identity)
 121            (gl:translate-f 0 0 -20)))
 122   :start
 123   ((glfw:enable glfw:+key-repeat+)
 124    (glfw:swap-interval 0)
 125    (begin-gl)
 126    (glfw:set-window-size-callback (cffi:callback window-size-callback))
 127    (glfw:set-key-callback (cffi:callback key-callback)))
 128   :main
 129   ;; to do -- we need to drop in and out of body forms
 130   ((draw)
 131    (cl:sleep 1)
 132    (animate))))
 133