2 (asdf:oos
'asdf
:load-op
'#:cl-glfw
)
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
)
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)))
17 (da (/ (/ (* 2 pi
) teeth
) 4)))
18 (gl:shade-model gl
:+flat
+)
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))
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
))))
33 ;; draw front sides of teeth
34 (gl:with-begin gl
:+quads
+
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))))
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))
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)))))
54 ;; draw back sides of teeth
55 (gl:with-begin gl
:+quads
+
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))))
63 ;; draw outward faces of teeth
64 (gl:with-begin gl
:+quad-strip
+
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
)))))
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)))
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)))
91 (gl:shade-model gl
:+smooth
+)
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))))))
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
117 (when (and (not (zerop *autoexit
*))
118 (>= t1
(* 0.999 *autoexit
*)))
119 (glfw:close-window
)))
122 (gl:clear
(logior gl
:+color-buffer-bit
+ gl
:+depth-buffer-bit
+))
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)
129 (gl:translate-f -
3 -
2 0)
130 (gl:rotate-f angle
0 0 1)
131 (gl:call-list
*gear1
*))
134 (gl:translate-f
3.1 -
2 0)
135 (gl:rotate-f
(- (* -
2 angle
) 9) 0 0 1)
136 (gl:call-list
*gear2
*))
139 (gl:translate-f -
3.1 4.2 0)
140 (gl:rotate-f
(- (* -
2 angle
) 25) 0 0 1)
141 (gl:call-list
*gear3
*)))
146 (setf angle
(coerce (+ angle
(* 100 (- t1 t0
))) 'single-float
))))
149 (gl:enable gl
:+cull-face
+)
150 (gl:enable gl
:+lighting
+)
151 (gl:enable gl
:+light0
+)
152 (gl:enable gl
:+depth-test
+)
154 (gl:light-fv gl
:+light0
+ gl
:+position
+ #(5.0
5.0 10.0 0.0))
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))
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))
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))
169 (gl:enable gl
:+normalize
+)
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
*
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")
184 (format t
"Auto Exit after ~d seconds.~%" *autoexit
*)))))
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
+)
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)))))
198 (cffi:defcallback window-size-callback
:void
((width :int
) (height :int
))
199 (let* ((h (/ height width
))
202 (xmax (* znear
0.5)))
204 (gl:viewport
0 0 width height
)
205 (gl:with-setup-projection
206 (gl:frustum
(- xmax
) xmax
(* (- xmax
) h
) (* xmax h
) znear zfar
))
209 (gl:translate-f
0 0 -
20)))
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)
216 (glfw:set-window-size-callback
(cffi:callback window-size-callback
))
217 (glfw:set-key-callback
(cffi:callback key-callback
)))