examples/viewer.lisp

   1 (require '#:asdf)
   2 (asdf:oos 'asdf:load-op '#:cl-glfw)
   3 (asdf:oos 'asdf:load-op '#:cl-glfw-opengl-version_1_0)
   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 (defun make-grid (rows cols)
 209   "makes a triangle-strip with 1+r+2rc vertices;
 210 fills (0 to rows, 0 to cols, 0)"
 211   (let ((v (make-array (list (+ 1 rows (* 2 rows cols))
 212                              3)
 213                        :initial-element 0))
 214         (i 1) ; first vertex is (0, 0)
 215         )
 216     (flet ((put (r c)
 217              (setf (aref v i 0) r
 218                    (aref v i 1) c)
 219              (incf i)))
 220       (dotimes (row rows)
 221         (if (= (mod row 2) 0)
 222             (loop for col from 0 below cols
 223                do (progn
 224                     (put (1+ row) col)
 225                     (put row (1+ col)))
 226                finally (put (1+ row) cols))
 227             (loop for col from cols above 0
 228                do (progn
 229                     (put (1+ row) col)
 230                     (put row (1- col)))
 231                finally (put (1+ row) 0)))))
 232     (make-gl-object
 233      :type :triangle-strip
 234      :position v)))
 235
 236 (defparameter *grid* (make-grid 4 5))
 237 (tricolor *grid*)
 238
 239 ;;;; The viewer
 240 (defparameter *view-rotx* 0)
 241 (defparameter *view-roty* 0)
 242 (defparameter *view-rotz* 0)
 243
 244 (defun key-callback (key action)
 245   (when (eql action glfw:+press+)
 246     (case key
 247       (#\Z
 248        (if (eql (glfw:get-key glfw:+key-lshift+) glfw:+press+)
 249            (decf *view-rotz* 5)
 250            (incf *view-rotz* 5)))
 251       (:esc   (glfw:close-window))
 252       (:up    (incf *view-rotx* 5))
 253       (:down  (decf *view-rotx* 5))
 254       (:left  (incf *view-roty* 5))
 255       (:right (decf *view-roty* 5)))))
 256
 257 (defun view-gl-object (obj)
 258   (let ((frames 0)
 259         t0 t1)
 260     (setf *view-rotx* 0
 261           *view-roty* 0
 262           *view-rotz* 0)
 263     (glfw:do-window (:title "Shape Viewer" :width 640 :height 480)
 264         ((glfw:enable glfw:+sticky-keys+)
 265          (glfw:enable glfw:+key-repeat+)
 266          (gl:enable gl:+cull-face+)
 267          (glfw:swap-interval 0)
 268          (glfw:set-key-callback 'key-callback)
 269          (setf t0 (glfw:get-time)
 270                t1 (glfw:get-time)))
 271
 272       (when (eql (glfw:get-key glfw:+key-esc+) glfw:+press+)
 273         (return-from glfw:do-window))
 274
 275       (setf t1 (glfw:get-time))
 276
 277       (when (> (- t1 t0) 1)
 278         (glfw:set-window-title (format nil "Shape Viewer (~,1f FPS)" (/ frames (- t1 t0))))
 279         (setf frames 0
 280               t0 t1))
 281
 282       (incf frames)
 283
 284       (destructuring-bind (width height) (glfw:get-window-size)
 285         (setf height (max height 1))
 286         (gl:viewport 0 0 width height)
 287
 288         (gl:clear-color 0 0 0 0)
 289         (gl:clear gl:+color-buffer-bit+)
 290
 291         (gl:matrix-mode gl:+projection+)
 292         (gl:load-identity)
 293         (glu:perspective 65 (/ width height) 1 100)
 294         (gl:matrix-mode gl:+modelview+)
 295         (gl:load-identity)
 296         (glu:look-at 0  1 0
 297                      0 20 0
 298                      0  0 1)
 299
 300         (gl:translate-f 0 14 0)
 301
 302         (gl:with-push-matrix
 303             (gl:rotate-f *view-rotx* 1 0 0)
 304           (gl:rotate-f *view-roty* 0 1 0)
 305           (gl:rotate-f *view-rotz* 0 0 1)
 306
 307           (render-gl-object obj))))))
 308
 309 (view-gl-object *tetrahedron*)