examples/gears.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
   5 (defparameter *autoexit* 0)
   6 (defparameter *view-rotx* 20)
   7 (defparameter *view-roty* 30)
   8 (defparameter *view-rotz* 0)
   9 (defparameter *gear1* nil)
  10 (defparameter *gear2* nil)
  11 (defparameter *gear3* nil)
  12
  13 (defun gear (inner-radius outer-radius width teeth tooth-depth)
  14   (let ((r0 inner-radius)
  15         (r1 (- outer-radius (/ tooth-depth 2)))
  16         (r2 (+ outer-radius (/ tooth-depth 2)))
  17         (angle 0)
  18         (da (/ (/ (* 2 pi) teeth) 4)))
  19     (gl:shade-model gl:+flat+)
  20     (gl:normal-3f 0 0 1)
  21
  22     ;; draw front face
  23     (gl:with-begin gl:+quad-strip+
  24       (dotimes (i (1+ teeth))
  25         (setf angle (/ (* i 2 pi) teeth))
  26         (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
  27         (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
  28         (when (< i teeth)
  29           (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
  30           (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
  31                         (* r1 (sin (+ angle (* 3 da))))
  32                         (* width 0.5)))))
  33
  34     ;; draw front sides of teeth
  35     (gl:with-begin gl:+quads+
  36       (dotimes (i teeth)
  37         (setf angle (/ (* i 2 pi) teeth))
  38         (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
  39         (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5))
  40         (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5))
  41         (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))
  42
  43     (gl:normal-3f 0 0 -1)
  44
  45     ;; draw back face
  46     (gl:with-begin gl:+quad-strip+
  47       (dotimes (i (1+ teeth))
  48         (setf angle (/ (* i 2 pi) teeth))
  49         (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))
  50         (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5))
  51         (when (< i teeth)
  52           (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5))
  53           (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5)))))
  54
  55     ;; draw back sides of teeth
  56     (gl:with-begin gl:+quads+
  57       (dotimes (i teeth)
  58         (setf angle (/ (* i 2 pi) teeth))
  59         (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5))
  60         (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5))
  61         (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5))
  62         (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))))
  63
  64     ;; draw outward faces of teeth
  65     (gl:with-begin gl:+quad-strip+
  66       (dotimes (i teeth)
  67         (setf angle (/ (* i 2 pi) teeth))
  68         (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
  69         (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))
  70         (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
  71                (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
  72                (len (sqrt (+ (* u u) (* v v)))))
  73
  74           (setf u (/ u len))
  75           (setf v (/ v len))
  76           (gl:normal-3f v (- u) 0)
  77           (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5))
  78           (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5))
  79           (gl:normal-3f (cos angle) (sin angle) 0)
  80           (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5))
  81           (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5))
  82           (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))))
  83           (setf v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da))))))
  84           (gl:normal-3f v (- u) 0)
  85           (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))
  86           (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5))
  87           (gl:normal-3f (cos angle) (sin angle) 0)))
  88
  89       (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
  90       (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5)))
  91
  92     (gl:shade-model gl:+smooth+)
  93
  94     ;; draw inside radius cylinder */
  95     (gl:with-begin gl:+quad-strip+
  96       (dotimes (i (1+ teeth))
  97         (setf angle (/ (* i 2 pi) teeth))
  98         (gl:normal-3f (- (cos angle)) (- (sin angle)) 0)
  99         (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5))
 100         (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))))
 101
 102 (let ((frames 0)
 103       (angle 0)
 104       (t-last-report 0)
 105       (t0 0)
 106       (t1 0))
 107
 108   (defun report-fps ()
 109     (incf frames)
 110     (setf t0 t1
 111           t1 (glfw:get-time))
 112     (when (>= (- t1 t-last-report) 5)
 113       (let* ((seconds (- t1 t-last-report))
 114              (fps (/ frames seconds)))
 115         (format t "~d frames in ~3$ seconds = ~3$ FPS~%" frames seconds fps))
 116       (setf t-last-report t1
 117             frames 0))
 118     (when (and (not (zerop *autoexit*))
 119                (>= t1 (* 0.999 *autoexit*)))
 120       (glfw:close-window)))
 121
 122   (defun draw ()
 123     (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+))
 124     (gl:with-push-matrix
 125       (gl:rotate-f *view-rotx* 1 0 0)
 126       (gl:rotate-f *view-roty* 0 1 0)
 127       (gl:rotate-f *view-rotz* 0 0 1)
 128
 129       (gl:with-push-matrix
 130         (gl:translate-f -3 -2 0)
 131         (gl:rotate-f angle 0 0 1)
 132         (gl:call-list *gear1*))
 133
 134       (gl:with-push-matrix
 135         (gl:translate-f 3.1 -2 0)
 136         (gl:rotate-f (- (* -2 angle) 9) 0 0 1)
 137         (gl:call-list *gear2*))
 138
 139       (gl:with-push-matrix
 140         (gl:translate-f -3.1 4.2 0)
 141         (gl:rotate-f (- (* -2 angle) 25) 0 0 1)
 142         (gl:call-list *gear3*)))
 143     (report-fps))
 144
 145
 146   (defun animate()
 147     (setf angle (coerce (+ angle (* 100 (- t1 t0))) 'single-float))))
 148
 149 (defun init-gl ()
 150   (gl:enable gl:+cull-face+)
 151   (gl:enable gl:+lighting+)
 152   (gl:enable gl:+light0+)
 153   (gl:enable gl:+depth-test+)
 154
 155   (gl:light-fv gl:+light0+ gl:+position+ #(5.0 5.0 10.0 0.0))
 156
 157   ;; make the gears
 158   (gl:with-new-list (setf *gear1* (gl:gen-lists 1)) gl:+compile+
 159     (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ #(0.8 0.1 0.0 1.0))
 160     (gear 1 4 1 20 0.7))
 161
 162   (gl:with-new-list (setf *gear2* (gl:gen-lists 1)) gl:+compile+
 163     (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ #(0.0 0.8 0.2 1.0))
 164     (gear 0.5 2 2 10 0.7))
 165
 166   (gl:with-new-list (setf *gear3* (gl:gen-lists 1)) gl:+compile+
 167     (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ #(0.2 0.2 1.0 1.0))
 168     (gear 1.3 2 0.5 10 0.7))
 169
 170   (gl:enable gl:+normalize+)
 171
 172   ;; did we get -info or -exit?
 173   (dolist (arg (or #+sbcl sb-ext:*posix-argv*
 174                    #+lispworks system:*line-arguments-list*
 175                    #+cmu extensions:*command-line-words*
 176                    nil))
 177     (cond ((string= arg "-info")
 178            (format t "GL_RENDERER   = ~s~%GL_VERSION    = ~s~%GL_VENDOR     = ~s~%GL_EXTENSIONS = ~s~%"
 179                    (gl:get-string gl:+renderer+)
 180                    (gl:get-string gl:+version+)
 181                    (gl:get-string gl:+vendor+)
 182                    (gl:get-string gl:+extensions+)))
 183           ((string= arg "-exit")
 184            (setf *autoexit* 30)
 185            (format t "Auto Exit after ~d seconds.~%" *autoexit*)))))
 186
 187 (defun key-callback (key action)
 188   (when (eql action glfw:+press+)
 189     (case key
 190       (#\Z (if (eql (glfw:get-key glfw:+key-lshift+) glfw:+press+)
 191                (decf *view-rotz* 5)
 192                (incf *view-rotz* 5)))
 193       (:esc   (glfw:close-window))
 194       (:up    (incf *view-rotx* 5))
 195       (:down  (decf *view-rotx* 5))
 196       (:left  (incf *view-roty* 5))
 197       (:right (decf *view-roty* 5)))))
 198
 199 (defun window-size-callback (width height)
 200   (let* ((h (/ height width))
 201          (znear 5)
 202          (zfar 30)
 203          (xmax (* znear 0.5)))
 204
 205     (gl:viewport 0 0 width height)
 206     (gl:with-setup-projection
 207       (gl:frustum (- xmax) xmax (* (- xmax) h) (* xmax h) znear zfar))
 208
 209     (gl:load-identity)
 210     (gl:translate-f 0 0 -20)))
 211
 212 ;; program loop
 213 (glfw:do-window (:title "Gears" :width 300 :height 300 :depthbits 16 :mode glfw:+window+)
 214     ((glfw:enable glfw:+key-repeat+)
 215      (glfw:swap-interval 0)
 216      (init-gl)
 217      (glfw:set-window-size-callback 'window-size-callback)
 218      (glfw:set-key-callback 'key-callback))
 219   (draw)
 220   (animate)
 221   (glfw:swap-buffers))