examples/gears.lisp

   1 (require '#:asdf)
   2 (asdf:oos 'asdf:load-op '#:cl-glfw)
   3
   4 (declaim (optimize (debug 3) (compilation-speed 0) (safety 3)))
   5
   6 (defparameter *running* t)
   7 (defparameter *t0* 0.0d0)
   8 (defparameter *t* 0)
   9 (defparameter *dt* 0)
  10 (defparameter *frames* 0)
  11 (defparameter *autoexit* 0)
  12 (defparameter *view_rotx* 20.0)
  13 (defparameter *view_roty* 30.0)
  14 (defparameter *view_rotz* 0.0)
  15 (defparameter *gear1* nil)
  16 (defparameter *gear2* nil)
  17 (defparameter *gear3* nil)
  18 (defparameter *angle* 0.0)
  19
  20
  21 (declaim (inline sfcos sfsin))
  22 (defun sfcos (a)
  23   (coerce (cos a) 'single-float))
  24
  25 (defun sfsin (a)
  26   (coerce (sin a) 'single-float))
  27
  28 (defun gear (inner_radius outer_radius width teeth tooth_depth)
  29   (let* ((r0 inner_radius)
  30         (r1 (- outer_radius (/ tooth_depth 2.0)))
  31         (r2 (+ outer_radius (/ tooth_depth 2.0)))
  32         (angle 0.0)
  33         (da (/ (/ (* 2.0 pi) teeth) 4.0)))
  34     (gl:shade-model gl:+flat+)
  35     (gl:normal-3f 0.0 0.0 1.0)
  36
  37     ;; draw front face
  38     (gl:begin gl:+quad-strip+)
  39     (dotimes (i (1+ teeth))
  40       (setf angle (/ (* i 2.0 pi) teeth))
  41       (gl:vertex-3f (* r0 (sfcos angle)) (* r0 (sfsin angle)) (* width 0.5))
  42       (gl:vertex-3f (* r1 (sfcos angle)) (* r1 (sfsin angle)) (* width 0.5))
  43       (when (< i teeth)
  44         (gl:vertex-3f (* r0 (sfcos angle)) (* r0 (sfsin angle)) (* width 0.5))
  45         (gl:vertex-3f (* r1 (sfcos (+ angle (* 3 da)))) (* r1 (sfsin (+ angle (* 3 da)))) (* width 0.5))))
  46     (gl:end)
  47
  48     ;; draw front sides of teeth
  49     (gl:begin gl:+quads+)
  50     (dotimes (i teeth)
  51       (setf angle (/ (* i 2.0 pi) teeth))
  52       (gl:vertex-3f (* r1 (sfcos angle)) (* r1 (sfsin angle)) (* width 0.5))
  53       (gl:vertex-3f (* r2 (sfcos (+ angle da))) (* r2 (sfsin (+ angle da))) (* width 0.5))
  54       (gl:vertex-3f (* r2 (sfcos (+ angle (* 2 da)))) (* r2 (sfsin (+ angle (* 2 da)))) (* width 0.5))
  55       (gl:vertex-3f (* r1 (sfcos (+ angle (* 3 da)))) (* r1 (sfsin (+ angle (* 3 da)))) (* width 0.5)))
  56     (gl:end)
  57
  58     (gl:normal-3f 0.0 0.0 -1.0)
  59
  60     ;; draw back face
  61     (gl:begin gl:+quad-strip+)
  62     (dotimes (i (1+ teeth))
  63       (setf angle (/ (* i 2.0 pi) teeth))
  64       (gl:vertex-3f (* r1 (sfcos angle)) (* r1 (sfsin angle)) (* (- width) 0.5))
  65       (gl:vertex-3f (* r0 (sfcos angle)) (* r0 (sfsin angle)) (* (- width) 0.5))
  66       (when (< i teeth)
  67         (gl:vertex-3f (* r1 (sfcos (+ angle (* 3 da)))) (* r1 (sfsin (+ angle (* 3 da)))) (* (- width) 0.5))
  68         (gl:vertex-3f (* r0 (sfcos angle)) (* r0 (sfsin angle)) (* (- width) 0.5))))
  69     (gl:end)
  70
  71     ;; draw back sides of teeth
  72     (gl:begin gl:+quads+)
  73     (dotimes (i teeth)
  74       (setf angle (/ (* i 2.0 pi) teeth))
  75       (gl:vertex-3f (* r1 (sfcos (+ angle (* 3 da)))) (* r1 (sfsin (+ angle (* 3 da)))) (* (- width) 0.5))
  76       (gl:vertex-3f (* r2 (sfcos (+ angle (* 2 da)))) (* r2 (sfsin (+ angle (* 2 da)))) (* (- width) 0.5))
  77       (gl:vertex-3f (* r2 (sfcos (+ angle da))) (* r2 (sfsin (+ angle da))) (* (- width) 0.5))
  78       (gl:vertex-3f (* r1 (sfcos angle)) (* r1 (sfsin angle)) (* (- width) 0.5)))
  79     (gl:end)
  80
  81     ;; draw outward faces of teeth
  82     (gl:begin gl:+quad-strip+)
  83     (dotimes (i teeth)
  84       (setf angle (/ (* i 2.0 pi) teeth))
  85       (gl:vertex-3f (* r1 (sfcos angle)) (* r1 (sfsin angle)) (* width 0.5))
  86       (gl:vertex-3f (* r1 (sfcos angle)) (* r1 (sfsin angle)) (* (- width) 0.5))
  87       (let* ((u (- (* r2 (sfcos (+ angle da))) (* r1 (sfcos angle))))
  88            (v (- (* r2 (sfsin (+ angle da))) (* r1 (sfsin angle))))
  89            (len (sqrt (+ (* u u) (* v v)))))
  90
  91            (setf u (/ u len))
  92            (setf v (/ v len))
  93            (gl:normal-3f v (- u) 0.0)
  94            (gl:vertex-3f (* r2 (sfcos (+ angle da))) (* r2 (sfsin (+ angle da))) (* width 0.5))
  95            (gl:vertex-3f (* r2 (sfcos (+ angle da))) (* r2 (sfsin (+ angle da))) (* (- width) 0.5))
  96            (gl:normal-3f (sfcos angle) (sfsin angle) 0.0)
  97            (gl:vertex-3f (* r2 (sfcos (+ angle (* 2 da)))) (* r2 (sfsin (+ angle (* 2 da)))) (* width 0.5))
  98            (gl:vertex-3f (* r2 (sfcos (+ angle (* 2 da)))) (* r2 (sfsin (+ angle (* 2 da)))) (* (- width) 0.5))
  99            (setf u (- (* r1 (sfcos (+ angle (* 3 da)))) (* r2 (sfcos (+ angle (* 2 da))))))
 100            (setf v (- (* r1 (sfsin (+ angle (* 3 da)))) (* r2 (sfsin (+ angle (* 2 da))))))
 101            (gl:normal-3f v (- u) 0.0)
 102            (gl:vertex-3f (* r1 (sfcos (+ angle (* 3 da)))) (* r1 (sfsin (+ angle (* 3 da)))) (* width 0.5))
 103            (gl:vertex-3f (* r1 (sfcos (+ angle (* 3 da)))) (* r1 (sfsin (+ angle (* 3 da)))) (* (- width) 0.5))
 104            (gl:normal-3f (sfcos angle) (sfsin angle) 0.0)))
 105
 106     (gl:vertex-3f (* r1 (sfcos 0)) (* r1 (sfsin 0)) (* width 0.5))
 107     (gl:vertex-3f (* r1 (sfcos 0)) (* r1 (sfsin 0)) (* (- width) 0.5))
 108     (gl:end)
 109
 110     (gl:shade-model gl:+smooth+)
 111
 112     ;; draw inside radius cylinder */
 113     (gl:begin gl:+quad-strip+)
 114     (dotimes (i (1+ teeth))
 115       (setf angle (/ (* i 2.0 pi) teeth))
 116       (gl:normal-3f (- (sfcos angle)) (- (sfsin angle)) 0.0)
 117       (gl:vertex-3f (* r0 (sfcos angle)) (* r0 (sfsin angle)) (* (- width) 0.5))
 118       (gl:vertex-3f (* r0 (sfcos angle)) (* r0 (sfsin angle)) (* width 0.5)))
 119     (gl:end)))
 120
 121
 122 (defun draw ()
 123   (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+))
 124   (gl:push-matrix)
 125     (gl:rotate-f *view_rotx* 1.0 0.0 0.0)
 126     (gl:rotate-f *view_roty* 0.0 1.0 0.0)
 127     (gl:rotate-f *view_rotz* 0.0 0.0 1.0)
 128
 129     (gl:push-matrix)
 130       (gl:translate-f -3.0 -2.0 0.0)
 131       (gl:rotate-f *angle* 0.0 0.0 1.0)
 132       (gl:call-list *gear1*)
 133     (gl:pop-matrix)
 134
 135     (gl:push-matrix)
 136       (gl:translate-f 3.1 -2.0 0.0)
 137       (gl:rotate-f (- (* -2.0 *angle*) 9.0) 0.0 0.0 1.0)
 138       (gl:call-list *gear2*)
 139     (gl:pop-matrix)
 140
 141     (gl:push-matrix)
 142       (gl:translate-f -3.1 4.2 0.0)
 143       (gl:rotate-f (- (* -2.0 *angle*) 25.0) 0.0 0.0 1.0)
 144       (gl:call-list *gear3*)
 145     (gl:pop-matrix)
 146
 147   (gl:pop-matrix)
 148
 149   (incf *frames*)
 150
 151   (let ((t_new (glfw:get-time)))
 152     (setf *dt* (- t_new *t*))
 153     (setf *t* t_new)
 154     (when (>= (- *t* *t0*) 5.0)
 155       (let* ((seconds (- *t* *t0*))
 156             (fps (/ *frames* seconds)))
 157         (format t "~d frames in ~3$ seconds = ~3$ FPS~%" *frames* seconds fps)
 158         (setf *t0* *t*)
 159         (setf *frames* 0)
 160         (when (and (>= *t* (* 0.999 *autoexit*)) (not (eql *autoexit* 0)))
 161           (setf *running* nil))))))
 162
 163
 164 (defun animate()
 165   (setf *angle* (coerce (+ *angle* (* 100.0 *dt*)) 'single-float)))
 166
 167 (defun init-gl ()
 168   (let ((pos (cffi:foreign-alloc 'gl:float :initial-contents '(5.0 5.0 10.0 0.0)))
 169        (red (cffi:foreign-alloc 'gl:float :initial-contents '(0.8 0.1 0.0 1.0)))
 170        (green (cffi:foreign-alloc 'gl:float :initial-contents '(0.0 0.8 0.2 1.0)))
 171        (blue (cffi:foreign-alloc 'gl:float :initial-contents '(0.2 0.2 1.0 1.0)))
 172        (command-line (or
 173          #+sbcl sb-ext:*posix-argv*
 174          #+lispworks system:*line-arguments-list*
 175          #+cmu extensions:*command-line-words*
 176          nil)))
 177     (gl:light-fv gl:+light0+ gl:+position+ pos)
 178     (gl:enable gl:+cull-face+)
 179     (gl:enable gl:+lighting+)
 180     (gl:enable gl:+light0+)
 181     (gl:enable gl:+depth-test+)
 182
 183     ;; make the gears
 184     (setf *gear1* (gl:gen-lists 1))
 185     (gl:new-list *gear1* gl:+compile+) ; glNewList(gear1, GL_COMPILE);
 186     (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ red) ; glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, red);
 187     (gear 1.0 4.0 1.0 20 0.7) ; gear(1.0, 4.0, 1.0, 20, 0.7);
 188     (gl:end-list) ; glEndList();
 189
 190     (setf *gear2* (gl:gen-lists 1)) ; gear2 = glGenLists(1);
 191     (gl:new-list *gear2* gl:+compile+) ; glNewList(gear2, GL_COMPILE);
 192     (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ green) ; glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, green);
 193     (gear 0.5 2.0 2.0 10 0.7) ; gear(0.5, 2.0, 2.0, 10, 0.7);
 194     (gl:end-list) ; glEndList();
 195
 196     (setf *gear3* (gl:gen-lists 1)) ; gear3 = glGenLists(1);
 197     (gl:new-list *gear3* gl:+compile+) ; glNewList(gear3, GL_COMPILE);
 198     (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ blue) ; glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, blue);
 199     (gear 1.3 2.0 0.5 10 0.7) ; gear(1.3, 2.0, 0.5, 10, 0.7);
 200     (gl:end-list) ; glEndList();
 201
 202     (gl:enable gl:+normalize+) ; glEnable(GL_NORMALIZE);
 203
 204     ;; did we get -info or -exit?
 205     (dolist (arg command-line)
 206       (cond ((string= arg "-info")
 207               (format t "GL_RENDERER   = ~s~%GL_VERSION    = ~s~%GL_VENDOR     = ~s~%GL_EXTENSIONS = ~s~%"
 208                 (gl:get-string gl:+renderer+)
 209                 (gl:get-string gl:+version+)
 210                 (gl:get-string gl:+vendor+)
 211                 (gl:get-string gl:+extensions+)))
 212             ((string= arg "-exit")
 213               (progn
 214                 (setf *autoexit* 30)
 215                 (format t "Auto Exit after ~d seconds.~%" *autoexit*)))))
 216
 217     (cffi:foreign-free pos)
 218     (cffi:foreign-free red)
 219     (cffi:foreign-free green)
 220     (cffi:foreign-free blue)))
 221
 222 (cffi:defcallback key-callback :void ((key :int) (action :int))
 223   (when (eql action glfw:+press+)
 224     (cond ((eql key (char-code #\Z))
 225             (if (eql (glfw:get-key glfw:+key-lshift+) glfw:+press+)
 226               (decf *view_rotz* 5.0)
 227               (incf *view_rotz* 5.0)))
 228           ((eql key glfw:+key-esc+)
 229             (setf *running* nil))
 230           ((eql key glfw:+key-up+)
 231             (incf *view_rotx* 5.0))
 232           ((eql key glfw:+key-down+)
 233             (decf *view_rotx* 5.0))
 234           ((eql key glfw:+key-left+)
 235             (incf *view_roty* 5.0))
 236           ((eql key glfw:+key-right+)
 237             (decf *view_roty* 5.0)))))
 238
 239 (cffi:defcallback window-size-callback :void ((width :int) (height :int))
 240   (let* ((h (/ height width))
 241         (znear 5.0d0)
 242         (zfar 30.0d0)
 243         (xmax (* znear 0.5d0)))
 244
 245     (gl:viewport 0 0 width height)
 246     (gl:matrix-mode gl:+projection+)
 247     (gl:load-identity)
 248     (gl:frustum (- xmax) xmax (* (- xmax) h) (* xmax h) znear zfar)
 249     (gl:matrix-mode gl:+modelview+)
 250     (gl:load-identity)
 251     (gl:translate-f 0.0 0.0 -20.0)
 252   ))
 253
 254 (glfw:init)
 255 (if (eql (glfw:open-window 300 300 0 0 0 0 16 0 glfw:+window+) 0)
 256   (progn
 257     (glfw:terminate)
 258     (error "Could not initialize a window.")))
 259 (glfw:set-window-title "Gears")
 260 (glfw:enable glfw:+key-repeat+)
 261 (glfw:swap-interval 0)
 262
 263 ;; launch OpenGL with our settings
 264 (init-gl)
 265
 266 (glfw:set-window-size-callback (cffi:callback window-size-callback))
 267 (glfw:set-key-callback (cffi:callback key-callback))
 268
 269 ;; program loop
 270 (do () ((eql *running* nil))
 271   (draw)
 272   (animate)
 273   (glfw:swap-buffers)
 274   (setf *running* (and *running* (> (glfw:get-window-param glfw:+opened+) 0)))
 275 )
 276
 277 (glfw:terminate)