gui/draw.lisp

   1 (in-package :gui)
   2
   3 (defmacro def-vec-funcs (&rest names)
   4   `(progn
   5      ,@(loop for name in names collect
   6             (let ((name-v (alexandria:format-symbol :gui "~a-V" name)))
   7               `(defun ,name-v (vec)
   8                  (declare (vec vec)
   9                          (values null &optional))
  10                 (,name (vec-x vec) (vec-y vec) (vec-z vec))
  11                 nil)))))
  12
  13 (def-vec-funcs vertex tex-coord translate normal scale)
  14
  15 (defvar circle-points
  16   (let* ((n 37)
  17          (ps (make-array (+ n 2) :element-type 'vec
  18                          :initial-element (v))))
  19     (declare (fixnum n)
  20              ((simple-array vec 1) ps))
  21     (setf (aref ps 0) (v))
  22     (dotimes (i n)
  23       (let ((arg (* 2d0 pi i (/ 1d0 n))))
  24         (declare ((double-float 0d0 6.3d0) arg))
  25         (setf (aref ps (1+ i)) (make-vec (cos arg) (sin arg)))))
  26     (setf (aref ps (1+ n)) (aref ps 1))
  27     ps))
  28
  29 (declaim (type (simple-array vec 1) circle-points))
  30
  31 (defun draw-circle ()
  32   "Draw circle with radius 1."
  33   (dotimes (i (length circle-points))
  34     (vertex-v (aref circle-points i)))
  35   nil)
  36
  37 (defmethod draw ((disk lens:disk))
  38   (declare (values null &optional))
  39   (with-slots ((c lens::center) (r lens::radius)) disk
  40    (with-pushed-matrix
  41      (translate-v c)
  42      (scale r r r)
  43      (with-primitive :triangle-fan
  44        (draw-circle)))))
  45
  46 (defclass texture-luminance-ub8 ()
  47   ((dimensions :accessor dimensions :initarg :dimensions :initform '(0 0 0)
  48                :type cons)
  49    (object :accessor object :initarg :object :initform 0 :type fixnum)
  50    (target :accessor target :initarg :target
  51            :initform :texture-3d :type fixnum)))
  52
  53 (defmethod initialize-instance :after ((tex texture-luminance-ub8) &key data)
  54   (let ((rank (etypecase data
  55                 ((simple-array (unsigned-byte 8) 2) 2)
  56                 ((simple-array (unsigned-byte 8) 3) 3))))
  57     (with-slots (dimensions object target) tex
  58       (setf object (first (gen-textures 1))
  59             dimensions (array-dimensions data)
  60             target (ecase rank
  61                      (2 :texture-rectangle-nv)
  62                      (3 :texture-3d)))
  63       (bind-texture target object)
  64       (tex-parameter target :texture-min-filter :linear)
  65       (tex-parameter target :texture-mag-filter :linear)
  66       (sb-sys:with-pinned-objects (data)
  67         (let* ((data1 (sb-ext:array-storage-vector data))
  68                (data-sap (sb-sys:vector-sap data1)))
  69           (ecase rank
  70             (2 (tex-image-2d target 0 :luminance
  71                              (array-dimension data 1) ;; x
  72                              (array-dimension data 0) 0 :luminance
  73                              :unsigned-byte data-sap))
  74             (3 (tex-image-3d target 0 :luminance
  75                              (array-dimension data 2) ;; x
  76                              (array-dimension data 1) ;; y
  77                              (array-dimension data 0) 0 :luminance
  78                              :unsigned-byte data-sap))))))))
  79
  80 (defmethod destroy ((tex texture-luminance-ub8))
  81   (delete-textures (list (object tex))))
  82
  83 (defmethod bind-tex ((tex texture-luminance-ub8))
  84   (bind-texture (target tex) (object tex)))
  85
  86 (defmethod draw-xz ((tex texture-luminance-ub8) x+ x- z+ z-
  87                     &key (y 0d0) (ty 0d0))
  88   "Draw a quad with a texture. If the texture is 3d, an xz-plane at y
  89   is selected. The parameter x+, x-, z+, z- and y define vertex
  90   positions of the quad. In case of a 3d texture ty choses the y
  91   texture coordinate with value from 0 .. 1."
  92   (with-slots (target dimensions) tex
  93     (bind-tex tex)
  94     (gl:enable target)
  95     (let* ((texcoords
  96             (ecase target
  97               (:texture-rectangle-nv
  98                (destructuring-bind (yy xx) dimensions
  99                  (let ((y (* 1d0 yy))
 100                        (x (* 1d0 xx)))
 101                    (list (make-vec x y)     (make-vec 0d0 y)
 102                          (make-vec 0d0 0d0) (make-vec x 0d0)))))
 103               (:texture-3d (list (make-vec 1d0 ty 1d0) (make-vec 0d0 ty 1d0)
 104                                  (make-vec 0d0 ty 0d0) (make-vec 1d0 ty 0d0)))))
 105            (vertexs (list (make-vec x+ y z-)
 106                           (make-vec x- y z-)
 107                           (make-vec x- y z+)
 108                           (make-vec x+ y z+))))
 109       (gl:with-primitive :quads
 110         (loop for v in vertexs and c in texcoords do
 111            (tex-coord-v c) (vertex-v v))))
 112     (gl:disable target)))
 113
 114
 115
 116 (defun draw-axes ()
 117   (gl:line-width 3)
 118   (gl:with-primitive :lines
 119     (gl:color 1 0 0 1) (gl:vertex 0 0 0) (gl:vertex 1 0 0)
 120     (gl:color 0 1 0 1) (gl:vertex 0 0 0) (gl:vertex 0 1 0)
 121     (gl:color 0 0 1 1) (gl:vertex 0 0 0) (gl:vertex 0 0 1)))
 122
 123
 124 (defun draw-wire-box (start end)
 125   (gl:with-pushed-matrix
 126     (translate-v start)
 127     (scale-v (v- end start))
 128     (gl:translate .5 .5 .5)
 129     (glut:wire-cube 1)))