the opengl demos now work unmodified under both ikarus and ypsilon.

This commit is contained in:
Abdulaziz Ghuloum 2008-09-24 06:00:42 -04:00
parent c8d0baa341
commit 6a9de3e974
2 changed files with 157 additions and 151 deletions

View File

@ -9,20 +9,20 @@
;; Linux: libGL.so.1 libglut.so.3 ;; Linux: libGL.so.1 libglut.so.3
(import (gl) (glut) (import
(gl) (glut)
(ypsilon-compat) (ypsilon-compat)
(rename (except (rnrs) angle display) (rename (except (rnrs) angle display) (reverse rnrs:reverse))
(reverse rnrs:reverse))
(rnrs programs)) (rnrs programs))
(begin
(define object glutSolidIcosahedron)
(define reverse #t)
(define angle 0.0)
(define last-update 0)
(define display (define object glutSolidIcosahedron)
(define reverse #t)
(define angle 0.0)
(define last-update 0)
(define display
(lambda () (lambda ()
(glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
(do ((y 2.0 (+ y 3.0))) (do ((y 2.0 (+ y 3.0)))
@ -42,7 +42,7 @@
(/ (+ x y) 20.0 100.0))))) (/ (+ x y) 20.0 100.0)))))
(glutSwapBuffers))) (glutSwapBuffers)))
(define rotate (define rotate
(lambda () (lambda ()
(cond ((< (+ last-update 16000) (microsecond)) (cond ((< (+ last-update 16000) (microsecond))
(if (= (glutGetWindow) 0) (exit 0)) (if (= (glutGetWindow) 0) (exit 0))
@ -58,18 +58,18 @@
(set! last-update (microsecond)) (set! last-update (microsecond))
(glutPostRedisplay))))) (glutPostRedisplay)))))
(define mouse (define mouse
(lambda (button state x y) (lambda (button state x y)
(and (= state 0) (set! reverse (not reverse))) (and (= state 0) (set! reverse (not reverse)))
(format #t "mouse callback ~s ~s ~s ~s ~%" button state x y))) (format #t "mouse callback ~s ~s ~s ~s ~%" button state x y)))
(define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron))) (define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron)))
(define show-sphere (lambda () (glutSolidSphere 1.0 32 16))) (define show-sphere (lambda () (glutSolidSphere 1.0 32 16)))
(define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1))) (define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1)))
(define show-cube (lambda () (glutSolidCube 1.5))) (define show-cube (lambda () (glutSolidCube 1.5)))
(define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32))) (define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32)))
(define menu (define menu
(lambda (m) (lambda (m)
(format #t "menu callback ~s ~%" m) (format #t "menu callback ~s ~%" m)
(case m (case m
@ -85,7 +85,7 @@
((10) (glShadeModel GL_FLAT)) ((10) (glShadeModel GL_FLAT))
((11) (exit))))) ((11) (exit)))))
(define reshape (define reshape
(lambda (w h) (lambda (w h)
(format #t "reshape callback ~s ~s ~%" w h) (format #t "reshape callback ~s ~s ~%" w h)
(and (> w 0) (and (> w 0)
@ -99,11 +99,11 @@
(glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0)) (glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0))
(glMatrixMode GL_MODELVIEW))))) (glMatrixMode GL_MODELVIEW)))))
(define visibility (define visibility
(lambda (state) (lambda (state)
(format #t "visibility callback ~s ~%" state))) (format #t "visibility callback ~s ~%" state)))
(define f32vector (define f32vector
(lambda lst (lambda lst
(define-syntax f32set! (define-syntax f32set!
(syntax-rules () (syntax-rules ()
@ -116,7 +116,7 @@
(f32set! bv i (car lst)) (f32set! bv i (car lst))
(loop (+ i 1) (cdr lst)))))))) (loop (+ i 1) (cdr lst))))))))
(define render-one (define render-one
(lambda (x y ambr ambg ambb difr difg difb specr specg specb shine) (lambda (x y ambr ambg ambb difr difg difb specr specg specb shine)
(glPushMatrix) (glPushMatrix)
(glTranslatef x y 0.0) (glTranslatef x y 0.0)
@ -136,7 +136,7 @@
#;(trace render-one) #;(trace render-one)
#;(collect-notify #t) #;(collect-notify #t)
(define run (define run
(lambda () (lambda ()
(glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH)) (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH))
(glutInitWindowPosition 100 100) (glutInitWindowPosition 100 100)
@ -176,4 +176,4 @@
(glutAttachMenu GLUT_RIGHT_BUTTON) (glutAttachMenu GLUT_RIGHT_BUTTON)
(glutMainLoop))) (glutMainLoop)))
(run)) (run)

View File

@ -0,0 +1,6 @@
(library (ypsilon-compat)
(export on-windows on-darwin on-linux on-freebsd on-posix
load-shared-object c-argument c-function
microsecond usleep format)
(import (core) (ffi)))