- opengl demos from ypsilon (gears and glut-demo) now work under

ikarus's ffi using a compatibility layer.
This commit is contained in:
Abdulaziz Ghuloum 2008-09-23 07:48:16 -04:00
parent abe97b4053
commit 61ecbe0dd1
9 changed files with 5117 additions and 4 deletions

View File

@ -0,0 +1,283 @@
(library (core)
(export iota string-contains architecture-feature format
flonum->float string->cstring load-shared-object
lookup-shared-object
stdcall-shared-object->void
stdcall-shared-object->int
stdcall-shared-object->intptr
stdcall-shared-object->double
make-callback
usleep microsecond)
(import (except (ikarus) library format)
(except (ikarus system $foreign) make-callback))
(define (format what str . args)
(import (ikarus))
(cond
[(eq? what #f)
(apply printf str args)]
[else
(apply format str args)]))
(define (iota n i)
(cond
[(= n 0) '()]
[else (cons i (iota (- n 1) (+ i 1)))]))
(define (architecture-feature what)
(case what
[(operating-system) "darwin"]
[(alignof:int) 4]
[(sizeof:int) 4]
[else (error 'architecture-feature "invalid args" what)]))
(define (string-contains text s)
(define (starts-at? i)
(let f ([i i] [j 0])
(cond
[(= j (string-length s)) #t]
[(= i (string-length text)) #f]
[else
(and (char=? (string-ref text i) (string-ref s j))
(f (+ i 1) (+ j 1)))])))
(let f ([i 0])
(cond
[(= i (string-length text)) #f]
[(starts-at? i) #t]
[else (f (+ i 1))])))
(define-record-type library (fields name pointer))
(define (load-shared-object libname)
(make-library libname
(or (dlopen libname)
(error 'load-shared-object (dlerror) libname))))
(define-record-type shared-object
(fields name lib [mutable proc] pointer))
(define (lookup-shared-object lib name)
(define who 'lookup-shared-object)
(unless (symbol? name) (die who "not a symbol" name))
(unless (library? lib) (die who "not a library" lib))
(make-shared-object name lib #f
(or (dlsym (library-pointer lib) (symbol->string name))
(error who
(format #f "cannot find object ~a in library ~a"
name (library-name lib))))))
(define get-ffi
(let ([ffis '()])
(lambda (return-type arg-types)
(let ([x (cons return-type arg-types)])
(cond
[(assoc x ffis) => cdr]
[else
(let ([ffi (make-ffi return-type arg-types)])
(set! ffis (cons (cons x ffi) ffis))
ffi)])))))
(define (arg->arg-type who)
(define (err who x)
(error 'arg->arg-type
(format #f "cannot handle conversion for procedure ~a" who)
x))
(lambda (arg)
(cond
[(bytevector? arg) 'pointer]
[(vector? arg) 'pointer]
[(cstring? arg) 'pointer]
[(pointer? arg) 'pointer]
[(cfloat? arg) 'float]
[(flonum? arg) 'double]
[(or (fixnum? arg) (bignum? arg)) 'sint32]
[else (err who arg)])))
(define (convert-incoming type result)
(define who 'convert-incoming)
(case type
[(void) (void)]
[(sint32) result]
[(pointer) result]
[else (error who "unhandled type" type)]))
(define (convert-outgoing type arg)
(define who 'convert-outgoing)
(case type
[(pointer)
(cond
[(bytevector? arg) (bytevector->blob arg)]
[(vector? arg) (vector->blob arg)]
[(cstring? arg) (cstring-pointer arg)]
[(pointer? arg) arg]
[else (error who "no converter for" type arg)])]
[(sint32)
(cond
[(or (fixnum? arg) (bignum? arg)) arg]
[else (error who "no converter for" type arg)])]
[(float)
(cond
[(cfloat? arg) (cfloat-value arg)]
[else (error who "no converter for" type arg)])]
[(double)
(cond
[(flonum? arg) arg]
[else (error who "no converter for" type arg)])]
[else (error who "unhandled type" type)]))
(define (wrap-conversion who return-type arg-types f)
(lambda args
(unless (= (length args) (length arg-types))
(error who "incorrect number of arguments" args))
(let ([args (map convert-outgoing arg-types args)])
(let ([result (apply f args)])
(convert-incoming return-type result)))))
(define (make-proc who obj return-type args)
(let ([arg-types (map (arg->arg-type who) args)])
(let ([ffi (get-ffi return-type arg-types)])
(wrap-conversion
(shared-object-name obj)
return-type arg-types
(ffi (shared-object-pointer obj))))))
(define (get-proc who obj return-type args)
(unless (shared-object? obj)
(error who "not a shared object" obj))
(or (shared-object-proc obj)
(let ([p (make-proc who obj return-type args)])
(shared-object-proc-set! obj p)
p)))
(define-record-type cstring (fields pointer))
(define (string->cstring str)
(let ([bv (string->utf8 str)])
(let ([n (bytevector-length bv)])
(let ([p (malloc (+ n 1))])
(let f ([i 0])
(unless (= i n)
(pointer-set-char p i (bytevector-u8-ref bv i))
(f (+ i 1))))
(pointer-set-char p n 0)
(make-cstring p)))))
(define (bytevector->blob bv)
(let ([n (bytevector-length bv)])
(let ([p (malloc n)])
(let f ([i 0] [j (- n 1)])
(unless (= i n)
(pointer-set-char p i (bytevector-u8-ref bv j))
(f (+ i 1) (- j 1))))
p)))
#;
(define (bytevector->blob bv)
(let ([n (bytevector-length bv)])
(let ([p (malloc n)])
(let f ([i 0])
(unless (= i n)
(pointer-set-char p i (bytevector-u8-ref bv i))
(f (+ i 1))))
p)))
(define (object->long x)
(cond
[(integer? x) x]
[(cstring? x) (pointer->integer (cstring-pointer x))]
[else (error 'object->pointer "cannot handle" x)]))
(define (vector->blob v)
(let ([n (vector-length v)])
(let ([p (malloc (* n 4))])
(let f ([i 0] [j (- n 1)])
(unless (= i n)
(pointer-set-long p (* i 4)
(object->long (vector-ref v j)))
(f (+ i 1) (- j 1))))
p)))
(define-record-type cfloat (fields value))
(define (flonum->float x)
(cond
[(flonum? x) (make-cfloat x)]
[else (error 'flonum->float "invalid arg" x)]))
(define (stdcall-shared-object->void proc . args)
(apply (get-proc 'stdcall-shared-object->void proc 'void args) args))
(define (stdcall-shared-object->int proc . args)
(apply (get-proc 'stdcall-shared-object->int proc 'sint32 args) args))
(define (stdcall-shared-object->intptr proc . args)
(apply (get-proc 'stdcall-shared-object->intptr proc 'pointer args) args))
(define (make-callback conv argcount proc)
(import (ikarus system $foreign))
(define who 'make-callback)
(unless (procedure? proc) (error who "not a procedure" proc))
(unless (eqv? 0 conv) (error who "invalid calling convention" conv))
((make-callback 'sint32 (make-list argcount 'sint32)) proc))
(define (stdcall-shared-object->double . args) (error '#f "invalid args" args))
(define (usleep . args) (error '#f "invalid args" args))
(define (microsecond)
(let ([t (current-time)])
(+ (* (time-second t) 1000000)
(div (time-nanosecond t) 1000))))
;(define-record-type carray (fields pointer))
;(define make-binary-array-of-int
; (lambda argv
; (let ((step (architecture-feature 'alignof:int))
; (proc (case (architecture-feature 'sizeof:int)
; ((4) pointer-set-int)
; ((8) pointer-set-long)
; (else
; (syntax-violation 'make-binary-array-of-int "byte size of int not defined")))))
; (let ((p (malloc (* step (length argv)))))
; (let loop ((offset 0) (arg argv))
; (cond ((null? arg) (make-carray p))
; (else
; (let ((value (car arg)))
; (proc p offset value)
; (loop (+ offset step) (cdr arg))))))))))
;
;(define make-binary-array-of-char*
; (lambda (ref . argv)
; (assert (= ref 0))
; (let ((step (architecture-feature 'alignof:int))
; (proc (case (architecture-feature 'sizeof:int)
; ((4) pointer-set-int)
; ((8) pointer-set-long)
; (else
; (syntax-violation 'make-binary-array-of-char* "byte size of int not defined")))))
; (let ((p (malloc (* step (length argv)))))
; (let loop ((offset 0) (arg argv))
; (cond ((null? arg) (make-carray p))
; (else
; (let ((value (car arg)))
; (proc p offset
; (pointer->integer
; (cstring-pointer (string->cstring value))))
; (loop (+ offset step) (cdr arg))))))))))
)

196
lab/ypsilon-ffi/ffi.scm Normal file
View File

@ -0,0 +1,196 @@
;;; Ypsilon Scheme System
;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
;;; See license.txt for terms and conditions of use.
(library (ffi)
(export c-function c-argument
on-windows on-darwin on-linux on-freebsd on-posix)
(import (rnrs) (core))
(define on-windows (and (string-contains (architecture-feature 'operating-system) "windows") #t))
(define on-darwin (and (string-contains (architecture-feature 'operating-system) "darwin") #t))
(define on-linux (and (string-contains (architecture-feature 'operating-system) "linux") #t))
(define on-freebsd (and (string-contains (architecture-feature 'operating-system) "freebsd") #t))
(define on-posix (not on-windows))
(define assert-bool
(lambda (name n i)
(cond ((boolean? i) (if i 1 0))
(else
(assertion-violation name (format "expected #t or #f, but got ~r, as argument ~s" i n))))))
(define assert-int
(lambda (name n i)
(cond ((and (integer? i) (exact? i)) i)
(else
(assertion-violation name (format "expected exact integer, but got ~r, as argument ~s" i n))))))
(define assert-float
(lambda (name n f)
(cond ((flonum? f) (flonum->float f))
(else
(assertion-violation name (format "expected flonum, but got ~r, as argument ~s" f n))))))
(define assert-double
(lambda (name n f)
(cond ((flonum? f) f)
(else
(assertion-violation name (format "expected flonum, but got ~r, as argument ~s" f n))))))
(define assert-string
(lambda (name n s)
(cond ((string? s) s)
(else
(assertion-violation name (format "expected string, but got ~r, as argument ~s" s n))))))
(define assert-bytevector
(lambda (name n b)
(cond ((bytevector? b) b)
(else
(assertion-violation name (format "expected bytevector, but got ~r, as argument ~s" b n))))))
(define assert-closure
(lambda (name n p)
(cond ((procedure? p) p)
(else
(assertion-violation name (format "expected procedure, but got ~r, as argument ~s" p n))))))
(define assert-int-vector
(lambda (name n vect)
(or (vector? vect)
(assertion-violation name (format "expected vector, but got ~r, as argument ~s" vect n)))
(let ((lst (vector->list vect)))
(for-each (lambda (i)
(or (and (integer? i) (exact? i))
(assertion-violation name (format "expected list of exact integer, but got ~r, as argument ~s" vect n))))
lst)
lst)))
(define assert-string-vector
(lambda (name n vect)
(or (vector? vect)
(assertion-violation name (format "expected vector, but got ~r, as argument ~s" vect n)))
(let ((lst (vector->list vect)))
(for-each (lambda (s)
(or (string? s)
(assertion-violation name (format "expected vector of string, but got ~r, as argument ~s" vect n))))
lst)
lst)))
(define int->bool
(lambda (val)
(not (= val 0))))
(define char*->string
(lambda (val)
(and val (bytevector->string val (make-transcoder (utf-8-codec))))))
(define make-binary-array-of-int
(lambda argv
(let ((step (architecture-feature 'alignof:int))
(proc (case (architecture-feature 'sizeof:int)
((4) bytevector-s32-native-set!)
((8) bytevector-s64-native-set!)
(else
(syntax-violation 'make-binary-array-of-int "byte size of int not defined")))))
(let ((bv (make-bytevector (* step (length argv)))))
(let loop ((offset 0) (arg argv))
(cond ((null? arg) bv)
(else
(let ((value (car arg)))
(proc bv offset value)
(loop (+ offset step) (cdr arg))))))))))
(define make-binary-array-of-char*
(lambda (ref . argv)
(apply vector
ref
(map (lambda (value) (string->cstring value)) argv))))
(define-syntax c-callback-arguments
(lambda (x)
(syntax-case x ()
((_ args ...)
(let ((lst (syntax->datum (syntax (args ...)))))
(if (for-all (lambda (arg) (memq arg '(int void*))) lst)
(datum->syntax #'k (length lst))
(syntax-violation 'c-callback "expected list of int or void* for argument" x)))))))
(define-syntax c-argument
(syntax-rules (int bool void* char* byte* double float c-callback __stdcall)
((_ name n int var)
(assert-int 'name n var))
((_ name n bool var)
(assert-bool 'name n var))
((_ name n void* var)
(assert-int 'name n var))
((_ name n float var)
(assert-float 'name n var))
((_ name n double var)
(assert-double 'name n var))
((_ name n byte* var)
(assert-bytevector 'name n var))
((_ name n char* var)
(string->cstring (assert-string 'name n var)))
((_ name n [int] var)
(apply make-binary-array-of-int (assert-int-vector 'name n var)))
((_ name n [char*] var)
(apply make-binary-array-of-char* 0 (assert-string-vector 'name n var)))
((_ name n (*[char*]) var)
(apply make-binary-array-of-char* 1 (assert-string-vector 'name n var)))
((_ name n [c-callback void (args ...)] var)
(make-callback 0 (c-callback-arguments args ...) (assert-closure 'name n var)))
((_ name n [c-callback int (args ...)] var)
(make-callback 0 (c-callback-arguments args ...) (assert-closure 'name n var)))
((_ name n [c-callback void __stdcall (args ...)] var)
(make-callback 1 (c-callback-arguments args ...) (assert-closure 'name n var)))
((_ name n [c-callback int __stdcall (args ...)] var)
(make-callback 1 (c-callback-arguments args ...) (assert-closure 'name n var)))))
(define-syntax c-function-stub
(lambda (x)
(syntax-case x ()
((_ lib-handle lib-name (cast stub) func-name types ...)
(with-syntax (((args ...) (generate-temporaries (syntax (types ...))))
((n ...) (map (lambda (e) (datum->syntax #'k e)) (iota (length (syntax (types ...))) 1))))
(syntax (let ((loc (lookup-shared-object lib-handle 'func-name)))
(if loc
(let () (define func-name
(lambda (args ...)
(cast (stub loc (c-argument func-name n types args) ...)))) func-name)
(let () (define func-name
(lambda x
(error 'func-name (format "function not available in ~a" lib-name)))) func-name))))))
((_ lib-handle lib-name stub func-name types ...)
(syntax (c-function-stub lib-handle lib-name ((lambda (x) x) stub) func-name types ...))))))
(define-syntax c-function
(syntax-rules (__stdcall void int double void* bool char*)
((_ lib-handle lib-name void __stdcall func-name (types ...))
(c-function-stub lib-handle lib-name stdcall-shared-object->void func-name types ...))
((_ lib-handle lib-name int __stdcall func-name (types ...))
(c-function-stub lib-handle lib-name stdcall-shared-object->int func-name types ...))
((_ lib-handle lib-name double __stdcall func-name (types ...))
(c-function-stub lib-handle lib-name stdcall-shared-object->double func-name types ...))
((_ lib-handle lib-name void* __stdcall func-name (types ...))
(c-function-stub lib-handle lib-name stdcall-shared-object->intptr func-name types ...))
((_ lib-handle lib-name bool __stdcall func-name (types ...))
(c-function-stub lib-handle lib-name (int->bool stdcall-shared-object->int) func-name types ...))
((_ lib-handle lib-name char* __stdcall func-name (types ...))
(c-function-stub lib-handle lib-name (char*->string stdcall-shared-object->char*) func-name types ...))
((_ lib-handle lib-name void func-name (types ...))
(c-function-stub lib-handle lib-name call-shared-object->void func-name types ...))
((_ lib-handle lib-name int func-name (types ...))
(c-function-stub lib-handle lib-name call-shared-object->int func-name types ...))
((_ lib-handle lib-name double func-name (types ...))
(c-function-stub lib-handle lib-name call-shared-object->double func-name types ...))
((_ lib-handle lib-name void* func-name (types ...))
(c-function-stub lib-handle lib-name call-shared-object->intptr func-name types ...))
((_ lib-handle lib-name bool func-name (types ...))
(c-function-stub lib-handle lib-name (int->bool call-shared-object->int) func-name types ...))
((_ lib-handle lib-name char* func-name (types ...))
(c-function-stub lib-handle lib-name (char*->string call-shared-object->char*) func-name types ...))))
) ;[end]

350
lab/ypsilon-ffi/gears.scm Executable file
View File

@ -0,0 +1,350 @@
#!/usr/bin/env ypsilon
;;
;; 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 (core) (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)
(u8-list->bytevector (reverse (bytevector->u8-list 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)
;; glGetString dose not works correctly.
(if (string? (glGetString GL_RENDERER))
(begin
(newline)
(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

3473
lab/ypsilon-ffi/gl.scm Normal file

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,192 @@
#!/usr/bin/env ypsilon
;; glut-demo.scm:
;; GLUT, OpenGL, FFI, and Concurrent GC Stress Test
;;
;; Requirements:
;; Darwin: OpenGL.framework GLUT.framework
;; Windows: opengl32.dll glut32.dll
;; Linux: libGL.so.1 libglut.so.3
(import (core) (gl) (glut)
(rename (except (rnrs) angle display)
(reverse rnrs:reverse))
(rnrs programs))
(begin
(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 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 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 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 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 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 visibility
(lambda (state)
(format #t "visibility callback ~s ~%" state)))
(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)
(u8-list->bytevector (rnrs:reverse (bytevector->u8-list bv))))
(else
(f32set! bv i (car lst))
(loop (+ i 1) (cdr lst)))))))
#;
(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)))
(run))

620
lab/ypsilon-ffi/glut.scm Normal file
View File

@ -0,0 +1,620 @@
;;; Ypsilon Scheme System
;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
;;; See license.txt for terms and conditions of use.
(library (glut)
(export GLUT_RGB
GLUT_RGBA
GLUT_INDEX
GLUT_SINGLE
GLUT_DOUBLE
GLUT_ACCUM
GLUT_ALPHA
GLUT_DEPTH
GLUT_STENCIL
GLUT_MULTISAMPLE
GLUT_STEREO
GLUT_LUMINANCE
GLUT_NO_RECOVERY
GLUT_LEFT_BUTTON
GLUT_MIDDLE_BUTTON
GLUT_RIGHT_BUTTON
GLUT_DOWN
GLUT_UP
GLUT_KEY_F1
GLUT_KEY_F2
GLUT_KEY_F3
GLUT_KEY_F4
GLUT_KEY_F5
GLUT_KEY_F6
GLUT_KEY_F7
GLUT_KEY_F8
GLUT_KEY_F9
GLUT_KEY_F10
GLUT_KEY_F11
GLUT_KEY_F12
GLUT_KEY_LEFT
GLUT_KEY_UP
GLUT_KEY_RIGHT
GLUT_KEY_DOWN
GLUT_KEY_PAGE_UP
GLUT_KEY_PAGE_DOWN
GLUT_KEY_HOME
GLUT_KEY_END
GLUT_KEY_INSERT
GLUT_LEFT
GLUT_ENTERED
GLUT_MENU_NOT_IN_USE
GLUT_MENU_IN_USE
GLUT_NOT_VISIBLE
GLUT_VISIBLE
GLUT_HIDDEN
GLUT_FULLY_RETAINED
GLUT_PARTIALLY_RETAINED
GLUT_FULLY_COVERED
GLUT_RED
GLUT_GREEN
GLUT_BLUE
GLUT_NORMAL
GLUT_OVERLAY
glutInit
glutInitDisplayString
glutInitDisplayMode
glutInitWindowPosition
glutInitWindowSize
glutMainLoop
glutCreateWindow
glutCreateSubWindow
glutDestroyWindow
glutPostRedisplay
glutPostWindowRedisplay
glutSwapBuffers
glutGetWindow
glutSetWindow
glutSetWindowTitle
glutSetIconTitle
glutPositionWindow
glutReshapeWindow
glutPopWindow
glutPushWindow
glutIconifyWindow
glutShowWindow
glutHideWindow
glutFullScreen
glutSetCursor
glutWarpPointer
glutEstablishOverlay
glutRemoveOverlay
glutUseLayer
glutPostOverlayRedisplay
glutPostWindowOverlayRedisplay
glutShowOverlay
glutHideOverlay
glutCreateMenu
glutDestroyMenu
glutGetMenu
glutSetMenu
glutAddMenuEntry
glutAddSubMenu
glutChangeToMenuEntry
glutChangeToSubMenu
glutRemoveMenuItem
glutAttachMenu
glutDetachMenu
glutDisplayFunc
glutReshapeFunc
glutKeyboardFunc
glutMouseFunc
glutMotionFunc
glutPassiveMotionFunc
glutEntryFunc
glutVisibilityFunc
glutIdleFunc
glutTimerFunc
glutMenuStateFunc
glutSpecialFunc
glutSpaceballMotionFunc
glutSpaceballRotateFunc
glutSpaceballButtonFunc
glutButtonBoxFunc
glutDialsFunc
glutTabletMotionFunc
glutTabletButtonFunc
glutMenuStatusFunc
glutOverlayDisplayFunc
glutWindowStatusFunc
glutKeyboardUpFunc
glutSpecialUpFunc
glutJoystickFunc
glutSetColor
glutGetColor
glutCopyColormap
glutGet
glutDeviceGet
glutExtensionSupported
glutGetModifiers
glutLayerGet
glutGetProcAddress
glutBitmapCharacter
glutBitmapWidth
glutStrokeCharacter
glutStrokeWidth
glutBitmapLength
glutStrokeLength
glutWireSphere
glutSolidSphere
glutWireCone
glutSolidCone
glutWireCube
glutSolidCube
glutWireTorus
glutSolidTorus
glutWireDodecahedron
glutSolidDodecahedron
glutWireTeapot
glutSolidTeapot
glutWireOctahedron
glutSolidOctahedron
glutWireTetrahedron
glutSolidTetrahedron
glutWireIcosahedron
glutSolidIcosahedron
glutVideoResizeGet
glutSetupVideoResizing
glutStopVideoResizing
glutVideoResize
glutVideoPan
glutReportErrors
glutIgnoreKeyRepeat
glutSetKeyRepeat
glutForceJoystickFunc
glutGameModeString
glutEnterGameMode
glutLeaveGameMode
glutGameModeGet)
(import (rnrs) (core) (ffi))
(define libGLUT (cond (on-darwin (load-shared-object "GLUT.framework/GLUT"))
(on-windows (load-shared-object "glut32.dll"))
(on-linux (load-shared-object "libglut.so.3"))
(on-freebsd (load-shared-object "libglut.so.4"))
(else (assertion-violation #f "can not locate GLUT library, unknown operating system"))))
;; Display mode bit masks.
(define GLUT_RGB 0)
(define GLUT_RGBA GLUT_RGB)
(define GLUT_INDEX 1)
(define GLUT_SINGLE 0)
(define GLUT_DOUBLE 2)
(define GLUT_ACCUM 4)
(define GLUT_ALPHA 8)
(define GLUT_DEPTH 16)
(define GLUT_STENCIL 32)
(define GLUT_MULTISAMPLE 128)
(define GLUT_STEREO 256)
(define GLUT_LUMINANCE 512)
(define GLUT_NO_RECOVERY 1024)
;; Mouse buttons.
(define GLUT_LEFT_BUTTON 0)
(define GLUT_MIDDLE_BUTTON 1)
(define GLUT_RIGHT_BUTTON 2)
;; Mouse button state.
(define GLUT_DOWN 0)
(define GLUT_UP 1)
;; function keys
(define GLUT_KEY_F1 1)
(define GLUT_KEY_F2 2)
(define GLUT_KEY_F3 3)
(define GLUT_KEY_F4 4)
(define GLUT_KEY_F5 5)
(define GLUT_KEY_F6 6)
(define GLUT_KEY_F7 7)
(define GLUT_KEY_F8 8)
(define GLUT_KEY_F9 9)
(define GLUT_KEY_F10 10)
(define GLUT_KEY_F11 11)
(define GLUT_KEY_F12 12)
;; directional keys
(define GLUT_KEY_LEFT 100)
(define GLUT_KEY_UP 101)
(define GLUT_KEY_RIGHT 102)
(define GLUT_KEY_DOWN 103)
(define GLUT_KEY_PAGE_UP 104)
(define GLUT_KEY_PAGE_DOWN 105)
(define GLUT_KEY_HOME 106)
(define GLUT_KEY_END 107)
(define GLUT_KEY_INSERT 108)
;; Entry/exit state.
(define GLUT_LEFT 0)
(define GLUT_ENTERED 1)
;; Menu usage state.
(define GLUT_MENU_NOT_IN_USE 0)
(define GLUT_MENU_IN_USE 1)
;; Visibility state.
(define GLUT_NOT_VISIBLE 0)
(define GLUT_VISIBLE 1)
;; Window status state.
(define GLUT_HIDDEN 0)
(define GLUT_FULLY_RETAINED 1)
(define GLUT_PARTIALLY_RETAINED 2)
(define GLUT_FULLY_COVERED 3)
;; Color index component selection values.
(define GLUT_RED 0)
(define GLUT_GREEN 1)
(define GLUT_BLUE 2)
;; Layers for use.
(define GLUT_NORMAL 0)
(define GLUT_OVERLAY 1)
(define-syntax define-function
(syntax-rules ()
((_ ret name args)
(define name (c-function libGLUT "GLUT library" ret __stdcall name args)))))
;; void glutInit(int *argcp, char **argv)
;; (define-function void glutInit ([int] [char*]))
(define glutInit
(if on-windows
(lambda (a1 a2)
(c-argument 'glutInit 1 [int] a1)
(c-argument 'glutInit 2 [char*] a2)
((c-function libGLUT "GLUT library" void __stdcall __glutInitWithExit ([int] [char*] [c-callback void (int)]))
a1 a2 (lambda (n) (exit n))))
(c-function libGLUT "GLUT library" void __stdcall glutInit ([int] [char*]))))
;; void glutInitDisplayString(const char *string)
(define-function void glutInitDisplayString (char*))
;; void glutInitDisplayMode(unsigned int mode)
(define-function void glutInitDisplayMode (int))
;; void glutInitWindowPosition(int x, int y)
(define-function void glutInitWindowPosition (int int))
;; void glutInitWindowSize(int width, int height)
(define-function void glutInitWindowSize (int int))
;; void glutMainLoop(void)
(define-function void glutMainLoop ())
;; int glutCreateWindow(const char *title)
(define-function int glutCreateWindow (char*))
;; int glutCreateSubWindow(int win, int x, int y, int width, int height)
(define-function int glutCreateSubWindow (int int int int int))
;; void glutDestroyWindow(int win)
(define-function void glutDestroyWindow (int))
;; void glutPostRedisplay(void)
(define-function void glutPostRedisplay ())
;; void glutPostWindowRedisplay(int win)
(define-function void glutPostWindowRedisplay (int))
;; void glutSwapBuffers(void)
(define-function void glutSwapBuffers ())
;; int glutGetWindow(void)
(define-function int glutGetWindow ())
;; void glutSetWindow(int win)
(define-function void glutSetWindow (int))
;; void glutSetWindowTitle(const char *title)
(define-function void glutSetWindowTitle (char*))
;; void glutSetIconTitle(const char *title)
(define-function void glutSetIconTitle (char*))
;; void glutPositionWindow(int x, int y)
(define-function void glutPositionWindow (int int))
;; void glutReshapeWindow(int width, int height)
(define-function void glutReshapeWindow (int int))
;; void glutPopWindow(void)
(define-function void glutPopWindow ())
;; void glutPushWindow(void)
(define-function void glutPushWindow ())
;; void glutIconifyWindow(void)
(define-function void glutIconifyWindow ())
;; void glutShowWindow(void)
(define-function void glutShowWindow ())
;; void glutHideWindow(void)
(define-function void glutHideWindow ())
;; void glutFullScreen(void)
(define-function void glutFullScreen ())
;; void glutSetCursor(int cursor)
(define-function void glutSetCursor (int))
;; void glutWarpPointer(int x, int y)
(define-function void glutWarpPointer (int int))
;; void glutEstablishOverlay(void)
(define-function void glutEstablishOverlay ())
;; void glutRemoveOverlay(void)
(define-function void glutRemoveOverlay ())
;; void glutUseLayer(GLenum layer)
(define-function void glutUseLayer (int))
;; void glutPostOverlayRedisplay(void)
(define-function void glutPostOverlayRedisplay ())
;; void glutPostWindowOverlayRedisplay(int win)
(define-function void glutPostWindowOverlayRedisplay (int))
;; void glutShowOverlay(void)
(define-function void glutShowOverlay ())
;; void glutHideOverlay(void)
(define-function void glutHideOverlay ())
;; int glutCreateMenu(void (*)(int))
(define-function void glutCreateMenu ([c-callback void (int)]))
;; void glutDestroyMenu(int menu)
(define-function void glutDestroyMenu (int))
;; int glutGetMenu(void)
(define-function int glutGetMenu ())
;; void glutSetMenu(int menu)
(define-function void glutSetMenu (int))
;; void glutAddMenuEntry(const char *label, int value)
(define-function void glutAddMenuEntry (char* int))
;; void glutAddSubMenu(const char *label, int submenu)
(define-function void glutAddSubMenu (char* int))
;; void glutChangeToMenuEntry(int item, const char *label, int value)
(define-function void glutChangeToMenuEntry (int char* int))
;; void glutChangeToSubMenu(int item, const char *label, int submenu)
(define-function void glutChangeToSubMenu (int char* int))
;; void glutRemoveMenuItem(int item)
(define-function void glutRemoveMenuItem (int))
;; void glutAttachMenu(int button)
(define-function void glutAttachMenu (int))
;; void glutDetachMenu(int button)
(define-function void glutDetachMenu (int))
;; void glutDisplayFunc(void (*func)(void))
(define-function void glutDisplayFunc ([c-callback void ()]))
;; void glutReshapeFunc(void (*func)(int width, int height))
(define-function void glutReshapeFunc ([c-callback void (int int)]))
;; void glutKeyboardFunc(void (*func)(unsigned char key, int x, int y))
(define-function void glutKeyboardFunc ([c-callback void (int int int)]))
;; void glutMouseFunc(void (*func)(int button, int state, int x, int y))
(define-function void glutMouseFunc ([c-callback void (int int int int)]))
;; void glutMotionFunc(void (*func)(int x, int y))
(define-function void glutMotionFunc ([c-callback void (int int)]))
;; void glutPassiveMotionFunc(void (*func)(int x, int y))
(define-function void glutPassiveMotionFunc ([c-callback void (int int)]))
;; void glutEntryFunc(void (*func)(int state))
(define-function void glutEntryFunc ([c-callback void (int)]))
;; void glutVisibilityFunc(void (*func)(int state))
(define-function void glutVisibilityFunc ([c-callback void (int)]))
;; void glutIdleFunc(void (*func)(void))
(define-function void glutIdleFunc ([c-callback void ()]))
;; void glutTimerFunc(unsigned int millis, void (*func)(int value), int value)
(define-function void glutTimerFunc (int [c-callback void (int)] int))
;; void glutMenuStateFunc(void (*func)(int state))
(define-function void glutMenuStateFunc ([c-callback void (int)]))
;; void glutSpecialFunc(void (*func)(int key, int x, int y))
(define-function void glutSpecialFunc ([c-callback void (int int int)]))
;; void glutSpaceballMotionFunc(void (*func)(int x, int y, int z))
(define-function void glutSpaceballMotionFunc ([c-callback void (int int int)]))
;; void glutSpaceballRotateFunc(void (*func)(int x, int y, int z))
(define-function void glutSpaceballRotateFunc ([c-callback void (int int int)]))
;; void glutSpaceballButtonFunc(void (*func)(int button, int state))
(define-function void glutSpaceballButtonFunc ([c-callback void (int int)]))
;; void glutButtonBoxFunc(void (*func)(int button, int state))
(define-function void glutButtonBoxFunc ([c-callback void (int int)]))
;; void glutDialsFunc(void (*func)(int dial, int value))
(define-function void glutDialsFunc ([c-callback void (int int)]))
;; void glutTabletMotionFunc(void (*func)(int x, int y))
(define-function void glutTabletMotionFunc ([c-callback void (int int)]))
;; void glutTabletButtonFunc(void (*func)(int button, int state, int x, int y))
(define-function void glutTabletButtonFunc ([c-callback void (int int int int)]))
;; void glutMenuStatusFunc(void (*func)(int status, int x, int y))
(define-function void glutMenuStatusFunc ([c-callback void (int int int)]))