From 6a9de3e974d9eec657694973f1ca896a8b023b6e Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Wed, 24 Sep 2008 06:00:42 -0400 Subject: [PATCH] the opengl demos now work unmodified under both ikarus and ypsilon. --- lab/ypsilon-ffi/glut-demo.scm | 302 +++++++++++----------- lab/ypsilon-ffi/ypsilon-compat.ypsilon.ss | 6 + 2 files changed, 157 insertions(+), 151 deletions(-) create mode 100644 lab/ypsilon-ffi/ypsilon-compat.ypsilon.ss diff --git a/lab/ypsilon-ffi/glut-demo.scm b/lab/ypsilon-ffi/glut-demo.scm index 3770b1c..d768e10 100644 --- a/lab/ypsilon-ffi/glut-demo.scm +++ b/lab/ypsilon-ffi/glut-demo.scm @@ -9,171 +9,171 @@ ;; Linux: libGL.so.1 libglut.so.3 -(import (gl) (glut) - (ypsilon-compat) - (rename (except (rnrs) angle display) - (reverse rnrs:reverse)) - (rnrs programs)) -(begin +(import + (gl) (glut) + (ypsilon-compat) + (rename (except (rnrs) angle display) (reverse rnrs:reverse)) + (rnrs programs)) - (define object glutSolidIcosahedron) - (define reverse #t) - (define angle 0.0) - (define last-update 0) - (define display - (lambda () - (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) - (do ((y 2.0 (+ y 3.0))) - ((> y 14.0)) - (do ((x 2.0 (+ x 3.0))) - ((> x 14.0)) - (if reverse - (render-one x y - 0.4 (/ x 40.0) (/ y 40.0) - (/ x 20.0) (/ y 20.0) 0.4 - (/ x 20.0) 0.2 (/ y 20.0) - (/ (+ x y) 20.0 100.0)) - (render-one x y - (/ y 40.0) (/ x 40.0) 0.4 - (/ x 20.0) 0.4 (/ y 20.0) - 0.2 (/ x 20.0) (/ y 20.0) - (/ (+ x y) 20.0 100.0))))) - (glutSwapBuffers))) +(define object glutSolidIcosahedron) +(define reverse #t) +(define angle 0.0) +(define last-update 0) - (define rotate - (lambda () - (cond ((< (+ last-update 16000) (microsecond)) - (if (= (glutGetWindow) 0) (exit 0)) - (if reverse - (let ((new-angle (+ angle 2.0))) - (if (>= new-angle 360.0) - (set! angle (- new-angle 360.0)) - (set! angle new-angle))) - (let ((new-angle (- angle 2.0))) - (if (< new-angle 360.0) - (set! angle (+ new-angle 360.0)) - (set! angle new-angle)))) - (set! last-update (microsecond)) - (glutPostRedisplay))))) +(define display + (lambda () + (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) + (do ((y 2.0 (+ y 3.0))) + ((> y 14.0)) + (do ((x 2.0 (+ x 3.0))) + ((> x 14.0)) + (if reverse + (render-one x y + 0.4 (/ x 40.0) (/ y 40.0) + (/ x 20.0) (/ y 20.0) 0.4 + (/ x 20.0) 0.2 (/ y 20.0) + (/ (+ x y) 20.0 100.0)) + (render-one x y + (/ y 40.0) (/ x 40.0) 0.4 + (/ x 20.0) 0.4 (/ y 20.0) + 0.2 (/ x 20.0) (/ y 20.0) + (/ (+ x y) 20.0 100.0))))) + (glutSwapBuffers))) - (define mouse - (lambda (button state x y) - (and (= state 0) (set! reverse (not reverse))) - (format #t "mouse callback ~s ~s ~s ~s ~%" button state x y))) +(define rotate + (lambda () + (cond ((< (+ last-update 16000) (microsecond)) + (if (= (glutGetWindow) 0) (exit 0)) + (if reverse + (let ((new-angle (+ angle 2.0))) + (if (>= new-angle 360.0) + (set! angle (- new-angle 360.0)) + (set! angle new-angle))) + (let ((new-angle (- angle 2.0))) + (if (< new-angle 360.0) + (set! angle (+ new-angle 360.0)) + (set! angle new-angle)))) + (set! last-update (microsecond)) + (glutPostRedisplay))))) - (define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron))) - (define show-sphere (lambda () (glutSolidSphere 1.0 32 16))) - (define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1))) - (define show-cube (lambda () (glutSolidCube 1.5))) - (define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32))) +(define mouse + (lambda (button state x y) + (and (= state 0) (set! reverse (not reverse))) + (format #t "mouse callback ~s ~s ~s ~s ~%" button state x y))) - (define menu - (lambda (m) - (format #t "menu callback ~s ~%" m) - (case m - ((1) (set! object glutSolidIcosahedron)) - ((2) (set! object glutSolidOctahedron)) - ((3) (set! object glutSolidTetrahedron)) - ((4) (set! object show-dodecahedron)) - ((5) (set! object show-sphere)) - ((6) (set! object show-cone)) - ((7) (set! object show-cube)) - ((8) (set! object show-torus)) - ((9) (glShadeModel GL_SMOOTH)) - ((10) (glShadeModel GL_FLAT)) - ((11) (exit))))) +(define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron))) +(define show-sphere (lambda () (glutSolidSphere 1.0 32 16))) +(define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1))) +(define show-cube (lambda () (glutSolidCube 1.5))) +(define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32))) - (define reshape - (lambda (w h) - (format #t "reshape callback ~s ~s ~%" w h) - (and (> w 0) - (> h 0) - (begin - (glViewport 0 0 w h) - (glMatrixMode GL_PROJECTION) - (glLoadIdentity) - (if (<= w h) - (glOrtho 0.0 16.0 0.0 (/ (* 16.0 h) w) -10.0 10.0) - (glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0)) - (glMatrixMode GL_MODELVIEW))))) +(define menu + (lambda (m) + (format #t "menu callback ~s ~%" m) + (case m + ((1) (set! object glutSolidIcosahedron)) + ((2) (set! object glutSolidOctahedron)) + ((3) (set! object glutSolidTetrahedron)) + ((4) (set! object show-dodecahedron)) + ((5) (set! object show-sphere)) + ((6) (set! object show-cone)) + ((7) (set! object show-cube)) + ((8) (set! object show-torus)) + ((9) (glShadeModel GL_SMOOTH)) + ((10) (glShadeModel GL_FLAT)) + ((11) (exit))))) - (define visibility - (lambda (state) - (format #t "visibility callback ~s ~%" state))) +(define reshape + (lambda (w h) + (format #t "reshape callback ~s ~s ~%" w h) + (and (> w 0) + (> h 0) + (begin + (glViewport 0 0 w h) + (glMatrixMode GL_PROJECTION) + (glLoadIdentity) + (if (<= w h) + (glOrtho 0.0 16.0 0.0 (/ (* 16.0 h) w) -10.0 10.0) + (glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0)) + (glMatrixMode GL_MODELVIEW))))) - (define f32vector - (lambda 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 visibility + (lambda (state) + (format #t "visibility callback ~s ~%" state))) - (define render-one - (lambda (x y ambr ambg ambb difr difg difb specr specg specb shine) - (glPushMatrix) - (glTranslatef x y 0.0) - (cond ((eq? object show-sphere) - (glRotatef 90.0 0.0 1.0 0.0) - (glRotatef angle 0.0 0.0 1.0)) - (else - (glRotatef angle -0.3 1.0 -0.5))) - (glMaterialfv GL_FRONT GL_AMBIENT (f32vector ambr ambg ambb 1.0)) - (glMaterialfv GL_FRONT GL_DIFFUSE (f32vector difr difg difb 1.0)) - (glMaterialfv GL_FRONT GL_SPECULAR (f32vector specr specg specb 1.0)) - (glMaterialf GL_FRONT GL_SHININESS (* shine 128.0)) - (object) - (glPopMatrix))) +(define f32vector + (lambda 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 render-one + (lambda (x y ambr ambg ambb difr difg difb specr specg specb shine) + (glPushMatrix) + (glTranslatef x y 0.0) + (cond ((eq? object show-sphere) + (glRotatef 90.0 0.0 1.0 0.0) + (glRotatef angle 0.0 0.0 1.0)) + (else + (glRotatef angle -0.3 1.0 -0.5))) + (glMaterialfv GL_FRONT GL_AMBIENT (f32vector ambr ambg ambb 1.0)) + (glMaterialfv GL_FRONT GL_DIFFUSE (f32vector difr difg difb 1.0)) + (glMaterialfv GL_FRONT GL_SPECULAR (f32vector specr specg specb 1.0)) + (glMaterialf GL_FRONT GL_SHININESS (* shine 128.0)) + (object) + (glPopMatrix))) #;(import (trace)) #;(trace render-one) #;(collect-notify #t) - (define run - (lambda () - (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH)) - (glutInitWindowPosition 100 100) - (glutInitWindowSize 500 500) - (glutInit (vector (length (command-line))) (apply vector (command-line))) - (glutCreateWindow "Hello GLUT") - (glLightfv GL_LIGHT0 GL_AMBIENT (f32vector 0.0 0.0 0.0 1.0)) - (glLightfv GL_LIGHT0 GL_DIFFUSE (f32vector 1.0 1.0 1.0 1.0)) - (glLightfv GL_LIGHT0 GL_POSITION (f32vector 0.0 3.0 3.0 0.0)) - (glLightModelfv GL_LIGHT_MODEL_AMBIENT (f32vector 0.2 0.2 0.2 1.0)) - (glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0)) - (glShadeModel GL_FLAT) - (glFrontFace GL_CW) - (glEnable GL_LIGHTING) - (glEnable GL_LIGHT0) - (glEnable GL_AUTO_NORMAL) - (glEnable GL_NORMALIZE) - (glEnable GL_DEPTH_TEST) - (glDepthFunc GL_LESS) - (glutDisplayFunc display) - (glutReshapeFunc reshape) - (glutVisibilityFunc visibility) - (glutMouseFunc mouse) - (glutIdleFunc rotate) - (glutCreateMenu menu) - (glutAddMenuEntry "Icosahedron" 1) - (glutAddMenuEntry "Octahedron" 2) - (glutAddMenuEntry "Tetrahedron" 3) - (glutAddMenuEntry "Dodecahedron" 4) - (glutAddMenuEntry "Sphere" 5) - (glutAddMenuEntry "Cone" 6) - (glutAddMenuEntry "Cube" 7) - (glutAddMenuEntry "Torus" 8) - (glutAddMenuEntry "[smooth]" 9) - (glutAddMenuEntry "[flat]" 10) - (glutAddMenuEntry "Exit" 11) - (glutAttachMenu GLUT_RIGHT_BUTTON) - (glutMainLoop))) +(define run + (lambda () + (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH)) + (glutInitWindowPosition 100 100) + (glutInitWindowSize 500 500) + (glutInit (vector (length (command-line))) (apply vector (command-line))) + (glutCreateWindow "Hello GLUT") + (glLightfv GL_LIGHT0 GL_AMBIENT (f32vector 0.0 0.0 0.0 1.0)) + (glLightfv GL_LIGHT0 GL_DIFFUSE (f32vector 1.0 1.0 1.0 1.0)) + (glLightfv GL_LIGHT0 GL_POSITION (f32vector 0.0 3.0 3.0 0.0)) + (glLightModelfv GL_LIGHT_MODEL_AMBIENT (f32vector 0.2 0.2 0.2 1.0)) + (glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0)) + (glShadeModel GL_FLAT) + (glFrontFace GL_CW) + (glEnable GL_LIGHTING) + (glEnable GL_LIGHT0) + (glEnable GL_AUTO_NORMAL) + (glEnable GL_NORMALIZE) + (glEnable GL_DEPTH_TEST) + (glDepthFunc GL_LESS) + (glutDisplayFunc display) + (glutReshapeFunc reshape) + (glutVisibilityFunc visibility) + (glutMouseFunc mouse) + (glutIdleFunc rotate) + (glutCreateMenu menu) + (glutAddMenuEntry "Icosahedron" 1) + (glutAddMenuEntry "Octahedron" 2) + (glutAddMenuEntry "Tetrahedron" 3) + (glutAddMenuEntry "Dodecahedron" 4) + (glutAddMenuEntry "Sphere" 5) + (glutAddMenuEntry "Cone" 6) + (glutAddMenuEntry "Cube" 7) + (glutAddMenuEntry "Torus" 8) + (glutAddMenuEntry "[smooth]" 9) + (glutAddMenuEntry "[flat]" 10) + (glutAddMenuEntry "Exit" 11) + (glutAttachMenu GLUT_RIGHT_BUTTON) + (glutMainLoop))) - (run)) +(run) diff --git a/lab/ypsilon-ffi/ypsilon-compat.ypsilon.ss b/lab/ypsilon-ffi/ypsilon-compat.ypsilon.ss new file mode 100644 index 0000000..7ca9a62 --- /dev/null +++ b/lab/ypsilon-ffi/ypsilon-compat.ypsilon.ss @@ -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)))