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