#lang racket/gui
(require (planet stephanh/rgl:1:0/rgl)
ffi/vector)
(define controls? #t)
(define gears-canvas%
(class* canvas% ()
(inherit refresh with-gl-context swap-gl-buffers get-parent)
(define rotation 0.0)
(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 step? #f)
(define/public (run)
(set! step? #t)
(refresh))
(define/public (move-left)
(set! view-roty (+ view-roty 5.0))
(refresh))
(define/public (move-right)
(set! view-roty (- view-roty 5.0))
(refresh))
(define/public (move-up)
(set! view-rotx (+ view-rotx 5.0))
(refresh))
(define/public (move-down)
(set! view-rotx (- view-rotx 5.0))
(refresh))
(define (build-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))
(da2 (* da 2))
(da3 (* da 3))
(half-width (* width 0.5))
(neg-half-width (- half-width)))
(glShadeModel GL_FLAT)
(glNormal3d 0.0 0.0 1.0)
(glBegin GL_QUAD_STRIP)
(do ((i 0 (+ 1 i))) ((> i teeth))
(let* ((angle (/ (* i 2.0 pi) teeth))
(cos-angle (cos angle))
(sin-angle (sin angle)))
(glVertex3d (* r0 cos-angle) (* r0 sin-angle) half-width)
(glVertex3d (* r1 cos-angle) (* r1 sin-angle) half-width)
(when (< i teeth)
(glVertex3d (* r0 cos-angle)
(* r0 sin-angle)
(* half-width))
(glVertex3d (* r1 (cos (+ angle da3)))
(* r1 (sin (+ angle da3)))
half-width))))
(glEnd)
(glBegin GL_QUADS)
(do ((i 0 (+ 1 i))) ((= i teeth))
(let ((angle (/ (* i 2.0 pi) teeth)))
(glVertex3d (* r1 (cos angle))
(* r1 (sin angle))
half-width)
(glVertex3d (* r2 (cos (+ angle da)))
(* r2 (sin (+ angle da)))
half-width)
(glVertex3d (* r2 (cos (+ angle da2)))
(* r2 (sin (+ angle da2)))
half-width)
(glVertex3d (* r1 (cos (+ angle da3)))
(* r1 (sin (+ angle da3)))
half-width)))
(glEnd)
(glNormal3d 0.0 0.0 -1.0)
(glBegin GL_QUAD_STRIP)
(do ((i 0 (+ 1 i))) ((> i teeth))
(let* ((angle (/ (* i 2.0 pi) teeth))
(cos-angle (cos angle))
(sin-angle (sin angle)))
(glVertex3d (* r1 cos-angle) (* r1 sin-angle) neg-half-width)
(glVertex3d (* r0 cos-angle) (* r0 sin-angle) neg-half-width)
(when (< i teeth)
(glVertex3d (* r1 (cos (+ angle da3)))
(* r1 (sin (+ angle da3)))
neg-half-width)
(glVertex3d (* r0 cos-angle)
(* r0 sin-angle)
neg-half-width))))
(glEnd)
(glBegin GL_QUADS)
(do ((i 0 (+ 1 i))) ((= i teeth))
(let ((angle (/ (* i 2.0 pi) teeth)))
(glVertex3d (* r1 (cos (+ angle da3)))
(* r1 (sin (+ angle da3)))
neg-half-width)
(glVertex3d (* r2 (cos (+ angle da2)))
(* r2 (sin (+ angle da2)))
neg-half-width)
(glVertex3d (* r2 (cos (+ angle da)))
(* r2 (sin (+ angle da)))
neg-half-width)
(glVertex3d (* r1 (cos angle))
(* r1 (sin angle))
neg-half-width)))
(glEnd)
(glBegin GL_QUAD_STRIP)
(do ((i 0 (+ 1 i))) ((= i teeth))
(let* ((angle (/ (* i 2.0 pi) teeth))
(cos-angle (cos angle))
(sin-angle (sin angle)))
(glVertex3d (* r1 cos-angle) (* r1 sin-angle) half-width)
(glVertex3d (* r1 cos-angle) (* r1 sin-angle) neg-half-width)
(let* ((u (- (* r2 (cos (+ angle da))) (* r1 cos-angle)))
(v (- (* r2 (sin (+ angle da))) (* r1 sin-angle)))
(len (sqrt (+ (* u u) (* v v)))))
(glNormal3d (/ v len) (- (/ u len)) 0.0))
(glVertex3d (* r2 (cos (+ angle da)))
(* r2 (sin (+ angle da)))
half-width)
(glVertex3d (* r2 (cos (+ angle da)))
(* r2 (sin (+ angle da)))
neg-half-width)
(glNormal3d cos-angle sin-angle 0.0)
(glVertex3d (* r2 (cos (+ angle da2)))
(* r2 (sin (+ angle da2)))
half-width)
(glVertex3d (* r2 (cos (+ angle da2)))
(* r2 (sin (+ angle da2)))
neg-half-width)
(let ((u (- (* r1 (cos (+ angle da3)))
(* r2 (cos (+ angle da2)))))
(v (- (* r1 (sin (+ angle da3)))
(* r2 (sin (+ angle da2))))))
(glNormal3d v (- u) 0.0))
(glVertex3d (* r1 (cos (+ angle da3)))
(* r1 (sin (+ angle da3)))
half-width)
(glVertex3d (* r1 (cos (+ angle da3)))
(* r1 (sin (+ angle da3)))
neg-half-width)
(glNormal3d cos-angle sin-angle 0.0)))
(glVertex3d (* r1 (cos 0)) (* r1 (sin 0)) half-width)
(glVertex3d (* r1 (cos 0)) (* r1 (sin 0)) neg-half-width)
(glEnd)
(glShadeModel GL_SMOOTH)
(glBegin GL_QUAD_STRIP)
(do ((i 0 (+ 1 i))) ((> i teeth))
(let* ((angle (/ (* i 2.0 pi) teeth))
(cos-angle (cos angle))
(sin-angle (sin angle)))
(glNormal3d (- cos-angle) (- sin-angle) 0.0)
(glVertex3d (* r0 cos-angle) (* r0 sin-angle) neg-half-width)
(glVertex3d (* r0 cos-angle) (* r0 sin-angle) half-width)))
(glEnd)))
(define/override (on-size width height)
(with-gl-context
(lambda ()
(unless gear1
(printf " RENDERER: ~A\n" (glGetString GL_RENDERER))
(printf " VERSION: ~A\n" (glGetString GL_VERSION))
(printf " VENDOR: ~A\n" (glGetString GL_VENDOR))
(printf " EXTENSIONS: ~A\n" (glGetString GL_EXTENSIONS)))
(glViewport 0 0 width height)
(glMatrixMode GL_PROJECTION)
(glLoadIdentity)
(let ((h (/ height width)))
(glFrustum -1.0 1.0 (- h) h 5.0 60.0))
(glMatrixMode GL_MODELVIEW)
(glLoadIdentity)
(glTranslated 0.0 0.0 -40.0)
(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)
(unless gear1
(set! gear1 (glGenLists 1))
(glNewList gear1 GL_COMPILE)
(glMaterialfv GL_FRONT
GL_AMBIENT_AND_DIFFUSE
(f32vector 0.8 0.1 0.0 1.0))
(build-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))
(build-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))
(build-gear 1.3 2.0 0.5 10 0.7)
(glEndList)
(glEnable GL_NORMALIZE))))
(refresh))
(define sec (current-seconds))
(define frames 0)
(define/override (on-paint)
(when gear1
(when (>= (- (current-seconds) sec) 5)
(send (get-parent) set-status-text (format "~a fps" (/ (exact->inexact frames) 5)))
(set! sec (current-seconds))
(set! frames 0))
(set! frames (add1 frames))
(when step?
(set! rotation (+ 2.0 rotation)))
(with-gl-context
(lambda ()
(glClearColor 0.0 0.0 0.0 0.0)
(glClear (bitwise-ior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
(glPushMatrix)
(glRotated view-rotx 1.0 0.0 0.0)
(glRotated view-roty 0.0 1.0 0.0)
(glRotated view-rotz 0.0 0.0 1.0)
(glPushMatrix)
(glTranslated -3.0 -2.0 0.0)
(glRotated rotation 0.0 0.0 1.0)
(glCallList gear1)
(glPopMatrix)
(glPushMatrix)
(glTranslated 3.1 -2.0 0.0)
(glRotated (- (* -2.0 rotation) 9.0) 0.0 0.0 1.0)
(glCallList gear2)
(glPopMatrix)
(glPushMatrix)
(glTranslated -3.1 4.2 0.0)
(glRotated (- (* -2.0 rotation) 25.0) 0.0 0.0 1.0)
(glCallList gear3)
(glPopMatrix)
(glPopMatrix)
(swap-gl-buffers)
(glFlush)))
(when step?
(set! step? #f)
(queue-callback (lambda x (send this run)) #f))))
(super-instantiate () (style '(gl no-autoclear)))))
(define (f)
(let* ((f (make-object frame% "gears.ss" #f))
(c (instantiate gears-canvas% (f) (min-width 300) (min-height 300))))
(send f create-status-line)
(when controls?
(let ((h (instantiate horizontal-panel% (f)
(alignment '(center center)) (stretchable-height #f))))
(instantiate button%
("Start" h (lambda (b e) (send b enable #f) (send c run)))
(stretchable-width #t) (stretchable-height #t))
(let ((h (instantiate horizontal-panel% (h)
(alignment '(center center)))))
(instantiate button% ("Left" h (lambda x (send c move-left)))
(stretchable-width #t))
(let ((v (instantiate vertical-panel% (h)
(alignment '(center center)) (stretchable-width #f))))
(instantiate button% ("Up" v (lambda x (send c move-up)))
(stretchable-width #t))
(instantiate button% ("Down" v (lambda x (send c move-down)))
(stretchable-width #t)))
(instantiate button% ("Right" h (lambda x (send c move-right)))
(stretchable-width #t)))))
(send f show #t)))
(f)