examples/viewer.lisp

   1 (require '#:asdf)
   2 (asdf:oos 'asdf:load-op '#:cl-glfw)
   3 (asdf:oos 'asdf:load-op '#:cl-glfw-opengl)
   4 (asdf:oos 'asdf:load-op '#:cl-glfw-glu)
   5
   6 (defstruct gl-object
   7   (type)
   8   (position)
   9   (normal)
  10   (color)
  11   (texture)
  12   ;; (display-list) ; compiled
  13   )
  14
  15 (defun gl-geometry-type (keyword)
  16   "Enumeration of the OpenGL geometric object types"
  17   (ecase keyword
  18     (:points gl:+points+)
  19     (:lines gl:+lines+)
  20     (:line-loop gl:+line-loop+)
  21     (:line-strip gl:+line-strip+)
  22     (:triangles gl:+triangles+)
  23     (:triangle-strip gl:+triangle-strip+)
  24     (:triangle-fan gl:+triangle-fan+)
  25     (:quads gl:+quads+)
  26     (:quad-strip gl:+quad-strip+)
  27     (:polygon gl:+polygon+)))
  28
  29 (defun render-gl-object (obj)
  30   "Display an object"
  31   (gl:with-begin (gl-geometry-type (gl-object-type obj))
  32     (let ((position (gl-object-position obj))
  33           (color (gl-object-color obj)))
  34       (if color
  35           (dotimes (row (array-dimension position 0))
  36             (gl:color-3f (aref color row 0)
  37                          (aref color row 1)
  38                          (aref color row 2))
  39             (gl:vertex-3f (aref position row 0)
  40                           (aref position row 1)
  41                           (aref position row 2)))
  42           (dotimes (row (array-dimension position 0))
  43             (gl:vertex-3f (aref position row 0)
  44                           (aref position row 1)
  45                           (aref position row 2)))))))
  46 (defun tricolor (obj)
  47   "set alternating vertices to red,green,blue"
  48   (let* ((position (gl-object-position obj))
  49          (color (make-array (array-dimensions position))))
  50     (dotimes (row (array-dimension color 0))
  51       (case (mod row 3)
  52         (0 (setf (aref color row 0) 1
  53                  (aref color row 1) 0
  54                  (aref color row 2) 0))
  55         (1 (setf (aref color row 0) 0
  56                  (aref color row 1) 1
  57                  (aref color row 2) 0))
  58         (2 (setf (aref color row 0) 0
  59                  (aref color row 1) 0
  60                  (aref color row 2) 1))))
  61     (setf (gl-object-color obj) color)))
  62
  63 ;;;; Platonic solids
  64 (defparameter *tetrahedron*
  65   (make-gl-object
  66    :type :triangle-strip
  67    :position (make-array '(6 3)
  68                          :initial-contents '((0 0 1)
  69                                              (0 1 0)
  70                                              (1 0 0)
  71                                              (1 1 1)
  72                                              (0 0 1)
  73                                              (0 1 0)))))
  74 (tricolor *tetrahedron*)
  75
  76 (defparameter *cube*
  77   (make-gl-object
  78    :type :triangle-strip
  79    :position (make-array '(14 3)
  80                          :initial-contents '((0 0 0)
  81                                              (0 0 1)
  82                                              (0 1 0)
  83                                              (0 1 1)
  84                                              (1 1 1)
  85                                              (0 0 1)
  86                                              (1 0 1)
  87                                              (0 0 0)
  88                                              (1 0 0)
  89                                              (0 1 0)
  90                                              (1 1 0)
  91                                              (1 1 1)
  92                                              (1 0 0)
  93                                              (1 0 1)))))
  94 (tricolor *cube*)
  95
  96 (defparameter *cube-points*
  97   (make-gl-object
  98    :type :points
  99    :position (make-array '(8 3)
 100                          :initial-contents '((0 0 0)
 101                                              (0 0 1)
 102                                              (0 1 0)
 103                                              (0 1 1)
 104                                              (1 0 0)
 105                                              (1 0 1)
 106                                              (1 1 0)
 107                                              (1 1 1)))))
 108
 109 (defparameter *octahedron*
 110   (make-gl-object
 111    :type :triangle-strip
 112    :position (make-array '(12 3)
 113                          :initial-contents '((0 0 1)
 114                                              (1 0 0)
 115                                              (0 1 0)
 116                                              (0 0 -1)
 117                                              (0 1 0)
 118                                              (-1 0 0)
 119                                              (0 0 1)
 120                                              (0 -1 0)
 121                                              (1 0 0)
 122                                              (0 -1 0)
 123                                              (0 0 -1)
 124                                              (-1 0 0)))))
 125 (tricolor *octahedron*)
 126
 127 ;; dodecahedron
 128
 129
 130 (defparameter *icosahedron*
 131   (let* ((phi (/ (+ 1 (sqrt 5))
 132                  2))
 133          (-phi (- phi))
 134          (0++ `(0 1 ,phi))
 135          (0+- `(0 1 ,-phi))
 136          (0-+ `(0 -1 ,phi))
 137          (0-- `(0 -1 ,-phi))
 138          (++0 `(1 ,phi 0))
 139          (+-0 `(1 ,-phi 0))
 140          (-+0 `(-1 ,phi 0))
 141          (--0 `(-1 ,-phi 0))
 142          (+0+ `(,phi 0 1))
 143          (+0- `(,phi 0 -1))
 144          (-0+ `(,-phi 0 1))
 145          (-0- `(,-phi 0 -1)))
 146     (make-gl-object
 147      :type :triangle-strip
 148      :position (make-array
 149                 '(30 3)
 150                 :initial-contents `(;; up
 151                                     ,-0-
 152                                     ,0--
 153                                     ,0+-
 154                                     ,+0-
 155                                     ,++0
 156                                     ,+0+
 157                                     ;; down
 158                                     ,++0
 159                                     ,0++
 160                                     ,++0
 161                                     ,-+0
 162                                     ,0+-
 163                                     ,-+0
 164                                     ,-0-
 165                                     ;; up
 166                                     ,-+0
 167                                     ,-0+
 168                                     ,0++
 169                                     ,0-+
 170                                     ,+0+
 171                                     ;; down
 172                                     ,0-+
 173                                     ,+-0
 174                                     ,0-+
 175                                     ,--0
 176                                     ,-0+
 177                                     ,--0
 178                                     ,-0-
 179                                     ;; up
 180                                     ,--0
 181                                     ,0--
 182                                     ,+-0
 183                                     ,+0-
 184                                     ,+0+)))))
 185 (tricolor *icosahedron*)
 186
 187 (defparameter *icosahedron-points*
 188   (let* ((phi (/ (+ 1 (sqrt 5))
 189                  2))
 190          (-phi (- phi)))
 191     (make-gl-object
 192      :type :points
 193      :position (make-array
 194                 '(12 3)
 195                 :initial-contents `((0 1 ,phi)
 196                                     (0 1 ,-phi)
 197                                     (0 -1 ,phi)
 198                                     (0 -1 ,-phi)
 199                                     (1 ,phi 0)
 200                                     (1 ,-phi 0)
 201                                     (-1 ,phi 0)
 202                                     (-1 ,-phi 0)
 203                                     (,phi 0 1)
 204                                     (,phi 0 -1)
 205                                     (,-phi 0 1)
 206                                     (,-phi 0 -1))))))
 207
 208 ;;;; The viewer
 209 (defparameter *view-rotx* 0)
 210 (defparameter *view-roty* 0)
 211 (defparameter *view-rotz* 0)
 212
 213 (cffi:defcallback key-callback :void ((key :int) (action :int))
 214   (when (eql action glfw:+press+)
 215     (cond ((eql key (char-code #\Z))
 216            (if (eql (glfw:get-key glfw:+key-lshift+) glfw:+press+)
 217                (decf *view-rotz* 5)
 218                (incf *view-rotz* 5)))
 219           ((eql key glfw:+key-esc+)   (glfw:close-window))
 220           ((eql key glfw:+key-up+)    (incf *view-rotx* 5))
 221           ((eql key glfw:+key-down+)  (decf *view-rotx* 5))
 222           ((eql key glfw:+key-left+)  (incf *view-roty* 5))
 223           ((eql key glfw:+key-right+) (decf *view-roty* 5)))))
 224
 225 (defun view-gl-object (obj)
 226  (let ((frames 0)
 227       t0 t1)
 228    (setf *view-rotx* 0
 229          *view-roty* 0
 230          *view-rotz* 0)
 231   (glfw:do-window ("Shape Viewer" 640 480)
 232       ((glfw:enable glfw:+sticky-keys+)
 233        (glfw:enable glfw:+key-repeat+)
 234        (gl:enable gl:+cull-face+)
 235        (glfw:swap-interval 0)
 236        (glfw:set-key-callback (cffi:callback key-callback))
 237        (setf t0 (glfw:get-time)
 238              t1 (glfw:get-time)))
 239
 240     (when (eql (glfw:get-key glfw:+key-esc+) glfw:+press+)
 241       (return-from glfw:do-window))
 242
 243     (setf t1 (glfw:get-time))
 244
 245     (when (> (- t1 t0) 1)
 246       (glfw:set-window-title (format nil "Shape Viewer (~,1f FPS)" (/ frames (- t1 t0))))
 247       (setf frames 0
 248             t0 t1))
 249
 250     (incf frames)
 251
 252     (destructuring-bind (width height) (glfw:get-window-size)
 253       (setf height (max height 1))
 254       (gl:viewport 0 0 width height)
 255
 256       (gl:clear-color 0 0 0 0)
 257       (gl:clear gl:+color-buffer-bit+)
 258
 259       (gl:matrix-mode gl:+projection+)
 260       (gl:load-identity)
 261       (glu:perspective 65 (/ width height) 1 100)
 262       (gl:matrix-mode gl:+modelview+)
 263       (gl:load-identity)
 264       (glu:look-at 0  1 0
 265                    0 20 0
 266                    0  0 1)
 267
 268       (gl:translate-f 0 14 0)
 269
 270       (gl:with-push-matrix
 271         (gl:rotate-f *view-rotx* 1 0 0)
 272         (gl:rotate-f *view-roty* 0 1 0)
 273         (gl:rotate-f *view-rotz* 0 0 1)
 274
 275         (render-gl-object obj))))))
 276
 277 (view-gl-object *cube*)