conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

302
lab/ypsilon-ffi/glut-demo.scm
View File

@ -9,171 +9,171 @@
;; Linux: libGL.so.1 libglut.so.3 ;; Linux: libGL.so.1 libglut.so.3
(import (gl) (glut) (import
(ypsilon-compat) (gl) (glut)
(rename (except (rnrs) angle display) (ypsilon-compat)
(reverse rnrs:reverse)) (rename (except (rnrs) angle display) (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)
(lambda () (define reverse #t)
(glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (define angle 0.0)
(do ((y 2.0 (+ y 3.0))) (define last-update 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 rotate (define display
(lambda () (lambda ()
(cond ((< (+ last-update 16000) (microsecond)) (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
(if (= (glutGetWindow) 0) (exit 0)) (do ((y 2.0 (+ y 3.0)))
(if reverse ((> y 14.0))
(let ((new-angle (+ angle 2.0))) (do ((x 2.0 (+ x 3.0)))
(if (>= new-angle 360.0) ((> x 14.0))
(set! angle (- new-angle 360.0)) (if reverse
(set! angle new-angle))) (render-one x y
(let ((new-angle (- angle 2.0))) 0.4 (/ x 40.0) (/ y 40.0)
(if (< new-angle 360.0) (/ x 20.0) (/ y 20.0) 0.4
(set! angle (+ new-angle 360.0)) (/ x 20.0) 0.2 (/ y 20.0)
(set! angle new-angle)))) (/ (+ x y) 20.0 100.0))
(set! last-update (microsecond)) (render-one x y
(glutPostRedisplay))))) (/ 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 (define rotate
(lambda (button state x y) (lambda ()
(and (= state 0) (set! reverse (not reverse))) (cond ((< (+ last-update 16000) (microsecond))
(format #t "mouse callback ~s ~s ~s ~s ~%" button state x y))) (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 mouse
(define show-sphere (lambda () (glutSolidSphere 1.0 32 16))) (lambda (button state x y)
(define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1))) (and (= state 0) (set! reverse (not reverse)))
(define show-cube (lambda () (glutSolidCube 1.5))) (format #t "mouse callback ~s ~s ~s ~s ~%" button state x y)))
(define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32)))
(define menu (define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron)))
(lambda (m) (define show-sphere (lambda () (glutSolidSphere 1.0 32 16)))
(format #t "menu callback ~s ~%" m) (define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1)))
(case m (define show-cube (lambda () (glutSolidCube 1.5)))
((1) (set! object glutSolidIcosahedron)) (define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32)))
((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 reshape (define menu
(lambda (w h) (lambda (m)
(format #t "reshape callback ~s ~s ~%" w h) (format #t "menu callback ~s ~%" m)
(and (> w 0) (case m
(> h 0) ((1) (set! object glutSolidIcosahedron))
(begin ((2) (set! object glutSolidOctahedron))
(glViewport 0 0 w h) ((3) (set! object glutSolidTetrahedron))
(glMatrixMode GL_PROJECTION) ((4) (set! object show-dodecahedron))
(glLoadIdentity) ((5) (set! object show-sphere))
(if (<= w h) ((6) (set! object show-cone))
(glOrtho 0.0 16.0 0.0 (/ (* 16.0 h) w) -10.0 10.0) ((7) (set! object show-cube))
(glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0)) ((8) (set! object show-torus))
(glMatrixMode GL_MODELVIEW))))) ((9) (glShadeModel GL_SMOOTH))
((10) (glShadeModel GL_FLAT))
((11) (exit)))))
(define visibility (define reshape
(lambda (state) (lambda (w h)
(format #t "visibility callback ~s ~%" state))) (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 (define visibility
(lambda lst (lambda (state)
(define-syntax f32set! (format #t "visibility callback ~s ~%" state)))
(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 (define f32vector
(lambda (x y ambr ambg ambb difr difg difb specr specg specb shine) (lambda lst
(glPushMatrix) (define-syntax f32set!
(glTranslatef x y 0.0) (syntax-rules ()
(cond ((eq? object show-sphere) ((_ bv n value)
(glRotatef 90.0 0.0 1.0 0.0) (bytevector-ieee-single-native-set! bv (* n 4) value))))
(glRotatef angle 0.0 0.0 1.0)) (let ((bv (make-bytevector (* (length lst) 4))))
(else (let loop ((i 0) (lst lst))
(glRotatef angle -0.3 1.0 -0.5))) (cond ((null? lst) bv)
(glMaterialfv GL_FRONT GL_AMBIENT (f32vector ambr ambg ambb 1.0)) (else
(glMaterialfv GL_FRONT GL_DIFFUSE (f32vector difr difg difb 1.0)) (f32set! bv i (car lst))
(glMaterialfv GL_FRONT GL_SPECULAR (f32vector specr specg specb 1.0)) (loop (+ i 1) (cdr lst))))))))
(glMaterialf GL_FRONT GL_SHININESS (* shine 128.0))
(object) (define render-one
(glPopMatrix))) (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)) #;(import (trace))
#;(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)
(glutInitWindowSize 500 500) (glutInitWindowSize 500 500)
(glutInit (vector (length (command-line))) (apply vector (command-line))) (glutInit (vector (length (command-line))) (apply vector (command-line)))
(glutCreateWindow "Hello GLUT") (glutCreateWindow "Hello GLUT")
(glLightfv GL_LIGHT0 GL_AMBIENT (f32vector 0.0 0.0 0.0 1.0)) (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_DIFFUSE (f32vector 1.0 1.0 1.0 1.0))
(glLightfv GL_LIGHT0 GL_POSITION (f32vector 0.0 3.0 3.0 0.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_AMBIENT (f32vector 0.2 0.2 0.2 1.0))
(glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0)) (glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0))
(glShadeModel GL_FLAT) (glShadeModel GL_FLAT)
(glFrontFace GL_CW) (glFrontFace GL_CW)
(glEnable GL_LIGHTING) (glEnable GL_LIGHTING)
(glEnable GL_LIGHT0) (glEnable GL_LIGHT0)
(glEnable GL_AUTO_NORMAL) (glEnable GL_AUTO_NORMAL)
(glEnable GL_NORMALIZE) (glEnable GL_NORMALIZE)
(glEnable GL_DEPTH_TEST) (glEnable GL_DEPTH_TEST)
(glDepthFunc GL_LESS) (glDepthFunc GL_LESS)
(glutDisplayFunc display) (glutDisplayFunc display)
(glutReshapeFunc reshape) (glutReshapeFunc reshape)
(glutVisibilityFunc visibility) (glutVisibilityFunc visibility)
(glutMouseFunc mouse) (glutMouseFunc mouse)
(glutIdleFunc rotate) (glutIdleFunc rotate)
(glutCreateMenu menu) (glutCreateMenu menu)
(glutAddMenuEntry "Icosahedron" 1) (glutAddMenuEntry "Icosahedron" 1)
(glutAddMenuEntry "Octahedron" 2) (glutAddMenuEntry "Octahedron" 2)
(glutAddMenuEntry "Tetrahedron" 3) (glutAddMenuEntry "Tetrahedron" 3)
(glutAddMenuEntry "Dodecahedron" 4) (glutAddMenuEntry "Dodecahedron" 4)
(glutAddMenuEntry "Sphere" 5) (glutAddMenuEntry "Sphere" 5)
(glutAddMenuEntry "Cone" 6) (glutAddMenuEntry "Cone" 6)
(glutAddMenuEntry "Cube" 7) (glutAddMenuEntry "Cube" 7)
(glutAddMenuEntry "Torus" 8) (glutAddMenuEntry "Torus" 8)
(glutAddMenuEntry "[smooth]" 9) (glutAddMenuEntry "[smooth]" 9)
(glutAddMenuEntry "[flat]" 10) (glutAddMenuEntry "[flat]" 10)
(glutAddMenuEntry "Exit" 11) (glutAddMenuEntry "Exit" 11)
(glutAttachMenu GLUT_RIGHT_BUTTON) (glutAttachMenu GLUT_RIGHT_BUTTON)
(glutMainLoop))) (glutMainLoop)))
(run)) (run)

6
lab/ypsilon-ffi/ypsilon-compat.ypsilon.ss Normal file
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)))