gui/gui.lisp

   1 (in-package :gui)
   2
   3 (defclass fenster (window)
   4   ((cursor-position :accessor cursor-position
   5                     :initform (make-array 2 :element-type 'fixnum)
   6                     :type (simple-array fixnum (2)))
   7    (draw-func :accessor draw-func
   8               :initarg :draw-func
   9               :initform #'(lambda ()
  10                             (with-primitive :lines
  11                               (color 1 0 0) (vertex 0 0 0) (vertex 1 0 0)
  12                               (color 0 1 0) (vertex 0 0 0) (vertex 0 1 0)
  13                               (color 0 0 1) (vertex 0 0 0) (vertex 0 0 1)))
  14               :type function)))
  15
  16 (defmethod set-view ((w fenster) &key (2d nil) (view-center (v))
  17                      (fov 30d0))
  18       (load-identity)
  19       (viewport 0 0 (width w) (height w))
  20       (matrix-mode :projection)
  21       (load-identity)
  22       (if 2d
  23           (ortho 0 (width w) (height w) 0 -1 1)
  24         (let ((x (vec-x view-center))
  25               (y (vec-y view-center))
  26               (z (vec-z view-center)))
  27           (glu:perspective fov (/ (width w) (height w)) .01 100)
  28           (glu:look-at 20 30 10
  29                        x y z
  30                        0 0 1)))
  31       (matrix-mode :modelview)
  32       (load-identity))
  33
  34 (let ((field-of-view (list 30d0))
  35       (view-center (list (v))))
  36   (defun update-view (&key (center-list view-center)
  37                       (fov-list field-of-view))
  38     "This function can be called from outside an OpenGL context. The
  39 supplied lists will be used to set the viewpoint with glLookAt. It is
  40 consumed from the front."
  41     (declare (cons center-list fov-list))
  42     (assert (equal (type-of (car center-list))
  43                    (type-of (v))))
  44     (assert (numberp (car fov-list)))
  45     (setf view-center center-list
  46           field-of-view fov-list))
  47
  48   (defmethod ensure-uptodate-view ((w fenster))
  49     (labels ((pop-until-last (l)
  50                (if (cdr l)
  51                    (pop l)
  52                    (car l))))
  53       (set-view w :view-center (pop-until-last view-center)
  54                 :fov (pop-until-last field-of-view))))
  55
  56   (defmethod display ((w fenster))
  57     (ensure-uptodate-view w)
  58     (clear :color-buffer-bit :depth-buffer-bit)
  59     (load-identity)
  60
  61     (funcall (draw-func w))
  62
  63     (swap-buffers)
  64     (sleep (/ 20))
  65     (post-redisplay)))
  66
  67 (defmethod reshape ((w fenster) x y)
  68   (setf (width w) x
  69         (height w) y)
  70   (ensure-uptodate-view w))
  71
  72 (defmethod display-window :before ((w fenster))
  73   (ensure-uptodate-view w))
  74
  75 (defmethod passive-motion ((w fenster) x y)
  76   (setf (aref (cursor-position w) 0) x
  77         (aref (cursor-position w) 1) (- (height w) y)))
  78
  79 (defmethod keyboard ((w fenster) key x y)
  80   (case key
  81     (#\Esc (destroy-current-window))))
  82
  83 (defmacro with-gui (&body body)
  84   `(display-window
  85     (make-instance 'gui:fenster
  86                    :mode '(:double :rgb :depth)
  87                    :draw-func #'(lambda ()
  88                                   ,@body))))
  89
  90