source: project/release/3/glut/gears.scm @ 7700

Last change on this file since 7700 was 1908, checked in by felix winkelmann, 14 years ago

glut/opengl split, inline fix

File size: 9.0 KB
Line 
1;; $Id: gears.ss,v 1.36 2002/12/10 06:19:48 neil Exp $
2;;
3;; This is a version of the venerable "gears" demo for PLT Scheme 200 using
4;; Scott Owens' SGL OpenGL bindings.  It was ported from "glxgears.c" 1.3 from
5;; XFree86, which had the following notices:
6;;
7;;     Copyright (C) 1999-2001  Brian Paul   All Rights Reserved.
8;;
9;;     Permission is hereby granted, free of charge, to any person obtaining a
10;;     copy of this software and associated documentation files (the
11;;     "Software"), to deal in the Software without restriction, including
12;;     without limitation the rights to use, copy, modify, merge, publish,
13;;     distribute, sublicense, and/or sell copies of the Software, and to
14;;     permit persons to whom the Software is furnished to do so, subject to
15;;     the following conditions:
16;;
17;;     The above copyright notice and this permission notice shall be included
18;;     in all copies or substantial portions of the Software.
19;;
20;;     XFree86: xc/programs/glxgears/glxgears.c,v 1.3 2001/11/03 17:29:20 dawes
21;;
22;;     This is a port of the infamous "gears" demo to straight GLX (i.e. no
23;;     GLUT).  Port by Brian Paul 23 March 2001.
24;;
25;; To run, evaluate this file in DrScheme, or execute "mred -r gears.ss"
26;; from your OS shell.  If your version of SGL is missing "gl:End-list", then
27;; add a line "void glEndList( void );" to file "collects/sgl/gl-specs/gl11.h",
28;; and execute "setup-plt -l sgl".
29;;
30;; Scheme port by Neil W. Van Dyke <neil@neilvandyke.org>, 23 November 2002.
31;; Originally called glxgears.ss.  Minor modifications since.
32;; See "http://www.neilvandyke.org/opengl-plt/" for more information.
33;;
34;; Ported to Chicken by Felix L. Winkelmann
35
36(require-extension srfi-4 gl glut)
37
38(define pi 3.14)
39
40(define rotation 0.0)
41
42(define view-rotx 20.0)
43(define view-roty 30.0)
44(define view-rotz 0.0)
45
46(define gear1 #f)
47(define gear2 #f)
48(define gear3 #f)
49
50(define step? #f)
51
52(define refresh glut:PostRedisplay)
53
54(define (run)
55  (set! step? #t)
56  (refresh))
57
58(define (move-left)
59  (set! view-roty (+ view-roty 5.0)))
60
61(define (move-right)
62  (set! view-roty (- view-roty 5.0)))
63
64(define (move-up)
65  (set! view-rotx (+ view-rotx 5.0)))
66
67(define (move-down)
68  (set! view-rotx (- view-rotx 5.0)))
69
70(define (build-gear inner-radius    ; radius of hole at center
71                    outer-radius    ; radius at center of teeth
72                    width           ; width of gear
73                    teeth           ; number of teeth
74                    tooth-depth)    ; depth of tooth
75  (let* ((r0             inner-radius)
76         (r1             (- outer-radius (/ tooth-depth 2.0)))
77         (r2             (+ outer-radius (/ tooth-depth 2.0)))
78         (da             (/ (* 2.0 pi) teeth 4.0))
79         (da2            (* da 2))
80         (da3            (* da 3))
81         (half-width     (* width 0.5))
82         (neg-half-width (- half-width)))
83
84    ;; TODO: Generalize away some more redundant program text.
85
86    (gl:ShadeModel gl:FLAT)
87
88    (gl:Normal3f 0.0 0.0 1.0)
89
90    ;; Draw front face.
91    (gl:Begin gl:QUAD_STRIP)
92    (do ((i 0 (+ 1 i))) ((> i teeth))
93      (let* ((angle     (/ (* i 2.0 pi) teeth))
94             (cos-angle (cos angle))
95             (sin-angle (sin angle)))
96        (gl:Vertex3f (* r0 cos-angle) (* r0 sin-angle) half-width)
97        (gl:Vertex3f (* r1 cos-angle) (* r1 sin-angle) half-width)
98        (when (< i teeth)
99          (gl:Vertex3f (* r0 cos-angle)
100                       (* r0 sin-angle)
101                       (* half-width))
102          (gl:Vertex3f (* r1 (cos (+ angle da3)))
103                       (* r1 (sin (+ angle da3)))
104                       half-width))))
105    (gl:End)
106
107    ;; Draw front sides of teeth.
108    (gl:Begin gl:QUADS)
109    (do ((i 0 (+ 1 i))) ((= i teeth))
110      (let ((angle (/ (* i 2.0 pi) teeth)))
111        (gl:Vertex3f (* r1 (cos angle))
112                     (* r1 (sin angle))
113                     half-width)
114        (gl:Vertex3f (* r2 (cos (+ angle da)))
115                     (* r2 (sin (+ angle da)))
116                     half-width)
117        (gl:Vertex3f (* r2 (cos (+ angle da2)))
118                     (* r2 (sin (+ angle da2)))
119                     half-width)
120        (gl:Vertex3f (* r1 (cos (+ angle da3)))
121                     (* r1 (sin (+ angle da3)))
122                     half-width)))
123    (gl:End)
124
125    (gl:Normal3f 0.0 0.0 -1.0)
126
127    ;; Draw back face.
128    (gl:Begin gl:QUAD_STRIP)
129    (do ((i 0 (+ 1 i))) ((> i teeth))
130      (let* ((angle     (/ (* i 2.0 pi) teeth))
131             (cos-angle (cos angle))
132             (sin-angle (sin angle)))
133        (gl:Vertex3f (* r1 cos-angle) (* r1 sin-angle) neg-half-width)
134        (gl:Vertex3f (* r0 cos-angle) (* r0 sin-angle) neg-half-width)
135        (when (< i teeth)
136          (gl:Vertex3f (* r1 (cos (+ angle da3)))
137                       (* r1 (sin (+ angle da3)))
138                       neg-half-width)
139          (gl:Vertex3f (* r0 cos-angle)
140                       (* r0 sin-angle)
141                       neg-half-width))))
142    (gl:End)
143
144    ;; Draw back sides of teeth.
145    (gl:Begin gl:QUADS)
146    (do ((i 0 (+ 1 i))) ((= i teeth))
147      (let ((angle (/ (* i 2.0 pi) teeth)))
148        (gl:Vertex3f (* r1 (cos (+ angle da3)))
149                     (* r1 (sin (+ angle da3)))
150                     neg-half-width)
151        (gl:Vertex3f (* r2 (cos (+ angle da2)))
152                     (* r2 (sin (+ angle da2)))
153                     neg-half-width)
154        (gl:Vertex3f (* r2 (cos (+ angle da)))
155                     (* r2 (sin (+ angle da)))
156                     neg-half-width)
157        (gl:Vertex3f (* r1 (cos angle))
158                     (* r1 (sin angle))
159                     neg-half-width)))
160    (gl:End)
161
162    ;; Draw outward faces of teeth.
163    (gl:Begin gl:QUAD_STRIP)
164    (do ((i 0 (+ 1 i))) ((= i teeth))
165      (let* ((angle     (/ (* i 2.0 pi) teeth))
166             (cos-angle (cos angle))
167             (sin-angle (sin angle)))
168
169        (gl:Vertex3f (* r1 cos-angle) (* r1 sin-angle) half-width)
170        (gl:Vertex3f (* r1 cos-angle) (* r1 sin-angle) neg-half-width)
171
172        (let* ((u   (- (* r2 (cos (+ angle da))) (* r1 cos-angle)))
173               (v   (- (* r2 (sin (+ angle da))) (* r1 sin-angle)))
174               (len (sqrt (+ (* u u) (* v v)))))
175          (gl:Normal3f (/ v len) (- (/ u len)) 0.0))
176
177        (gl:Vertex3f (* r2 (cos (+ angle da)))
178                     (* r2 (sin (+ angle da)))
179                     half-width)
180        (gl:Vertex3f (* r2 (cos (+ angle da)))
181                     (* r2 (sin (+ angle da)))
182                     neg-half-width)
183        (gl:Normal3f cos-angle sin-angle 0.0)
184        (gl:Vertex3f (* r2 (cos (+ angle da2)))
185                     (* r2 (sin (+ angle da2)))
186                     half-width)
187        (gl:Vertex3f (* r2 (cos (+ angle da2)))
188                     (* r2 (sin (+ angle da2)))
189                     neg-half-width)
190
191        (let ((u (- (* r1 (cos (+ angle da3)))
192                    (* r2 (cos (+ angle da2)))))
193              (v (- (* r1 (sin (+ angle da3)))
194                    (* r2 (sin (+ angle da2))))))
195          (gl:Normal3f v (- u) 0.0))
196
197        (gl:Vertex3f (* r1 (cos (+ angle da3)))
198                     (* r1 (sin (+ angle da3)))
199                     half-width)
200        (gl:Vertex3f (* r1 (cos (+ angle da3)))
201                     (* r1 (sin (+ angle da3)))
202                     neg-half-width)
203        (gl:Normal3f cos-angle sin-angle 0.0)))
204
205    (gl:Vertex3f (* r1 (cos 0)) (* r1 (sin 0)) half-width)
206    (gl:Vertex3f (* r1 (cos 0)) (* r1 (sin 0)) neg-half-width)
207    (gl:End)
208
209    (gl:ShadeModel gl:SMOOTH)
210
211    ;; Draw inside radius cylinder.
212    (gl:Begin gl:QUAD_STRIP)
213    (do ((i 0 (+ 1 i))) ((> i teeth))
214      (let* ((angle     (/ (* i 2.0 pi) teeth))
215             (cos-angle (cos angle))
216             (sin-angle (sin angle)))
217        (gl:Normal3f (- cos-angle) (- sin-angle) 0.0)
218        (gl:Vertex3f (* r0 cos-angle) (* r0 sin-angle) neg-half-width)
219        (gl:Vertex3f (* r0 cos-angle) (* r0 sin-angle) half-width)))
220    (gl:End)))
221
222(define (on-size width height)
223  (gl:Viewport 0 0 width height)
224  (gl:MatrixMode gl:PROJECTION)
225  (gl:LoadIdentity)
226  (let ((h (/ height width)))
227    (gl:Frustum -1.0 1.0 (- h) h 5.0 60.0))
228  (gl:MatrixMode gl:MODELVIEW)
229  (gl:LoadIdentity)
230  (gl:Translatef 0.0 0.0 -40.0)
231
232  (gl:Lightfv gl:LIGHT0 gl:POSITION (f32vector 5.0 5.0 10.0 0.0))
233  (gl:Enable gl:CULL_FACE)
234  (gl:Enable gl:LIGHTING)
235  (gl:Enable gl:LIGHT0)
236  (gl:Enable gl:DEPTH_TEST)
237
238  (unless gear1
239
240    (set! gear1 (gl:GenLists 1))
241    (gl:NewList gear1 gl:COMPILE)
242    (gl:Materialfv gl:FRONT
243                   gl:AMBIENT_AND_DIFFUSE
244                   (f32vector 0.8 0.1 0.0 1.0))
245    (build-gear 1.0 4.0 1.0 20 0.7)
246    (gl:EndList)
247
248    (set! gear2 (gl:GenLists 1))
249    (gl:NewList gear2 gl:COMPILE)
250    (gl:Materialfv gl:FRONT
251                   gl:AMBIENT_AND_DIFFUSE
252                   (f32vector 0.0 0.8 0.2 1.0))
253    (build-gear 0.5 2.0 2.0 10 0.7)
254    (gl:EndList)
255
256    (set! gear3 (gl:GenLists 1))
257    (gl:NewList gear3 gl:COMPILE)
258    (gl:Materialfv gl:FRONT
259                   gl:AMBIENT_AND_DIFFUSE
260                   (f32vector 0.2 0.2 1.0 1.0))
261    (build-gear 1.3 2.0 0.5 10 0.7)
262    (gl:EndList)
263
264    (gl:Enable gl:NORMALIZE)) )
265
266(define (on-paint)
267  ;; TODO: Add FPS instrumentation.
268  (when step?
269    ;; TODO: Don't increment this infinitely.
270    (set! rotation (+ 2.0 rotation)))
271
272  (gl:Clear (+ gl:COLOR_BUFFER_BIT gl:DEPTH_BUFFER_BIT))
273 
274  (gl:PushMatrix)
275  (gl:Rotatef view-rotx 1.0 0.0 0.0)
276  (gl:Rotatef view-roty 0.0 1.0 0.0)
277  (gl:Rotatef view-rotz 0.0 0.0 1.0)
278
279  (gl:PushMatrix)
280  (gl:Translatef -3.0 -2.0 0.0)
281  (gl:Rotatef rotation 0.0 0.0 1.0)
282  (gl:CallList gear1)
283  (gl:PopMatrix)
284
285  (gl:PushMatrix)
286  (gl:Translatef 3.1 -2.0 0.0)
287  (gl:Rotatef (- (* -2.0 rotation) 9.0) 0.0 0.0 1.0)
288  (gl:CallList gear2)
289  (gl:PopMatrix)
290
291  (gl:PushMatrix)
292  (gl:Translatef -3.1 4.2 0.0)
293  (gl:Rotatef (- (* -2.0 rotation) 25.0) 0.0 0.0 1.0)
294  (gl:CallList gear3)
295  (gl:PopMatrix)
296
297  (gl:PopMatrix)
298  (glut:SwapBuffers) )
299
300(glut:InitDisplayMode (+ glut:DOUBLE glut:DEPTH))
301(glut:CreateWindow "gears")
302(glut:ReshapeFunc on-size)
303(glut:DisplayFunc on-paint)
304(glut:IdleFunc run)
305(glut:KeyboardFunc (lambda _ (exit)))
306
307(gl:ClearColor 0.0 0.0 0.0 0)
308
309(glut:MainLoop)
Note: See TracBrowser for help on using the repository browser.