346 lines
10 KiB
Scheme
Executable File
346 lines
10 KiB
Scheme
Executable File
#!/usr/bin/env ikarus --r6rs-script
|
|
;;
|
|
;; 3-D gear wheels. This program is in the public domain.
|
|
;;
|
|
;; Brian Paul
|
|
;;
|
|
;; Conversion to GLUT by Mark J. Kilgard
|
|
;; Conversion to GtkGLExt by Naofumi Yasufuku
|
|
;; Port to Scheme/Gauche(GtkGLExt) by Shiro Kawai
|
|
;; Port to Scheme/Gauche(GLUT) by YOKOTA Hiroshi
|
|
;; Port to Ypsilon by YOKOTA Hiroshi
|
|
|
|
(import (ypsilon-compat) (rnrs) (rnrs programs) (gl) (glut))
|
|
|
|
;; These constant values are not defined in Ypsilon yet
|
|
(define pi 3.14159265358979323846)
|
|
(define GLUT_ELAPSED_TIME 700)
|
|
|
|
(define (f32vector . lst)
|
|
(define-syntax f32set!
|
|
(syntax-rules ()
|
|
((_ bv n value)
|
|
(bytevector-ieee-single-native-set! bv (* n 4) value))))
|
|
(let ((bv (make-bytevector (* (length lst) 4))))
|
|
(let loop ((i 0) (lst lst))
|
|
(cond ((null? lst) bv)
|
|
(else
|
|
(f32set! bv i (car lst))
|
|
(loop (+ i 1) (cdr lst)))))))
|
|
|
|
(define (/. a b)
|
|
(/ (inexact a) (inexact b)))
|
|
|
|
(define (c-int->c-uchar c)
|
|
(bitwise-and c #xff))
|
|
|
|
;; Draw a gear wheel. You'll probably want to call this function when
|
|
;; building a display list since we do a lot of trig here.
|
|
;;
|
|
;; Input: inner_radius - radius of hole at center
|
|
;; outer_radius - radius at center of teeth
|
|
;; width - width of gear
|
|
;; teeth - number of teeth
|
|
;; tooth_depth - depth of tooth
|
|
|
|
(define (gear inner-radius outer-radius width teeth tooth-depth)
|
|
(let ((r0 inner-radius)
|
|
(r1 (- outer-radius (/ tooth-depth 2.0)))
|
|
(r2 (+ outer-radius (/ tooth-depth 2.0)))
|
|
(da (* 2.0 (/ pi teeth 4.0))))
|
|
(glShadeModel GL_FLAT)
|
|
(glNormal3f 0.0 0.0 1.0)
|
|
|
|
;; draw front face
|
|
(glBegin GL_QUAD_STRIP)
|
|
(do ((i 0.0 (+ i 1.0))) ((>= i (+ teeth 1.0)))
|
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width 0.5))
|
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width 0.5))
|
|
(when (< i teeth)
|
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width 0.5))
|
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
|
(* width 0.5)))))
|
|
(glEnd)
|
|
|
|
;; draw front sides of teeth
|
|
(glBegin GL_QUADS)
|
|
(do ((i 0.0 (+ i 1.0))) ((>= i teeth))
|
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width 0.5))
|
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
|
(* r2 (sin (+ _angle da)))
|
|
(* width 0.5))
|
|
(glVertex3f (* r2 (cos (+ _angle (* 2.0 da))))
|
|
(* r2 (sin (+ _angle (* 2.0 da))))
|
|
(* width 0.5))
|
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
|
(* width 0.5))))
|
|
(glEnd)
|
|
|
|
(glNormal3f 0.0 0.0 -1.0)
|
|
|
|
;; draw back face
|
|
(glBegin GL_QUAD_STRIP)
|
|
(do ((i 0.0 (+ i 1.0))) ((>= i (+ teeth 1.0)))
|
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width -0.5))
|
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width -0.5))
|
|
(when (< i teeth)
|
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
|
(* width -0.5))
|
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width -0.5)))))
|
|
(glEnd)
|
|
|
|
;; draw back sides of teeth
|
|
(glBegin GL_QUADS)
|
|
(do ((i 0.0 (+ i 1.0))) ((>= i teeth))
|
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
|
(* width -0.5))
|
|
(glVertex3f (* r2 (cos (+ _angle (* 2.0 da))))
|
|
(* r2 (sin (+ _angle (* 2.0 da))))
|
|
(* width -0.5))
|
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
|
(* r2 (sin (+ _angle da)))
|
|
(* width -0.5))
|
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width -0.5))))
|
|
(glEnd)
|
|
|
|
;; draw outward faces of teeth
|
|
(glBegin GL_QUAD_STRIP)
|
|
(do ((i 0.0 (+ i 1.0))) ((>= i teeth))
|
|
(let ((_angle (* i 2.0 (/ pi teeth)))
|
|
(u 0.0)
|
|
(v 0.0)
|
|
(len 0.0))
|
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width 0.5))
|
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width -0.5))
|
|
|
|
(set! u (- (* r2 (cos (+ _angle da))) (* r1 (cos _angle))))
|
|
(set! v (- (* r2 (sin (+ _angle da))) (* r1 (sin _angle))))
|
|
(set! len (sqrt (+ (* u u) (* v v))))
|
|
;; canonicalize normal vector
|
|
(set! u (/ u len))
|
|
(set! v (/ v len))
|
|
|
|
(glNormal3f v (- u) 0.0)
|
|
|
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
|
(* r2 (sin (+ _angle da)))
|
|
(* width 0.5))
|
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
|
(* r2 (sin (+ _angle da)))
|
|
(* width -0.5))
|
|
(glNormal3f (cos _angle) (sin _angle) 0.0)
|
|
(glVertex3f (* r2 (cos (+ _angle (* 2 da))))
|
|
(* r2 (sin (+ _angle (* 2 da))))
|
|
(* width 0.5))
|
|
(glVertex3f (* r2 (cos (+ _angle (* 2 da))))
|
|
(* r2 (sin (+ _angle (* 2 da))))
|
|
(* width -0.5))
|
|
|
|
(set! u (- (* r1 (cos (+ _angle (* 3 da))))
|
|
(* r2 (cos (+ _angle (* 2 da))))))
|
|
(set! v (- (* r1 (sin (+ _angle (* 3 da))))
|
|
(* r2 (sin (+ _angle (* 2 da))))))
|
|
|
|
(glNormal3f v (- u) 0.0)
|
|
|
|
(glVertex3f (* r1 (cos (+ _angle (* 3 da))))
|
|
(* r1 (sin (+ _angle (* 3 da))))
|
|
(* width 0.5))
|
|
(glVertex3f (* r1 (cos (+ _angle (* 3 da))))
|
|
(* r1 (sin (+ _angle (* 3 da))))
|
|
(* width -0.5))
|
|
(glNormal3f (cos _angle) (sin _angle) 0.0)))
|
|
(glVertex3f (* r1 (cos 0.0)) (* r1 (sin 0.0)) (* width 0.5))
|
|
(glVertex3f (* r1 (cos 0.0)) (* r1 (sin 0.0)) (* width -0.5))
|
|
(glEnd)
|
|
|
|
(glShadeModel GL_SMOOTH)
|
|
|
|
;; draw inside radius cylinder
|
|
(glBegin GL_QUAD_STRIP)
|
|
(do ((i 0.0 (+ i 1.0))) ((>= i (+ teeth 1.0)))
|
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
|
(glNormal3f (- (cos _angle)) (- (sin _angle)) 0.0)
|
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width -0.5))
|
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width 0.5))))
|
|
(glEnd)
|
|
))
|
|
|
|
(define *view-rotx* 20.0)
|
|
(define *view-roty* 30.0)
|
|
(define *view-rotz* 0.0)
|
|
(define *gear1* #f)
|
|
(define *gear2* #f)
|
|
(define *gear3* #f)
|
|
(define *angle* 0.0)
|
|
(define *frames* 0)
|
|
(define *t0* 0)
|
|
(define *win* #f)
|
|
|
|
(define (cleanup)
|
|
(glDeleteLists *gear1* 1)
|
|
(glDeleteLists *gear2* 1)
|
|
(glDeleteLists *gear3* 1)
|
|
(glutDestroyWindow *win*))
|
|
|
|
(define (draw)
|
|
;;*** OpenGL BEGIN ***
|
|
(glClear (bitwise-ior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
|
|
(begin
|
|
(glPushMatrix)
|
|
(glRotatef *view-rotx* 1.0 0.0 0.0)
|
|
(glRotatef *view-roty* 0.0 1.0 0.0)
|
|
(glRotatef *view-rotz* 0.0 0.0 1.0)
|
|
(begin
|
|
(glPushMatrix)
|
|
(glTranslatef -3.0 -2.0 0.0)
|
|
(glRotatef *angle* 0.0 0.0 1.0)
|
|
(glCallList *gear1*)
|
|
(glPopMatrix))
|
|
(begin
|
|
(glPushMatrix)
|
|
(glTranslatef 3.1 -2.0 0.0)
|
|
(glRotatef (- (* -2.0 *angle*) 9.0) 0.0 0.0 1.0)
|
|
(glCallList *gear2*)
|
|
(glPopMatrix))
|
|
(begin
|
|
(glPushMatrix)
|
|
(glTranslatef -3.1 4.2 0.0)
|
|
(glRotatef (- (* -2.0 *angle*) 25.0) 0.0 0.0 1.0)
|
|
(glCallList *gear3*)
|
|
(glPopMatrix))
|
|
(glPopMatrix))
|
|
|
|
(glutSwapBuffers)
|
|
|
|
(set! *frames* (+ 1 *frames*))
|
|
|
|
(let ((t (glutGet GLUT_ELAPSED_TIME)))
|
|
(when (>= (- t *t0*) 5000)
|
|
(let ((seconds (/ (- t *t0*) 1000.0)))
|
|
(format #t "~d in ~d seconds = ~d FPS~%" *frames* seconds (/ *frames* seconds))
|
|
(set! *t0* t)
|
|
(set! *frames* 0)))))
|
|
|
|
;; new window size or exposure
|
|
(define (reshape width height)
|
|
(let ((h (/. height width)))
|
|
;;*** OpenGL BEGIN ***
|
|
(glViewport 0 0 width height)
|
|
(glMatrixMode GL_PROJECTION)
|
|
(glLoadIdentity)
|
|
(glFrustum -1.0 1.0 (- h) h 5.0 60.0)
|
|
(glMatrixMode GL_MODELVIEW)
|
|
(glLoadIdentity)
|
|
(glTranslatef 0.0 0.0 -40.0)
|
|
;;*** OpenGL END ***
|
|
))
|
|
|
|
(define (init)
|
|
;;*** OpenGL BEGIN ***
|
|
(glLightfv GL_LIGHT0 GL_POSITION (f32vector 5.0 5.0 10.0 0.0))
|
|
(glEnable GL_CULL_FACE)
|
|
(glEnable GL_LIGHTING)
|
|
(glEnable GL_LIGHT0)
|
|
(glEnable GL_DEPTH_TEST)
|
|
|
|
;; make the gears
|
|
(set! *gear1* (glGenLists 1))
|
|
(glNewList *gear1* GL_COMPILE)
|
|
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (f32vector 0.8 0.1 0.0 1.0))
|
|
(gear 1.0 4.0 1.0 20 0.7)
|
|
(glEndList)
|
|
|
|
(set! *gear2* (glGenLists 1))
|
|
(glNewList *gear2* GL_COMPILE)
|
|
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (f32vector 0.0 0.8 0.2 1.0))
|
|
(gear 0.5 2.0 2.0 10 0.7)
|
|
(glEndList)
|
|
|
|
(set! *gear3* (glGenLists 1))
|
|
(glNewList *gear3* GL_COMPILE)
|
|
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (f32vector 0.2 0.2 1.0 1.0))
|
|
(gear 1.3 2.0 0.5 10 0.7)
|
|
(glEndList)
|
|
|
|
(glEnable GL_NORMALIZE)
|
|
|
|
(format #t "GL_RENDERER = ~s~%" (glGetString GL_RENDERER))
|
|
(format #t "GL_VERSION = ~s~%" (glGetString GL_VERSION))
|
|
(format #t "GL_VENDOR = ~s~%" (glGetString GL_VENDOR))
|
|
(format #t "GL_EXTENSIONS = ~s~%" (glGetString GL_EXTENSIONS))
|
|
(newline)
|
|
;;*** OpenGL END ***
|
|
)
|
|
|
|
(define idle
|
|
(let ((t0 #f))
|
|
(lambda ()
|
|
(let ((dt #f)
|
|
(t (/ (glutGet GLUT_ELAPSED_TIME) 1000.0)))
|
|
(unless (number? t0)
|
|
(set! t0 t))
|
|
(set! dt (- t t0))
|
|
(set! t0 t)
|
|
(set! *angle* (+ *angle* (* 70.0 dt))) ; 70 degrees per second
|
|
(set! *angle* (mod *angle* 360.0)) ; prevents eventual overflow
|
|
(glutPostRedisplay)))))
|
|
|
|
;; change view angle, exit upon ESC
|
|
(define (key rk x y)
|
|
(let ((q (lambda () (glutPostRedisplay)))
|
|
(k (c-int->c-uchar rk)))
|
|
(cond
|
|
((= k (char->integer #\z))
|
|
(set! *view-rotz* (mod (+ *view-rotz* 5.0) 360.0)) (q))
|
|
((= k (char->integer #\Z))
|
|
(set! *view-rotz* (mod (- *view-rotz* 5.0) 360.0)) (q))
|
|
((= k (char->integer #\esc)) (exit)))))
|
|
|
|
;; change view angle
|
|
(define (special k x y)
|
|
(let ((q (lambda () (glutPostRedisplay))))
|
|
(cond
|
|
((= k GLUT_KEY_UP)
|
|
(set! *view-rotx* (mod (+ *view-rotx* 5.0) 360.0)) (q))
|
|
((= k GLUT_KEY_DOWN)
|
|
(set! *view-rotx* (mod (- *view-rotx* 5.0) 360.0)) (q))
|
|
((= k GLUT_KEY_LEFT)
|
|
(set! *view-roty* (mod (+ *view-roty* 5.0) 360.0)) (q))
|
|
((= k GLUT_KEY_RIGHT)
|
|
(set! *view-roty* (mod (- *view-roty* 5.0) 360.0)) (q)))))
|
|
|
|
(define (visible vis)
|
|
(if (= vis GLUT_VISIBLE)
|
|
(glutIdleFunc idle)
|
|
(glutIdleFunc (lambda () (usleep 100000)))))
|
|
|
|
(begin
|
|
(glutInit (vector (length (command-line))) (apply vector (command-line)))
|
|
(glutInitDisplayMode (bitwise-ior GLUT_DOUBLE GLUT_DEPTH GLUT_RGB))
|
|
|
|
(glutInitWindowPosition 0 0)
|
|
(glutInitWindowSize 300 300)
|
|
|
|
(set! *win* (glutCreateWindow "Gears"))
|
|
(init)
|
|
|
|
(glutDisplayFunc draw)
|
|
(glutReshapeFunc reshape)
|
|
(glutKeyboardFunc key)
|
|
(glutSpecialFunc special)
|
|
(glutVisibilityFunc visible)
|
|
|
|
(glutMainLoop)
|
|
)
|
|
|
|
;; end
|