examples/gears.lisp

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