diff --git a/collects/sgl/make-gl-info.ss b/collects/sgl/make-gl-info.ss index 39d131261c..bdf9b95a1d 100644 --- a/collects/sgl/make-gl-info.ss +++ b/collects/sgl/make-gl-info.ss @@ -1,15 +1,16 @@ -(module make-gl-info mzscheme - (require (prefix dynext: dynext/compile) - dynext/file - (prefix dynext: dynext/link) - mzlib/file - setup/dirs - launcher - srfi/13/string) - - (provide make-gl-info) - - (define c-file #< #include #include @@ -17,50 +18,50 @@ Scheme_Object *scheme_reload(Scheme_Env *env) { Scheme_Env *mod_env; - + mod_env = scheme_primitive_module(scheme_intern_symbol("make-gl-info-helper"), env); scheme_add_global("gl-byte-size", - scheme_make_integer_value(sizeof(GLbyte)), - mod_env); + scheme_make_integer_value(sizeof(GLbyte)), + mod_env); scheme_add_global("gl-ubyte-size", - scheme_make_integer_value(sizeof(GLubyte)), - mod_env); + scheme_make_integer_value(sizeof(GLubyte)), + mod_env); scheme_add_global("gl-short-size", - scheme_make_integer_value(sizeof(GLshort)), - mod_env); + scheme_make_integer_value(sizeof(GLshort)), + mod_env); scheme_add_global("gl-ushort-size", - scheme_make_integer_value(sizeof(GLushort)), - mod_env); + scheme_make_integer_value(sizeof(GLushort)), + mod_env); scheme_add_global("gl-int-size", - scheme_make_integer_value(sizeof(GLint)), - mod_env); + scheme_make_integer_value(sizeof(GLint)), + mod_env); scheme_add_global("gl-uint-size", - scheme_make_integer_value(sizeof(GLuint)), - mod_env); + scheme_make_integer_value(sizeof(GLuint)), + mod_env); scheme_add_global("gl-float-size", - scheme_make_integer_value(sizeof(GLfloat)), - mod_env); + scheme_make_integer_value(sizeof(GLfloat)), + mod_env); scheme_add_global("gl-double-size", - scheme_make_integer_value(sizeof(GLdouble)), - mod_env); + scheme_make_integer_value(sizeof(GLdouble)), + mod_env); scheme_add_global("gl-boolean-size", - scheme_make_integer_value(sizeof(GLboolean)), - mod_env); + scheme_make_integer_value(sizeof(GLboolean)), + mod_env); scheme_add_global("gl-sizei-size", - scheme_make_integer_value(sizeof(GLsizei)), - mod_env); + scheme_make_integer_value(sizeof(GLsizei)), + mod_env); scheme_add_global("gl-clampf-size", - scheme_make_integer_value(sizeof(GLclampf)), - mod_env); + scheme_make_integer_value(sizeof(GLclampf)), + mod_env); scheme_add_global("gl-clampd-size", - scheme_make_integer_value(sizeof(GLclampd)), - mod_env); + scheme_make_integer_value(sizeof(GLclampd)), + mod_env); scheme_add_global("gl-enum-size", - scheme_make_integer_value(sizeof(GLenum)), - mod_env); + scheme_make_integer_value(sizeof(GLenum)), + mod_env); scheme_add_global("gl-bitfield-size", - scheme_make_integer_value(sizeof(GLbitfield)), - mod_env); + scheme_make_integer_value(sizeof(GLbitfield)), + mod_env); scheme_finish_primitive_module(mod_env); return scheme_void; @@ -77,106 +78,101 @@ Scheme_Object *scheme_module_name(void) } end-string - ) +) - (define (delete/continue x) - (with-handlers ((exn:fail:filesystem? void)) - (delete-file x))) +(define (delete/continue x) + (with-handlers ([exn:fail:filesystem? void]) + (delete-file x))) - (define (parse-includes s) - (map (lambda (s) - (substring s 2 (string-length s))) - (string-tokenize s))) - - (define (get-args which-arg) - (let ((fp (build-path (find-lib-dir) "buildinfo"))) - (cond - ((file-exists? fp) - (call-with-input-file fp - (lambda (i) - (let loop ((l (read-line i))) - (cond - ((eof-object? l) "") - (else - (let ((m (regexp-match (format "^~a=(.*)$" which-arg) l))) - (if m - (cadr m) - (loop (read-line i)))))))))) - (else "")))) +(define (parse-includes s) + (map (lambda (s) (substring s 2 (string-length s))) + (string-tokenize s))) - (define (compile-c-to-so file file.c file.so) - (let ((file.o (append-object-suffix file))) - (dynext:compile-extension #f file.c file.o - `(,@(parse-includes (get-args "X_CFLAGS")) - ,(collection-path "compiler"))) - (dynext:link-extension #f (list file.o) file.so) - (delete/continue file.o))) +(define (get-args which-arg) + (let ([fp (build-path (find-lib-dir) "buildinfo")]) + (if (file-exists? fp) + (call-with-input-file fp + (lambda (i) + (let loop ([l (read-line i)]) + (if (eof-object? l) + "" + (let ([m (regexp-match (format "^~a=(.*)$" which-arg) l)]) + (if m + (cadr m) + (loop (read-line i)))))))) + ""))) - (define (build-helper compile-directory variant) - (let* ((file "make-gl-info-helper.ss") - (c (build-path compile-directory (append-c-suffix file))) - (so (build-path compile-directory - "native" - (system-library-subpath variant) - (append-extension-suffix file)))) - (make-directory* (build-path compile-directory "native" (system-library-subpath variant))) - (with-output-to-file c - (lambda () (display c-file)) - 'replace) - (compile-c-to-so file c so))) +(define (compile-c-to-so file file.c file.so) + (let ([file.o (append-object-suffix file)]) + (dynext:compile-extension #f file.c file.o + `(,@(parse-includes (get-args "X_CFLAGS")) + ,(collection-path "compiler"))) + (dynext:link-extension #f (list file.o) file.so) + (delete/continue file.o))) - (define (effective-system-type) - (let ([t (system-type)]) - (if (not (eq? t 'unix)) - t - ;; Check "buildinfo" for USE_GL flag: - (let ([buildinfo (build-path (find-lib-dir) "buildinfo")]) - (if (not (file-exists? buildinfo)) - (begin (printf "WARNING: buildinfo file missing: ~a\n" buildinfo) - t) - (with-input-from-file buildinfo - (lambda () - (if (regexp-match? #rx"-DUSE_GL" (current-input-port)) - t - (begin (printf "WARNING: no GL support\n") - 'no-gl))))))))) +(define (build-helper compile-directory variant) + (let* ([file "make-gl-info-helper.ss"] + [c (build-path compile-directory (append-c-suffix file))] + [so (build-path compile-directory "native" + (system-library-subpath variant) + (append-extension-suffix file))]) + (make-directory* (build-path compile-directory "native" + (system-library-subpath variant))) + (with-output-to-file c (lambda () (display c-file)) 'replace) + (compile-c-to-so file c so))) - (define (make-gl-info compile-directory) - (let ((zo (build-path compile-directory (append-zo-suffix "gl-info.ss"))) - (mod - (compile - (case (effective-system-type) - ((macosx windows no-gl) - `(,#'module gl-info mzscheme - (provide (all-defined)) - (define gl-byte-size 1) - (define gl-ubyte-size 1) - (define gl-short-size 2) - (define gl-ushort-size 2) - (define gl-int-size 4) - (define gl-uint-size 4) - (define gl-boolean-size 1) - (define gl-sizei-size 4) - (define gl-bitfield-size 4) - (define gl-enum-size 4) - (define gl-float-size 4) - (define gl-double-size 8) - (define gl-clampf-size 4) - (define gl-clampd-size 8))) - (else - (for-each (lambda (variant) - (parameterize ([dynext:link-variant variant]) - (build-helper compile-directory variant))) - (available-mzscheme-variants)) - `(,#'module gl-info mzscheme - (provide (all-defined)) - ,@(map - (lambda (x) - `(define ,x ,(dynamic-require 'sgl/make-gl-info-helper x))) - '(gl-byte-size gl-ubyte-size gl-short-size gl-ushort-size - gl-int-size gl-uint-size gl-boolean-size gl-sizei-size - gl-bitfield-size gl-enum-size gl-float-size gl-double-size - gl-clampf-size gl-clampd-size)))))))) - (with-output-to-file zo - (lambda () (write mod)) - 'replace)))) +(define (effective-system-type) + (let ([t (system-type)]) + (if (not (eq? t 'unix)) + t + ;; Check "buildinfo" for USE_GL flag: + (let ([buildinfo (build-path (find-lib-dir) "buildinfo")]) + (if (not (file-exists? buildinfo)) + (begin (printf "WARNING: buildinfo file missing: ~a\n" buildinfo) + t) + (with-input-from-file buildinfo + (lambda () + (if (regexp-match? #rx"-DUSE_GL" (current-input-port)) + t + (begin (printf "WARNING: no GL support\n") + 'no-gl))))))))) + +(define (make-gl-info compile-directory) + (let ([zo (build-path compile-directory (append-zo-suffix "gl-info.ss"))] + [mod + (compile + (case (effective-system-type) + [(macosx windows no-gl) + `(,#'module gl-info mzscheme + (provide (all-defined)) + (define gl-byte-size 1) + (define gl-ubyte-size 1) + (define gl-short-size 2) + (define gl-ushort-size 2) + (define gl-int-size 4) + (define gl-uint-size 4) + (define gl-boolean-size 1) + (define gl-sizei-size 4) + (define gl-bitfield-size 4) + (define gl-enum-size 4) + (define gl-float-size 4) + (define gl-double-size 8) + (define gl-clampf-size 4) + (define gl-clampd-size 8))] + [else + (for-each (lambda (variant) + (parameterize ([dynext:link-variant variant]) + (build-helper compile-directory variant))) + (available-mzscheme-variants)) + `(,#'module gl-info mzscheme + (provide (all-defined)) + ,@(map + (lambda (x) + `(define ,x ,(dynamic-require 'sgl/make-gl-info-helper x))) + '(gl-byte-size gl-ubyte-size gl-short-size gl-ushort-size + gl-int-size gl-uint-size gl-boolean-size gl-sizei-size + gl-bitfield-size gl-enum-size gl-float-size gl-double-size + gl-clampf-size gl-clampd-size)))]))]) + (with-output-to-file zo + (lambda () (write mod)) + 'replace))) diff --git a/collects/sgl/makefile.ss b/collects/sgl/makefile.ss index 7f114dde24..9ce7a3c574 100644 --- a/collects/sgl/makefile.ss +++ b/collects/sgl/makefile.ss @@ -1,18 +1,17 @@ -(module makefile mzscheme - (require make - setup/dirs - "make-gl-info.ss") +#lang mzscheme +(require make + setup/dirs + "make-gl-info.ss") - (provide pre-installer) +(provide pre-installer) - (define dir (build-path "compiled")) +(define dir (build-path "compiled")) - (define (pre-installer home) - (parameterize ((current-directory (collection-path "sgl")) - (make-print-reasons #f) - (make-print-checking #f)) - (make/proc - `((,(build-path dir "gl-info_ss.zo") - ("make-gl-info.ss" ,(build-path (find-include-dir) "schvers.h")) - ,(lambda () (make-gl-info dir))))))) - ) +(define (pre-installer home) + (parameterize ([current-directory (collection-path "sgl")] + [make-print-reasons #f] + [make-print-checking #f]) + (make/proc + `((,(build-path dir "gl-info_ss.zo") + ("make-gl-info.ss" ,(build-path (find-include-dir) "schvers.h")) + ,(lambda () (make-gl-info dir))))))) diff --git a/collects/sgl/sgl.ss b/collects/sgl/sgl.ss index 2c9114574b..d89496aa27 100644 --- a/collects/sgl/sgl.ss +++ b/collects/sgl/sgl.ss @@ -11,1020 +11,948 @@ ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. - -(module sgl mzscheme - (require mzlib/etc - "gl-vectors.ss" - "gl.ss") - - (define-syntax (_provide stx) - (syntax-case stx () - ((_ x ...) - (begin - #;(for-each - (lambda (x) - (syntax-case x (rename) - ((rename _ n) - (display (syntax-object->datum #'n))) - (_ (display (syntax-object->datum x)))) - (newline)) - (syntax->list #'(x ...))) - #'(provide x ...))))) - - (define-syntax-set (multi-arg multi-type-v) - - (define (iota n) - (cond - ((= 0 n) null) - (else (cons n (iota (sub1 n)))))) - - (define (get-possible-types-v ts) - (combine-str - (map (lambda (t) - (case t - ((iv) "gl-int-vector") - ((sv) "gl-short-vector") - ((bv) "gl-byte-vector") - ((uiv) "gl-uint-vector") - ((usv) "gl-ushort-vector") - ((ubv) "gl-ubyte-vector") - ((dv) "gl-double-vector") - ((fv) "gl-float-vector") - (else (error (format "~a" t))))) - ts))) - (define (combine-str strs) - (cond - ((null? strs) "") - ((null? (cdr strs)) - (string-append "or " (car strs))) - (else - (string-append (car strs) ", " (combine-str (cdr strs)))))) - - (define (multi-arg/proc stx) - (syntax-case stx () - ((_ name gl-name ((pre-arg-name pre-arg) ...) (num-arg ...)) - (let ((build-clause - (lambda (num-arg) - (with-syntax (((arg ...) - (generate-temporaries (iota num-arg))) - (gl-name - (datum->syntax-object - #'gl-name - (string->symbol - (format "~a~ad" - (syntax-object->datum #'gl-name) - num-arg)) - #'gl-name - #'gl-name))) - #`((pre-arg-name ... arg ...) - (cond - ((and (real? arg) ...) - (gl-name pre-arg ... arg ...)) - (else (raise-type-error 'name - "real numbers" - (list arg ...))))))))) - (with-syntax (((clauses ...) - (map build-clause - (syntax-object->datum #'(num-arg ...))))) - #`(define name - (case-lambda clauses ...))))))) - - (define (multi-type-v/proc stx) - (syntax-case stx () - ((_ name gl-name ((pre-arg-name pre-arg ) ...) - (length ...) (type ...) num? ) - (with-syntax ((arg (car (generate-temporaries (list #'name))))) - (let* ((num? (syntax-object->datum #'num?)) - (lengths (syntax-object->datum #'(length ...))) - (build-clause - (lambda (type) - (with-syntax ((pred? - (case type - ((dv) #'gl-double-vector?) - ((fv) #'gl-float-vector?) - ((iv) #'gl-int-vector?) - ((sv) #'gl-short-vector?) - ((bv) #'gl-byte-vector?) - ((uiv) #'gl-uint-vector?) - ((usv) #'gl-ushort-vector?) - ((ubv) #'gl-ubyte-vector?))) - ((clause ...) - (map - (lambda (length) - (with-syntax ((name - (datum->syntax-object - #'gl-name - (string->symbol - (format "~a~a~a" - (syntax-object->datum #'gl-name) - (if num? length "") - type)) - #'gl-name - #'gl-name))) - #`((#,length) (name pre-arg ... arg)))) - lengths))) - #`((pred? arg) - (case (gl-vector-length arg) - clause ... - (else (error - 'name - "expects vector with length in ~a: given vector has length ~a" - '(length ...) - (gl-vector-length arg)))))))) - (types (syntax-object->datum #'(type ...)))) - (with-syntax (((clause ...) (map build-clause types))) - #`(define (name pre-arg-name ... arg) - (cond - clause ... - (else - (raise-type-error 'name - #,(get-possible-types-v types) - arg))))))))))) - - (define-for-syntax gl-regex2 (regexp "(^GLU\\-)|(^GL\\-)")) - (define-for-syntax _-regex (regexp "_")) - - (define-for-syntax (translate-cname name) - (string->symbol - (string-downcase - (regexp-replace* gl-regex2 - (regexp-replace* _-regex - (symbol->string name) - "-") - "")))) - - (define-syntax (make-enum-table stx) +#lang mzscheme + +(require mzlib/etc + "gl-vectors.ss" + "gl.ss") + +(define-syntax (_provide stx) + (syntax-case stx () + [(_ x ...) + (begin + #; + (for-each + (lambda (x) + (syntax-case x (rename) + [(rename _ n) + (display (syntax-object->datum #'n))] + [_ (display (syntax-object->datum x))]) + (newline)) + (syntax->list #'(x ...))) + #'(provide x ...))])) + +(define-syntax-set (multi-arg multi-type-v) + + (define (iota n) + (if (= 0 n) null (cons n (iota (sub1 n))))) + + (define (get-possible-types-v ts) + (combine-str + (map (lambda (t) + (case t + [(iv) "gl-int-vector"] + [(sv) "gl-short-vector"] + [(bv) "gl-byte-vector"] + [(uiv) "gl-uint-vector"] + [(usv) "gl-ushort-vector"] + [(ubv) "gl-ubyte-vector"] + [(dv) "gl-double-vector"] + [(fv) "gl-float-vector"] + [else (error (format "~a" t))])) + ts))) + + (define (combine-str strs) + (cond [(null? strs) ""] + [(null? (cdr strs)) (string-append "or " (car strs))] + [else (string-append (car strs) ", " (combine-str (cdr strs)))])) + + (define (multi-arg/proc stx) (syntax-case stx () - ((_ name const ...) - (with-syntax (((sym ...) - (map translate-cname - (syntax-object->datum #'(const ...))))) - (cond - ((< (length (syntax->list #'(const ...))) 8) - (quasisyntax/loc stx - (define name - (let ((l `((sym . ,const) ...))) - (lambda (enum-sym name) - (let ((v (assq enum-sym l))) - (unless v - (raise-type-error name - (format "symbol in ~a" '(sym ...)) - enum-sym)) - (cdr v))))))) - (else - (quasisyntax/loc stx - (define name - (let ((ht (make-hash-table))) - (for-each (lambda (key value) - (hash-table-put! ht key value)) - '(sym ...) (list const ...)) - (lambda (enum-sym name) - (let ((v (hash-table-get ht enum-sym (lambda () #f)))) - (unless v - (raise-type-error name - (format "symbol in ~a" '(sym ...)) - enum-sym)) - v))))))))))) - - (define-syntax (make-inv-enum-table stx) + [(_ name gl-name ((pre-arg-name pre-arg) ...) (num-arg ...)) + (let ([build-clause + (lambda (num-arg) + (with-syntax ([(arg ...) + (generate-temporaries (iota num-arg))] + [gl-name + (datum->syntax-object + #'gl-name + (string->symbol + (format "~a~ad" + (syntax-object->datum #'gl-name) + num-arg)) + #'gl-name + #'gl-name)]) + #`((pre-arg-name ... arg ...) + (if (and (real? arg) ...) + (gl-name pre-arg ... arg ...) + (raise-type-error + 'name "real numbers" (list arg ...))))))]) + (with-syntax ([(clauses ...) + (map build-clause + (syntax-object->datum #'(num-arg ...)))]) + #`(define name + (case-lambda clauses ...))))])) + + (define (multi-type-v/proc stx) (syntax-case stx () - ((_ name const ...) - (with-syntax (((sym ...) - (map translate-cname - (syntax-object->datum #'(const ...))))) + [(_ name gl-name ((pre-arg-name pre-arg ) ...) + (length ...) (type ...) num? ) + (with-syntax ([arg (car (generate-temporaries (list #'name)))]) + (let* ([num? (syntax-object->datum #'num?)] + [lengths (syntax-object->datum #'(length ...))] + [build-clause + (lambda (type) + (with-syntax ([pred? + (case type + [(dv) #'gl-double-vector?] + [(fv) #'gl-float-vector?] + [(iv) #'gl-int-vector?] + [(sv) #'gl-short-vector?] + [(bv) #'gl-byte-vector?] + [(uiv) #'gl-uint-vector?] + [(usv) #'gl-ushort-vector?] + [(ubv) #'gl-ubyte-vector?])] + [(clause ...) + (map + (lambda (length) + (with-syntax ([name + (datum->syntax-object + #'gl-name + (string->symbol + (format "~a~a~a" + (syntax-object->datum #'gl-name) + (if num? length "") + type)) + #'gl-name + #'gl-name)]) + #`((#,length) (name pre-arg ... arg)))) + lengths)]) + #`((pred? arg) + (case (gl-vector-length arg) + clause ... + [else (error + 'name + "expects vector with length in ~a: given vector has length ~a" + '(length ...) + (gl-vector-length arg))]))))] + [types (syntax-object->datum #'(type ...))]) + (with-syntax ([(clause ...) (map build-clause types)]) + #`(define (name pre-arg-name ... arg) + (cond + clause ... + [else + (raise-type-error 'name + #,(get-possible-types-v types) + arg)])))))]))) + +(define-for-syntax (translate-cname name) + (let* ([r (symbol->string name)] + [r (regexp-replace* #rx"_" r "-")] + [r (regexp-replace #rx"^GLU?-" r "")] + [r (string-downcase r)]) + (string->symbol r))) + +(define-syntax (make-enum-table stx) + (syntax-case stx () + [(_ name const ...) + (with-syntax ([(sym ...) + (map translate-cname + (syntax-object->datum #'(const ...)))]) + (if (< (length (syntax->list #'(const ...))) 8) (quasisyntax/loc stx (define name - (let ((l `((,const . sym) ...))) - (lambda (enum-val) - (cdr (assq enum-val l)))))))))) - - (define check-length - (case-lambda - ((name v desired-length sym) - (unless (= desired-length (gl-vector-length v)) - (error name "expects vector of length ~a for ~a: argument vector has length ~a" - desired-length sym (gl-vector-length v)))) - ((name v desired-length) - (unless (= desired-length (gl-vector-length v)) - (error name "expects vector of length: argument vector has length ~a" - desired-length (gl-vector-length v)))))) + (let ([l `((sym . ,const) ...)]) + (lambda (enum-sym name) + (let ([v (assq enum-sym l)]) + (unless v + (raise-type-error name + (format "symbol in ~a" '(sym ...)) + enum-sym)) + (cdr v)))))) + (quasisyntax/loc stx + (define name + (let ([ht (make-hash-table)]) + (for-each (lambda (key value) + (hash-table-put! ht key value)) + '(sym ...) (list const ...)) + (lambda (enum-sym name) + (let ([v (hash-table-get ht enum-sym (lambda () #f))]) + (unless v + (raise-type-error name + (format "symbol in ~a" '(sym ...)) + enum-sym)) + v)))))))])) - ;; 2.5 - (_provide get-error) - (make-inv-enum-table get-error-table - GL_NO_ERROR - GL_INVALID_ENUM - GL_INVALID_VALUE - GL_INVALID_OPERATION - GL_STACK_OVERFLOW - GL_STACK_UNDERFLOW - GL_OUT_OF_MEMORY) - (define (get-error) - (get-error-table (glGetError))) +(define-syntax (make-inv-enum-table stx) + (syntax-case stx () + [(_ name const ...) + (with-syntax ([(sym ...) + (map translate-cname + (syntax-object->datum #'(const ...)))]) + (quasisyntax/loc stx + (define name + (let ([l `((,const . sym) ...)]) + (lambda (enum-val) + (cdr (assq enum-val l)))))))])) - ;; 2.6.1 - (_provide (rename gl-begin begin) (rename glEnd end)) - (make-enum-table begin-table - GL_LINES - GL_LINE_LOOP - GL_LINE_STRIP - GL_POINTS - GL_POLYGON - GL_QUADS - GL_QUAD_STRIP - GL_TRIANGLES - GL_TRIANGLE_FAN - GL_TRIANGLE_STRIP) - (define (gl-begin enum) - (glBegin (begin-table enum 'begin))) - - ;; 2.6.2 - (_provide (rename glEdgeFlag edge-flag)) +(define check-length + (case-lambda + [(name v desired-length sym) + (unless (= desired-length (gl-vector-length v)) + (error name "expects vector of length ~a for ~a: argument vector has length ~a" + desired-length sym (gl-vector-length v)))] + [(name v desired-length) + (unless (= desired-length (gl-vector-length v)) + (error name "expects vector of length ~a: argument vector has length ~a" + desired-length (gl-vector-length v)))])) - ;; 2.7 - (_provide vertex vertex-v - tex-coord tex-coord-v - multi-tex-coord multi-tex-coord-v - (rename glNormal3d normal) normal-v - color color-v - (rename glSecondaryColor3d secondary-color) secondary-color-v - (rename glIndexd index) index-v) +;; 2.5 +(_provide get-error) +(make-inv-enum-table get-error-table + GL_NO_ERROR + GL_INVALID_ENUM + GL_INVALID_VALUE + GL_INVALID_OPERATION + GL_STACK_OVERFLOW + GL_STACK_UNDERFLOW + GL_OUT_OF_MEMORY) +(define (get-error) + (get-error-table (glGetError))) - (multi-arg vertex glVertex () (2 3 4)) - (multi-type-v vertex-v glVertex () (2 3 4) (dv iv fv sv) #t) - (multi-arg tex-coord glTexCoord () (1 2 3 4)) - (multi-type-v tex-coord-v glTexCoord () (1 2 3 4) (dv iv fv sv) #t) - (make-enum-table multi-tex-coord-table - GL_TEXTURE0 GL_TEXTURE1 GL_TEXTURE2 GL_TEXTURE3 GL_TEXTURE4 - GL_TEXTURE5 GL_TEXTURE6 GL_TEXTURE7 GL_TEXTURE8 GL_TEXTURE9 - GL_TEXTURE10 GL_TEXTURE11 GL_TEXTURE12 GL_TEXTURE13 - GL_TEXTURE14 GL_TEXTURE15 GL_TEXTURE16 GL_TEXTURE17 - GL_TEXTURE18 GL_TEXTURE19 GL_TEXTURE20 GL_TEXTURE21 - GL_TEXTURE22 GL_TEXTURE23 GL_TEXTURE24 GL_TEXTURE25 - GL_TEXTURE26 GL_TEXTURE27 GL_TEXTURE28 GL_TEXTURE29 - GL_TEXTURE30 GL_TEXTURE31) - (multi-arg multi-tex-coord glMultiTexCoord - ((e (multi-tex-coord-table e 'multi-tex-coord))) - (1 2 3 4)) - (multi-type-v multi-tex-coord-v glMultiTexCoord - ((e (multi-tex-coord-table e 'multi-tex-coord))) - (1 2 3 4) - (sv iv fv dv) - #t) - (multi-type-v normal-v glNormal () (3) (dv iv fv sv bv) #t) - (multi-arg color glColor () (3 4)) - (multi-type-v color-v glColor () (3 4) (dv iv uiv fv ubv bv usv sv) #t) - (multi-type-v secondary-color-v glSecondaryColor () (3) (bv sv iv fv dv ubv usv uiv) #t) - (multi-type-v index-v glIndex () (1) (dv iv fv sv ubv) #f) +;; 2.6.1 +(_provide (rename gl-begin begin) (rename glEnd end)) +(make-enum-table begin-table + GL_LINES + GL_LINE_LOOP + GL_LINE_STRIP + GL_POINTS + GL_POLYGON + GL_QUADS + GL_QUAD_STRIP + GL_TRIANGLES + GL_TRIANGLE_FAN + GL_TRIANGLE_STRIP) +(define (gl-begin enum) + (glBegin (begin-table enum 'begin))) - ;; 2.8, 2.9 not implemented +;; 2.6.2 +(_provide (rename glEdgeFlag edge-flag)) - ;; 2.10 - (_provide (rename glRectd rect) rect-v) - (multi-type-v rect-v glRect () (4) (dv iv fv sv) #f) - - ;; 2.11.1 - (_provide (rename glDepthRange depth-range) (rename glViewport viewport)) - - ;; 2.11.2 - (_provide matrix-mode load-matrix mult-matrix - load-transpose-matrix mult-transpose-matrix - (rename glLoadIdentity load-identity) - (rename glRotated rotate) - (rename glTranslated translate) - (rename glScaled scale) - (rename glFrustum frustum) - (rename glOrtho ortho) - active-texture - (rename glPushMatrix push-matrix) - (rename glPopMatrix pop-matrix)) - - (make-enum-table matrix-mode-table - GL_MODELVIEW GL_PROJECTION GL_TEXTURE GL_COLOR) - (define (matrix-mode x) - (glMatrixMode (matrix-mode-table x 'matrix-mode))) - (define-values (glLoadMatrixfv glLoadMatrixdv glMultMatrixfv glMultMatrixdv - glLoadTransposeMatrixfv glLoadTransposeMatrixdv - glMultTransposeMatrixfv glMultTransposeMatrixdv) - (values glLoadMatrixf glLoadMatrixd glMultMatrixf glMultMatrixd - glLoadTransposeMatrixf glLoadTransposeMatrixd - glMultTransposeMatrixf glMultTransposeMatrixd)) - (multi-type-v load-matrix glLoadMatrix () (16) (fv dv) #f) - (multi-type-v mult-matrix glMultMatrix () (16) (fv dv) #f) - (multi-type-v load-transpose-matrix glLoadTransposeMatrix () (16) (fv dv) #f) - (multi-type-v mult-transpose-matrix glMultTransposeMatrix () (16) (fv dv) #f) - - (define (active-texture texture) - (glActiveTexture (multi-tex-coord-table texture 'active-texture texture))) +;; 2.7 +(_provide vertex vertex-v + tex-coord tex-coord-v + multi-tex-coord multi-tex-coord-v + (rename glNormal3d normal) normal-v + color color-v + (rename glSecondaryColor3d secondary-color) secondary-color-v + (rename glIndexd index) index-v) - ;; 2.11.3 - (_provide enable disable) - (make-enum-table enable-table - GL_VERTEX_ARRAY GL_NORMAL_ARRAY GL_FOG_COORD_ARRAY - GL_COLOR_ARRAY GL_SECONDARY_COLOR_ARRAY GL_INDEX_ARRAY - GL_TEXTURE_COORD_ARRAY GL_EDGE_FLAG_ARRAY - GL_NORMALIZE GL_RESCALE_NORMAL - GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 GL_CLIP_PLANE3 - GL_CLIP_PLANE4 GL_CLIP_PLANE5 - GL_FOG GL_COLOR_SUM - GL_LIGHTING GL_COLOR_MATERIAL - GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 GL_LIGHT4 - GL_LIGHT5 GL_LIGHT6 GL_LIGHT7 - GL_POINT_SMOOTH GL_LINE_SMOOTH GL_LINE_STIPPLE GL_CULL_FACE - GL_POLYGON_SMOOTH GL_POLYGON_OFFSET_POINT - GL_POLYGON_OFFSET_LINE GL_POLYGON_OFFSET_FILL - GL_POLYGON_STIPPLE - GL_MULTISAMPLE GL_SAMPLE_ALPHA_TO_COVERAGE - GL_SAMPLE_ALPHA_TO_ONE GL_SAMPLE_COVERAGE - GL_TEXTURE_1D GL_TEXTURE_2D GL_TEXTURE_3D - GL_TEXTURE_CUBE_MAP - GL_TEXTURE_GEN_S GL_TEXTURE_GEN_T - GL_TEXTURE_GEN_R GL_TEXTURE_GEN_Q - GL_SCISSOR_TEST GL_ALPHA_TEST GL_STENCIL_TEST - GL_DEPTH_TEST GL_BLEND GL_DITHER - GL_INDEX_LOGIC_OP GL_LOGIC_OP GL_COLOR_LOGIC_OP - GL_COLOR_TABLE GL_POST_CONVOLUTION_COLOR_TABLE - GL_POST_COLOR_MATRIX_COLOR_TABLE - GL_CONVOLUTION_1D GL_CONVOLUTION_2D GL_SEPARABLE_2D - GL_HISTOGRAM GL_MINMAX - GL_MAP1_VERTEX_3 GL_MAP1_VERTEX_4 GL_MAP1_INDEX - GL_MAP1_COLOR_4 GL_MAP1_NORMAL - GL_MAP1_TEXTURE_COORD_1 GL_MAP1_TEXTURE_COORD_2 - GL_MAP1_TEXTURE_COORD_3 GL_MAP1_TEXTURE_COORD_4 - GL_MAP2_VERTEX_3 GL_MAP2_VERTEX_4 GL_MAP2_INDEX - GL_MAP2_COLOR_4 GL_MAP2_NORMAL - GL_MAP2_TEXTURE_COORD_1 GL_MAP2_TEXTURE_COORD_2 - GL_MAP2_TEXTURE_COORD_3 GL_MAP2_TEXTURE_COORD_4 - GL_AUTO_NORMAL) - (define (enable x) - (glEnable (enable-table x 'enable))) - (define (disable x) - (glDisable (enable-table x 'disable))) +(multi-arg vertex glVertex () (2 3 4)) +(multi-type-v vertex-v glVertex () (2 3 4) (dv iv fv sv) #t) +(multi-arg tex-coord glTexCoord () (1 2 3 4)) +(multi-type-v tex-coord-v glTexCoord () (1 2 3 4) (dv iv fv sv) #t) +(make-enum-table multi-tex-coord-table + GL_TEXTURE0 GL_TEXTURE1 GL_TEXTURE2 GL_TEXTURE3 GL_TEXTURE4 + GL_TEXTURE5 GL_TEXTURE6 GL_TEXTURE7 GL_TEXTURE8 GL_TEXTURE9 + GL_TEXTURE10 GL_TEXTURE11 GL_TEXTURE12 GL_TEXTURE13 + GL_TEXTURE14 GL_TEXTURE15 GL_TEXTURE16 GL_TEXTURE17 + GL_TEXTURE18 GL_TEXTURE19 GL_TEXTURE20 GL_TEXTURE21 + GL_TEXTURE22 GL_TEXTURE23 GL_TEXTURE24 GL_TEXTURE25 + GL_TEXTURE26 GL_TEXTURE27 GL_TEXTURE28 GL_TEXTURE29 + GL_TEXTURE30 GL_TEXTURE31) +(multi-arg multi-tex-coord glMultiTexCoord + ((e (multi-tex-coord-table e 'multi-tex-coord))) + (1 2 3 4)) +(multi-type-v multi-tex-coord-v glMultiTexCoord + ((e (multi-tex-coord-table e 'multi-tex-coord))) + (1 2 3 4) + (sv iv fv dv) + #t) +(multi-type-v normal-v glNormal () (3) (dv iv fv sv bv) #t) +(multi-arg color glColor () (3 4)) +(multi-type-v color-v glColor () (3 4) (dv iv uiv fv ubv bv usv sv) #t) +(multi-type-v secondary-color-v glSecondaryColor () (3) (bv sv iv fv dv ubv usv uiv) #t) +(multi-type-v index-v glIndex () (1) (dv iv fv sv ubv) #f) - ;; 2.11.4 - (_provide tex-gen tex-gen-v) - (make-enum-table tex-gen-coord-table GL_S GL_T GL_R GL_Q) - (make-enum-table tex-gen-pname-table - GL_TEXTURE_GEN_MODE GL_OBJECT_PLANE GL_EYE_PLANE) - (make-enum-table tex-gen-param-table - GL_OBJECT_LINEAR GL_EYE_LINEAR GL_SPHERE_MAP - GL_REFLECTION_MAP GL_NORMAL_MAP) - (define (tex-gen c p n) - (let ((cv (tex-gen-coord-table c 'tex-gen)) - (pv (tex-gen-pname-table p 'tex-gen))) - (unless (= pv GL_TEXTURE_GEN_MODE) - (error 'tex-gen "does not accept ~a, use tex-gen-v instead" p)) - (glTexGeni cv pv (tex-gen-param-table n 'tex-gen)))) - (define (tex-gen-v c p v) - (let ((cv (tex-gen-coord-table c 'tex-gen-v)) - (pv (tex-gen-pname-table p 'tex-gen-v))) - (when (= pv GL_TEXTURE_GEN_MODE) - (error 'tex-gen-v "does not accept ~a, use tex-gen instead" p)) - (let ((f (cond - ((gl-int-vector? v) glTexGeniv) - ((gl-float-vector? v) glTexGenfv) - ((gl-double-vector? v) glTexGendv) - (else - (raise-type-error 'tex-gen-v - "gl-int-vector, gl-float-vector, or gl-double-vector" - 2 c p v))))) - (check-length 'tex-gen-v v 4) - (f cv pv v)))) - - ;; 2.12 - (_provide clip-plane) - (make-enum-table clip-plane-table - GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 - GL_CLIP_PLANE3 GL_CLIP_PLANE4 GL_CLIP_PLANE5) - (define (clip-plane p eqn) - (let ((v (clip-plane-table p 'clip-plane))) - (unless (gl-double-vector? eqn) - (raise-type-error 'clip-plane "gl-double-vector" 1 p eqn)) - (check-length 'clip-plane eqn 4) - (glClipPlane v eqn))) - - ;; 2.13 - (_provide raster-pos raster-pos-v - window-pos window-pos-v) - (multi-arg raster-pos glRasterPos () (2 3 4)) - (multi-type-v raster-pos-v glRasterPos () (2 3 4) (dv iv fv sv) #t) - (multi-arg window-pos glWindowPos () (2 3)) - (multi-type-v window-pos-v glWindowPos () (2 3) (dv iv fv sv) #t) - - ;; 2.14.1 - (_provide front-face) - (make-enum-table front-face-table GL_CCW GL_CW) - (define (front-face x) - (glFrontFace (front-face-table x 'front-face))) +;; 2.8, 2.9 not implemented - ;; 2.14.2 - (_provide material material-v light light-v light-model light-model-v) - (make-enum-table face-table GL_FRONT GL_BACK GL_FRONT_AND_BACK) - (make-enum-table material-pname-table - GL_AMBIENT GL_DIFFUSE GL_AMBIENT_AND_DIFFUSE - GL_SPECULAR GL_EMISSION GL_SHININESS GL_COLOR_INDEXES) - - (define (get-f v iv fv name a1 a2) - (cond - ((gl-int-vector? v) iv) - ((gl-float-vector? v) fv) - (else - (raise-type-error name - "gl-int-vector or gl-float-vector" - 2 a1 a2 v)))) - (define (do-f n v0 v1 i f name a0 a1) - (unless (real? n) - (raise-type-error name "real number" 2 a0 a1 n)) - (cond - ((and (exact? n) (integer? n)) - (i v0 v1 n)) - (else - (f v0 v1 n)))) - - (define (material face pname param) - (let ((v0 (face-table face 'material)) - (v1 (material-pname-table pname 'material))) - (unless (= v1 GL_SHININESS) - (error 'material "does not accept ~a, use material-v instead" pname)) - (do-f param v0 v1 glMateriali glMaterialf 'material face pname))) - - (define (material-v face pname params) - (let ((v0 (face-table face 'material-v)) - (v1 (material-pname-table pname 'material-v)) - (f (get-f params glMaterialiv glMaterialfv 'material-v face pname))) - (cond - ((= GL_SHININESS v1) - (check-length 'material-v params 1 pname)) - ((= GL_COLOR_INDEXES v1) - (check-length 'material-v params 3 pname)) - (else - (check-length 'material-v params 4 pname))) - (f v0 v1 params))) - - (make-enum-table light-light-table - GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 - GL_LIGHT4 GL_LIGHT5 GL_LIGHT6 GL_LIGHT7) - (make-enum-table light-pname-table - GL_AMBIENT GL_DIFFUSE GL_SPECULAR GL_POSITION - GL_SPOT_DIRECTION - GL_SPOT_EXPONENT GL_SPOT_CUTOFF - GL_CONSTANT_ATTENUATION GL_LINEAR_ATTENUATION - GL_QUADRATIC_ATTENUATION) - (define (light light pname param) - (let ((v0 (light-light-table light 'light)) - (v1 (light-pname-table pname 'light))) - (unless (memv v1 `(,GL_SPOT_EXPONENT ,GL_SPOT_CUTOFF - ,GL_CONSTANT_ATTENUATION ,GL_LINEAR_ATTENUATION - ,GL_QUADRATIC_ATTENUATION)) - (error 'light "does not accept ~a, use light-v instead" pname)) - (do-f param v0 v1 glLighti glLightf 'light light pname))) - - (define (light-v light pname params) - (let ((v0 (light-light-table light 'light-v)) - (v1 (light-pname-table pname 'light-v)) - (f (get-f params glLightiv glLightfv 'light-v light pname))) - (cond - ((= GL_SPOT_DIRECTION v1) - (check-length 'light-v params 3 pname)) - ((memv v1 `(,GL_AMBIENT ,GL_DIFFUSE ,GL_SPECULAR ,GL_POSITION)) - (check-length 'light-v params 4 pname)) - (else - (check-length 'light-v params 1 pname))) - (f v0 v1 params))) - - (make-enum-table light-model-table - GL_LIGHT_MODEL_AMBIENT - GL_LIGHT_MODEL_COLOR_CONTROL - GL_LIGHT_MODEL_LOCAL_VIEWER - GL_LIGHT_MODEL_TWO_SIDE) - - (define (light-model pname param) - (let ((v (light-model-table pname 'light-model))) - (when (= GL_LIGHT_MODEL_AMBIENT v) - (error 'light-model "does not accept ~a, use light-model-v instead" pname)) - (unless (real? param) - (raise-type-error 'light-model "real number" 1 pname param)) - (cond - ((and (exact? param) (integer? param)) - (glLightModeli v param)) - (else - (glLightModelf v param))))) - - (define (light-model-v pname params) - (let ((v (light-model-table pname 'light-model-v)) - (f (cond - ((gl-int-vector? params) glLightModeliv) - ((gl-float-vector? params) glLightModelfv) - (else - (raise-type-error 'light-model-v - "gl-int-vector or gl-float-vector" - 1 pname params))))) - (cond - ((= GL_LIGHT_MODEL_AMBIENT v) - (check-length 'light-model-v params 4 pname)) - (else - (check-length 'light-model-v params 1 pname))) - (f v params))) - - ;; 2.14.3 - (_provide color-material) - (make-enum-table color-material-mode-table - GL_EMISSION GL_AMBIENT GL_DIFFUSE - GL_SPECULAR GL_AMBIENT_AND_DIFFUSE) - (define (color-material x y) - (glColorMaterial (face-table x 'color-material) - (color-material-mode-table y 'color-material))) - - ;; 2.14.7 - (_provide shade-model) - (make-enum-table shade-model-table GL_FLAT GL_SMOOTH) - (define (shade-model x) - (glShadeModel (shade-model-table x 'shade-model))) +;; 2.10 +(_provide (rename glRectd rect) rect-v) +(multi-type-v rect-v glRect () (4) (dv iv fv sv) #f) - ;; 3.3 - (_provide (rename glPointSize point-size) - point-parameter point-parameter-v) - (make-enum-table point-parameter-table - GL_POINT_SIZE_MIN GL_POINT_SIZE_MAX - GL_POINT_DISTANCE_ATTENUATION - GL_POINT_FADE_THRESHOLD_SIZE) - (define (point-parameter pname param) - (let ((v (point-parameter-table pname 'point-parameter))) - (when (= GL_POINT_DISTANCE_ATTENUATION v) - (error 'point-parameter "does not accept ~a, use point-parameter-v instead" pname)) - (unless (real? param) - (raise-type-error 'point-parameter "real number" 1 pname param)) - (cond - ((and (exact? param) (integer? param)) - (glPointParameteri v param)) - (else - (glPointParameterf v param))))) - (define (point-parameter-v pname params) - (let ((v (point-parameter-table pname 'point-parameter)) - (f (cond - ((gl-int-vector? params) glPointParameteriv) - ((gl-float-vector? params) glPointParameterfv) - (else - (raise-type-error 'point-parameter-v - "gl-int-vector or gl-float-vector" - 1 pname params))))) - (cond - ((= GL_POINT_DISTANCE_ATTENUATION v) - (check-length 'point-parameter-v 3 pname)) - (else - (check-length 'light-model-v 1 pname))) - (f v params))) +;; 2.11.1 +(_provide (rename glDepthRange depth-range) (rename glViewport viewport)) - ;; 3.4 - (_provide (rename glLineWidth line-width)) - - ;; 3.4.2 - (_provide (rename glLineStipple line-stipple)) - - ;; 3.5.1 - (_provide cull-face) - (define (cull-face x) - (glCullFace (face-table x))) +;; 2.11.2 +(_provide matrix-mode load-matrix mult-matrix + load-transpose-matrix mult-transpose-matrix + (rename glLoadIdentity load-identity) + (rename glRotated rotate) + (rename glTranslated translate) + (rename glScaled scale) + (rename glFrustum frustum) + (rename glOrtho ortho) + active-texture + (rename glPushMatrix push-matrix) + (rename glPopMatrix pop-matrix)) - ;; 3.5.2 - ;; polygon-stipple +(make-enum-table matrix-mode-table + GL_MODELVIEW GL_PROJECTION GL_TEXTURE GL_COLOR) +(define (matrix-mode x) + (glMatrixMode (matrix-mode-table x 'matrix-mode))) +(define-values (glLoadMatrixfv glLoadMatrixdv glMultMatrixfv glMultMatrixdv + glLoadTransposeMatrixfv glLoadTransposeMatrixdv + glMultTransposeMatrixfv glMultTransposeMatrixdv) + (values glLoadMatrixf glLoadMatrixd glMultMatrixf glMultMatrixd + glLoadTransposeMatrixf glLoadTransposeMatrixd + glMultTransposeMatrixf glMultTransposeMatrixd)) +(multi-type-v load-matrix glLoadMatrix () (16) (fv dv) #f) +(multi-type-v mult-matrix glMultMatrix () (16) (fv dv) #f) +(multi-type-v load-transpose-matrix glLoadTransposeMatrix () (16) (fv dv) #f) +(multi-type-v mult-transpose-matrix glMultTransposeMatrix () (16) (fv dv) #f) - ;;3.5.4 - (_provide polygon-mode) - (make-enum-table polygon-mode-mode-table GL_POINT GL_LINE GL_FILL) - (define (polygon-mode x y) - (glPolygonMode (face-table x 'polygon-mode) - (polygon-mode-mode-table y 'polygon-mode))) +(define (active-texture texture) + (glActiveTexture (multi-tex-coord-table texture 'active-texture texture))) - ;; 3.5.5 - (_provide (rename glPolygonOffset polygon-offset)) - - ;; 3.6.1 - (_provide pixel-store) - (make-enum-table pixel-store-table - GL_UNPACK_SWAP_BYTES GL_UNPACK_LSB_FIRST - GL_UNPACK_ROW_LENGTH GL_UNPACK_SKIP_ROWS - GL_UNPACK_SKIP_PIXELS GL_UNPACK_ALIGNMENT - GL_UNPACK_IMAGE_HEIGHT GL_UNPACK_SKIP_IMAGES) - (define (pixel-store pname param) - (let ((v (pixel-store-table pname 'pixel-store))) - (unless (real? param) - (raise-type-error 'pixel-store - "real number" - 1 pname param)) - (cond - ((and (exact? param) (integer? param)) - (glPixelStorei v param)) - (else - (glPixelStoref v param))))) - - ;; 3.6.3, 3.6.4, 3.6.5, 3.7, 3.8, 3.10 not implemented - - ;; 4.1.2 - (_provide (rename glScissor scissor)) - - ;; 4.1.3 - (_provide (rename glSampleCoverage sample-coverage)) - - ;; 4.1.4 - (_provide alpha-func) - (make-enum-table func-table - GL_NEVER GL_ALWAYS GL_LESS GL_LEQUAL GL_EQUAL - GL_GEQUAL GL_GREATER GL_NOTEQUAL) - (define (alpha-func func ref) - (glAlphaFunc (func-table func 'alpha-func) ref)) - - ;; 4.1.5 - (_provide stencil-func stencil-op) - (define (stencil-func func ref mask) - (glStencilFunc (func-table func 'stencil-func) ref mask)) +;; 2.11.3 +(_provide enable disable) +(make-enum-table enable-table + GL_VERTEX_ARRAY GL_NORMAL_ARRAY GL_FOG_COORD_ARRAY + GL_COLOR_ARRAY GL_SECONDARY_COLOR_ARRAY GL_INDEX_ARRAY + GL_TEXTURE_COORD_ARRAY GL_EDGE_FLAG_ARRAY + GL_NORMALIZE GL_RESCALE_NORMAL + GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 GL_CLIP_PLANE3 + GL_CLIP_PLANE4 GL_CLIP_PLANE5 + GL_FOG GL_COLOR_SUM + GL_LIGHTING GL_COLOR_MATERIAL + GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 GL_LIGHT4 + GL_LIGHT5 GL_LIGHT6 GL_LIGHT7 + GL_POINT_SMOOTH GL_LINE_SMOOTH GL_LINE_STIPPLE GL_CULL_FACE + GL_POLYGON_SMOOTH GL_POLYGON_OFFSET_POINT + GL_POLYGON_OFFSET_LINE GL_POLYGON_OFFSET_FILL + GL_POLYGON_STIPPLE + GL_MULTISAMPLE GL_SAMPLE_ALPHA_TO_COVERAGE + GL_SAMPLE_ALPHA_TO_ONE GL_SAMPLE_COVERAGE + GL_TEXTURE_1D GL_TEXTURE_2D GL_TEXTURE_3D + GL_TEXTURE_CUBE_MAP + GL_TEXTURE_GEN_S GL_TEXTURE_GEN_T + GL_TEXTURE_GEN_R GL_TEXTURE_GEN_Q + GL_SCISSOR_TEST GL_ALPHA_TEST GL_STENCIL_TEST + GL_DEPTH_TEST GL_BLEND GL_DITHER + GL_INDEX_LOGIC_OP GL_LOGIC_OP GL_COLOR_LOGIC_OP + GL_COLOR_TABLE GL_POST_CONVOLUTION_COLOR_TABLE + GL_POST_COLOR_MATRIX_COLOR_TABLE + GL_CONVOLUTION_1D GL_CONVOLUTION_2D GL_SEPARABLE_2D + GL_HISTOGRAM GL_MINMAX + GL_MAP1_VERTEX_3 GL_MAP1_VERTEX_4 GL_MAP1_INDEX + GL_MAP1_COLOR_4 GL_MAP1_NORMAL + GL_MAP1_TEXTURE_COORD_1 GL_MAP1_TEXTURE_COORD_2 + GL_MAP1_TEXTURE_COORD_3 GL_MAP1_TEXTURE_COORD_4 + GL_MAP2_VERTEX_3 GL_MAP2_VERTEX_4 GL_MAP2_INDEX + GL_MAP2_COLOR_4 GL_MAP2_NORMAL + GL_MAP2_TEXTURE_COORD_1 GL_MAP2_TEXTURE_COORD_2 + GL_MAP2_TEXTURE_COORD_3 GL_MAP2_TEXTURE_COORD_4 + GL_AUTO_NORMAL) +(define (enable x) + (glEnable (enable-table x 'enable))) +(define (disable x) + (glDisable (enable-table x 'disable))) - (make-enum-table stencil-op-table - GL_KEEP GL_ZERO GL_REPLACE GL_INCR GL_DECR GL_INVERT - GL_INCR_WRAP GL_DECR_WRAP) - (define (stencil-op sfail dpfail dppass) - (glStencilOp (stencil-op-table sfail 'stencil-op) - (stencil-op-table dpfail 'stencil-op) - (stencil-op-table dppass 'stencil-op))) - - ;; 4.1.6 - (_provide depth-func) - (define (depth-func func) - (glDepthFunc (func-table func 'depth-func))) +;; 2.11.4 +(_provide tex-gen tex-gen-v) +(make-enum-table tex-gen-coord-table GL_S GL_T GL_R GL_Q) +(make-enum-table tex-gen-pname-table + GL_TEXTURE_GEN_MODE GL_OBJECT_PLANE GL_EYE_PLANE) +(make-enum-table tex-gen-param-table + GL_OBJECT_LINEAR GL_EYE_LINEAR GL_SPHERE_MAP + GL_REFLECTION_MAP GL_NORMAL_MAP) +(define (tex-gen c p n) + (let ([cv (tex-gen-coord-table c 'tex-gen)] + [pv (tex-gen-pname-table p 'tex-gen)]) + (unless (= pv GL_TEXTURE_GEN_MODE) + (error 'tex-gen "does not accept ~a, use tex-gen-v instead" p)) + (glTexGeni cv pv (tex-gen-param-table n 'tex-gen)))) +(define (tex-gen-v c p v) + (let ([cv (tex-gen-coord-table c 'tex-gen-v)] + [pv (tex-gen-pname-table p 'tex-gen-v)]) + (when (= pv GL_TEXTURE_GEN_MODE) + (error 'tex-gen-v "does not accept ~a, use tex-gen instead" p)) + (let ([f (cond [(gl-int-vector? v) glTexGeniv] + [(gl-float-vector? v) glTexGenfv] + [(gl-double-vector? v) glTexGendv] + [else (raise-type-error + 'tex-gen-v + "gl-int-vector, gl-float-vector, or gl-double-vector" + 2 c p v)])]) + (check-length 'tex-gen-v v 4) + (f cv pv v)))) - ;; 4.1.7 - (_provide begin-query end-query - (rename glGenQueries gen-queries) - (rename glDeleteQueries delete-queries)) - (make-enum-table query-table GL_SAMPLES_PASSED) - (define (begin-query target id) - (glBeginQuery (query-table target 'begin-query) id)) - (define (end-query target) - (glEndQuery (query-table target 'end-query))) - +;; 2.12 +(_provide clip-plane) +(make-enum-table clip-plane-table + GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 + GL_CLIP_PLANE3 GL_CLIP_PLANE4 GL_CLIP_PLANE5) +(define (clip-plane p eqn) + (let ([v (clip-plane-table p 'clip-plane)]) + (unless (gl-double-vector? eqn) + (raise-type-error 'clip-plane "gl-double-vector" 1 p eqn)) + (check-length 'clip-plane eqn 4) + (glClipPlane v eqn))) - ;; 4.1.8 - (_provide blend-equation blend-func blend-func-separate - (rename glBlendColor blend-color)) +;; 2.13 +(_provide raster-pos raster-pos-v + window-pos window-pos-v) +(multi-arg raster-pos glRasterPos () (2 3 4)) +(multi-type-v raster-pos-v glRasterPos () (2 3 4) (dv iv fv sv) #t) +(multi-arg window-pos glWindowPos () (2 3)) +(multi-type-v window-pos-v glWindowPos () (2 3) (dv iv fv sv) #t) - (make-enum-table blend-equation-table - GL_FUNC_ADD GL_FUNC_SUBTRACT GL_FUNC_REVERSE_SUBTRACT - GL_MIN GL_MAX) - (define (blend-equation func) - (glBlendEquation (blend-equation-table func 'blend-equation))) - - (make-enum-table blend-func-table - GL_ZERO GL_ONE - GL_SRC_COLOR GL_ONE_MINUS_SRC_COLOR - GL_DST_COLOR GL_ONE_MINUS_DST_COLOR - GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA - GL_DST_ALPHA GL_ONE_MINUS_DST_ALPHA - GL_CONSTANT_COLOR GL_ONE_MINUS_CONSTANT_COLOR - GL_CONSTANT_ALPHA GL_ONE_MINUS_CONSTANT_ALPHA - GL_SRC_ALPHA_SATURATE) - (define (blend-func src dest) - (glBlendFunc (blend-func-table src 'blend-func) - (blend-func-table dest 'blend-func))) +;; 2.14.1 +(_provide front-face) +(make-enum-table front-face-table GL_CCW GL_CW) +(define (front-face x) + (glFrontFace (front-face-table x 'front-face))) - (define (blend-func-separate src dest src-alpha dst-alpha) - (glBlendFuncSeparate (blend-func-table src 'blend-func) - (blend-func-table dest 'blend-func) - (blend-func-table src-alpha 'blend-func) - (blend-func-table dst-alpha 'blend-func))) +;; 2.14.2 +(_provide material material-v light light-v light-model light-model-v) +(make-enum-table face-table GL_FRONT GL_BACK GL_FRONT_AND_BACK) +(make-enum-table material-pname-table + GL_AMBIENT GL_DIFFUSE GL_AMBIENT_AND_DIFFUSE + GL_SPECULAR GL_EMISSION GL_SHININESS GL_COLOR_INDEXES) - ;; 4.1.10 - (provide logic-op) - (make-enum-table logic-op-table - GL_CLEAR GL_AND GL_AND_REVERSE GL_COPY GL_AND_INVERTED - GL_NOOP GL_XOR GL_OR GL_NOR GL_EQUIV GL_INVERT GL_OR_REVERSE - GL_COPY_INVERTED GL_OR_INVERTED GL_NAND GL_SET) - (define (logic-op op) - (glLogicOp logic-op-table op 'logic-op)) +(define (get-f v iv fv name a1 a2) + (cond [(gl-int-vector? v) iv] + [(gl-float-vector? v) fv] + [else (raise-type-error name + "gl-int-vector or gl-float-vector" + 2 a1 a2 v)])) +(define (do-f n v0 v1 i f name a0 a1) + (unless (real? n) + (raise-type-error name "real number" 2 a0 a1 n)) + (if (exact-integer? n) + (i v0 v1 n) + (f v0 v1 n))) - ;; 4.2.1 - (provide draw-buffer) - (make-enum-table draw-buffer-table - GL_NONE GL_FRONT_LEFT GL_FRONT_RIGHT GL_BACK_LEFT - GL_BACK_RIGHT GL_FRONT GL_BACK GL_LEFT GL_RIGHT - GL_FRONT_AND_BACK - GL_AUX0 GL_AUX1 GL_AUX2 GL_AUX3) - (define (draw-buffer buf) - (glDrawBuffer (draw-buffer-table buf 'draw-buffer))) +(define (material face pname param) + (let ([v0 (face-table face 'material)] + [v1 (material-pname-table pname 'material)]) + (unless (= v1 GL_SHININESS) + (error 'material "does not accept ~a, use material-v instead" pname)) + (do-f param v0 v1 glMateriali glMaterialf 'material face pname))) - ;; 4.2.2 - (_provide (rename glIndexMask index-mask) - (rename glColorMask color-mask) - (rename glDepthMask depth-mask) - (rename glStencilMask stencil-mask)) - - ;; 4.2.3 - (_provide clear - (rename glClearColor clear-color) - (rename glClearIndex clear-index) - (rename glClearDepth clear-depth) - (rename glClearStencil clear-stencil) - (rename glClearAccum clear-accum)) - (make-enum-table clear-table - GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT - GL_DEPTH_BUFFER_BIT GL_STENCIL_BUFFER_BIT) - (define clear - (lambda x - (glClear (apply bitwise-ior (map (lambda (x) - (clear-table x 'clear)) - x))))) +(define (material-v face pname params) + (let ([v0 (face-table face 'material-v)] + [v1 (material-pname-table pname 'material-v)] + [f (get-f params glMaterialiv glMaterialfv 'material-v face pname)]) + (check-length 'material-v params + (cond [(= GL_SHININESS v1) 1] + [(= GL_COLOR_INDEXES v1) 3] + [else 4]) + pname) + (f v0 v1 params))) - ;; 4.2.4 - (_provide accum) - (make-enum-table accum-table - GL_ACCUM GL_MULT GL_RETURN GL_MULT GL_ADD) - (define (accum op value) - (glAccum (accum-table op 'accum) value)) +(make-enum-table light-light-table + GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 + GL_LIGHT4 GL_LIGHT5 GL_LIGHT6 GL_LIGHT7) +(make-enum-table light-pname-table + GL_AMBIENT GL_DIFFUSE GL_SPECULAR GL_POSITION + GL_SPOT_DIRECTION + GL_SPOT_EXPONENT GL_SPOT_CUTOFF + GL_CONSTANT_ATTENUATION GL_LINEAR_ATTENUATION + GL_QUADRATIC_ATTENUATION) +(define (light light pname param) + (let ([v0 (light-light-table light 'light)] + [v1 (light-pname-table pname 'light)]) + (unless (memv v1 `(,GL_SPOT_EXPONENT ,GL_SPOT_CUTOFF + ,GL_CONSTANT_ATTENUATION ,GL_LINEAR_ATTENUATION + ,GL_QUADRATIC_ATTENUATION)) + (error 'light "does not accept ~a, use light-v instead" pname)) + (do-f param v0 v1 glLighti glLightf 'light light pname))) - ;; 4.3.2 not implemented +(define (light-v light pname params) + (let ([v0 (light-light-table light 'light-v)] + [v1 (light-pname-table pname 'light-v)] + [f (get-f params glLightiv glLightfv 'light-v light pname)]) + (check-length + 'light-v params + (cond [(= GL_SPOT_DIRECTION v1) 3] + [(memv v1 `(,GL_AMBIENT ,GL_DIFFUSE ,GL_SPECULAR ,GL_POSITION)) 4] + [else 1]) + pname) + (f v0 v1 params))) - ;; 4.3.3 - (_provide copy-pixels) - (make-enum-table copy-pixels-table - GL_COLOR GL_STENCIL GL_DEPTH) - (define (copy-pixels a b c d e) - (glCopyPixels a b c d (copy-pixels-table e 'copy-pixels))) +(make-enum-table light-model-table + GL_LIGHT_MODEL_AMBIENT + GL_LIGHT_MODEL_COLOR_CONTROL + GL_LIGHT_MODEL_LOCAL_VIEWER + GL_LIGHT_MODEL_TWO_SIDE) - ;; 5.1 - (_provide ;map1 map2 - eval-coord eval-coord-v map-grid eval-mesh eval-point) - (multi-arg eval-coord glEvalCoord () (1 2)) - (multi-type-v eval-coord-v glEvalCoord () (1 2) (dv fv) #t) - (define map-grid - (case-lambda - ((n a b) (glMapGrid1d n a b)) - ((m a b n c d) (glMapGrid2d m a b n c d)))) - (make-enum-table eval-mesh-table GL_POINT GL_LINE) - (define eval-mesh - (case-lambda - ((e a b) (glEvalMesh1 (eval-mesh-table e 'eval-mesh) a b)) - ((e a b c d) (glEvalMesh2 (eval-mesh-table e 'eval-mesh) a b c d)))) - (define eval-point - (case-lambda - ((x) (glEvalPoint1 x)) - ((x y) (glEvalPoint2 x y)))) +(define (light-model pname param) + (let ([v (light-model-table pname 'light-model)]) + (when (= GL_LIGHT_MODEL_AMBIENT v) + (error 'light-model "does not accept ~a, use light-model-v instead" pname)) + (unless (real? param) + (raise-type-error 'light-model "real number" 1 pname param)) + (if (exact-integer? param) + (glLightModeli v param) + (glLightModelf v param)))) - ;; 5.2 - (_provide (rename glInitNames init-names) - (rename glPopName pop-name) - (rename glPushName push-name) - (rename glLoadName load-name) - render-mode - select-buffer->gl-uint-vector) - (make-enum-table render-mode-table GL_RENDER GL_SELECT GL_FEEDBACK) - (define (render-mode x) - (glRenderMode (render-mode-table x 'render-mode))) +(define (light-model-v pname params) + (let ([v (light-model-table pname 'light-model-v)] + [f (cond [(gl-int-vector? params) glLightModeliv] + [(gl-float-vector? params) glLightModelfv] + [else (raise-type-error 'light-model-v + "gl-int-vector or gl-float-vector" + 1 pname params)])]) + (check-length 'light-model-v params + (if (= GL_LIGHT_MODEL_AMBIENT v) 4 1) + pname) + (f v params))) - ;; 5.3 - (_provide feedback-buffer->gl-float-vector - (rename glPassThrough pass-through)) - - ;; 5.4 - (_provide new-list - (rename glEndList end-list) - (rename glCallList call-list) - ;call-lists - (rename glListBase list-base) - (rename glGenLists gen-lists) - (rename glIsList is-list) - (rename glDeleteLists delete-lists)) - (make-enum-table new-list-table GL_COMPILE GL_COMPILE_AND_EXECUTE) - (define (new-list n mode) - (glNewList n (new-list-table mode 'new-list))) +;; 2.14.3 +(_provide color-material) +(make-enum-table color-material-mode-table + GL_EMISSION GL_AMBIENT GL_DIFFUSE + GL_SPECULAR GL_AMBIENT_AND_DIFFUSE) +(define (color-material x y) + (glColorMaterial (face-table x 'color-material) + (color-material-mode-table y 'color-material))) - ;; 5.5 - (_provide (rename glFlush flush) - (rename glFinish finish)) - - ;; 5.6 - (_provide hint) - (make-enum-table hint-target-table - GL_PERSPECTIVE_CORRECTION_HINT GL_POINT_SMOOTH_HINT - GL_LINE_SMOOTH_HINT GL_POLYGON_SMOOTH_HINT GL_FOG_HINT - GL_GENERATE_MIPMAP_HINT GL_TEXTURE_COMPRESSION_HINT) - (make-enum-table hint-hint-table GL_FASTEST GL_NICEST GL_DONT_CARE) - (define (hint target hint) - (glHint (hint-target-table target 'hint) - (hint-hint-table hint 'hint))) +;; 2.14.7 +(_provide shade-model) +(make-enum-table shade-model-table GL_FLAT GL_SMOOTH) +(define (shade-model x) + (glShadeModel (shade-model-table x 'shade-model))) - ;; 6.1.1 - (_provide ;glGetBooleanv glGetIntegerv glGetFloatv glGetDoublev - is-enabled) - (define (is-enabled e) - (glIsEnabled (enable-table e 'is-enabled))) +;; 3.3 +(_provide (rename glPointSize point-size) + point-parameter point-parameter-v) +(make-enum-table point-parameter-table + GL_POINT_SIZE_MIN GL_POINT_SIZE_MAX + GL_POINT_DISTANCE_ATTENUATION + GL_POINT_FADE_THRESHOLD_SIZE) +(define (point-parameter pname param) + (let ([v (point-parameter-table pname 'point-parameter)]) + (when (= GL_POINT_DISTANCE_ATTENUATION v) + (error 'point-parameter + "does not accept ~a, use point-parameter-v instead" pname)) + (unless (real? param) + (raise-type-error 'point-parameter "real number" 1 pname param)) + (if (exact-integer? param) + (glPointParameteri v param) + (glPointParameterf v param)))) +(define (point-parameter-v pname params) + (let ([v (point-parameter-table pname 'point-parameter)] + [f (cond [(gl-int-vector? params) glPointParameteriv] + [(gl-float-vector? params) glPointParameterfv] + [else (raise-type-error 'point-parameter-v + "gl-int-vector or gl-float-vector" + 1 pname params)])]) + (check-length 'point-parameter-v + (if (= GL_POINT_DISTANCE_ATTENUATION v) 3 1) + pname) + (f v params))) - ;; 6.1.3, 6.1.4, 6.1.5, 6.1.7, 6.1.8, 6.1.9, 6.1.10 not implemented +;; 3.4 +(_provide (rename glLineWidth line-width)) - ;; 6.1.11 - (_provide ;get-pointer-v - get-string) - - (make-enum-table get-string-table - GL_VENDOR GL_RENDERER GL_VERSION GL_EXTENSIONS) - (define (get-string x) - (glGetString (get-string-table x 'get-string))) +;; 3.4.2 +(_provide (rename glLineStipple line-stipple)) - ;; 6.1.12 - (_provide (rename glIsQuery is-query) - ;get-query get-query-object - ) - - ;; 6.1.13 - (_provide (rename glIsBuffer is-buffer) - ; get-buffer-sub-data get-buffer-pointer-v - ) - - ;; 6.1.14 - (_provide push-attrib push-client-attrib - (rename glPopAttrib pop-attrib) - (rename glPopClientAttrib pop-client-attrib)) - (make-enum-table push-attrib-table - GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT GL_CURRENT_BIT - GL_DEPTH_BUFFER_BIT GL_ENABLE_BIT GL_EVAL_BIT GL_FOG_BIT GL_HINT_BIT - GL_LIGHTING_BIT GL_LINE_BIT GL_LIST_BIT GL_MULTISAMPLE_BIT - GL_PIXEL_MODE_BIT GL_POINT_BIT GL_POLYGON_BIT GL_POLYGON_STIPPLE_BIT - GL_SCISSOR_BIT GL_STENCIL_BUFFER_BIT GL_TEXTURE_BIT - GL_TRANSFORM_BIT GL_VIEWPORT_BIT GL_ALL_ATTRIB_BITS) - (define push-attrib - (lambda x - (glPushAttrib (apply bitwise-ior (map (lambda (x) - (push-attrib-table x 'clear)) - x))))) - (make-enum-table push-client-attrib-table - GL_CLIENT_VERTEX_ARRAY_BIT - GL_CLIENT_PIXEL_STORE_BIT - GL_CLIENT_ALL_ATTRIB_BITS) - (define push-client-attrib - (lambda x - (glPushClientAttrib (apply bitwise-ior - (map (lambda (x) - (push-client-attrib-table x 'clear)) - x))))) - - - - ;; 2 - (_provide u-get-string - (rename gluCheckExtension check-extension)) - (make-enum-table u-get-string-table GLU_VERSION GLU_EXTENSIONS) - (define (u-get-string x) - (gluGetString (u-get-string-table x 'u-get-string))) +;; 3.5.1 +(_provide cull-face) +(define (cull-face x) + (glCullFace (face-table x))) - ;; 3 not implemented +;; 3.5.2 +;; polygon-stipple - ;; 4.1 - (_provide (rename gluOrtho2D ortho-2d) - (rename gluPerspective perspective) - (rename gluLookAt look-at) - pick-matrix) - (define (pick-matrix a b c d v) - (unless (gl-int-vector? v) - (raise-type-error 'pick-matrix - "gl-int-vector" - 4 a b c d v)) - (check-length 'pick-matrix v 4) - (gluPickMatrix a b c d v)) - - ;; 4.2 - (_provide project un-project un-project4) - (define (project a b c d e f) - (unless (gl-double-vector? d) - (raise-type-error 'project - "gl-double-vector" - 3 a b c d e f)) - (unless (gl-double-vector? e) - (raise-type-error 'project - "gl-double-vector" - 4 a b c d e f)) - (unless (gl-int-vector? f) - (raise-type-error 'project - "gl-double-vector" - 5 a b c d e f)) - (check-length 'project d 16) - (check-length 'project e 16) - (check-length 'project f 4) - (gluProject a b c d e f)) +;;3.5.4 +(_provide polygon-mode) +(make-enum-table polygon-mode-mode-table GL_POINT GL_LINE GL_FILL) +(define (polygon-mode x y) + (glPolygonMode (face-table x 'polygon-mode) + (polygon-mode-mode-table y 'polygon-mode))) - (define (un-project a b c d e f) - (unless (gl-double-vector? d) - (raise-type-error 'un-project - "gl-double-vector" - 3 a b c d e f)) - (unless (gl-double-vector? e) - (raise-type-error 'un-project - "gl-double-vector" - 4 a b c d e f)) - (unless (gl-int-vector? f) - (raise-type-error 'un-project - "gl-double-vector" - 5 a b c d e f)) - (check-length 'un-project d 16) - (check-length 'un-project e 16) - (check-length 'un-project f 4) - (gluUnProject a b c d e f)) +;; 3.5.5 +(_provide (rename glPolygonOffset polygon-offset)) - (define (un-project4 a b c d e f g h i) - (unless (gl-double-vector? e) - (raise-type-error 'un-project - "gl-double-vector" - 4 a b c d e f g h i)) - (unless (gl-double-vector? f) - (raise-type-error 'un-project - "gl-double-vector" - 5 a b c d e f g h i)) - (unless (gl-int-vector? g) - (raise-type-error 'un-project - "gl-double-vector" - 6 a b c d e f g h i)) - (check-length 'un-project4 e 16) - (check-length 'un-project4 f 16) - (check-length 'un-project4 g 4) - (gluUnProject4 a b c d e f g h i)) - - ;; 5 not implemented - - ;; 6.1 - (_provide (rename gluNewQuadric new-quadric)) - - ;; 6.2 not implemented - - ;; 6.3 - (_provide quadric-normals - (rename gluQuadricTexture quadric-texture) - quadric-orientation quadric-draw-style) - - (make-enum-table quadric-normals-table GLU_NONE GLU_FLAT GLU_SMOOTH) - (define (quadric-normals q e) - (gluQuadricNormals q (quadric-normals-table e 'quadric-normals))) - - (make-enum-table quadric-orientation-table GLU_INSIDE GLU_OUTSIDE) - (define (quadric-orientation q e) - (gluQuadricOrientation q (quadric-orientation-table e 'quadric-normals))) - - (make-enum-table quadric-draw-style-table - GLU_POINT GLU_LINE GLU_SILHOUETTE GLU_FILL) - (define (quadric-draw-style q e) - (gluQuadricDrawStyle q (quadric-draw-style-table e 'quadric-draw-style))) - - ;; 6.4 - (_provide (rename gluCylinder cylinder) - (rename gluDisk disk) - (rename gluSphere sphere) - (rename gluPartialDisk partial-disk)) - - ;; 7 not implemented - - ;; 8 - (_provide ;error-string - ) - - ;; Utils - - (_provide process-selection (struct selection-record (min-z max-z stack))) - ;; A selection-record is - ;; (make-selection-record number number (listof positive-int)) - (define-struct selection-record (min-z max-z stack)) +;; 3.6.1 +(_provide pixel-store) +(make-enum-table pixel-store-table + GL_UNPACK_SWAP_BYTES GL_UNPACK_LSB_FIRST + GL_UNPACK_ROW_LENGTH GL_UNPACK_SKIP_ROWS + GL_UNPACK_SKIP_PIXELS GL_UNPACK_ALIGNMENT + GL_UNPACK_IMAGE_HEIGHT GL_UNPACK_SKIP_IMAGES) +(define (pixel-store pname param) + (let ([v (pixel-store-table pname 'pixel-store)]) + (unless (real? param) + (raise-type-error 'pixel-store "real number" 1 pname param)) + (if (exact-integer? param) + (glPixelStorei v param) + (glPixelStoref v param)))) - ;; process-selection : gl-uint-vector int -> (listof selection-record) - (define (process-selection v hits) - (unless (gl-uint-vector? v) - (raise-type-error 'process-selection - "gl-uint-vector" - 0 v hits)) - (let ((index 0)) - (let loop ((hit 0)) - (cond - ((>= hit hits) null) - (else - (let ((stack-size (gl-vector-ref v index))) - (cons (make-selection-record - (gl-vector-ref v (add1 index)) - (gl-vector-ref v (+ index 2)) - (begin - (set! index (+ 3 index)) - (let loop ((j 0)) - (cond - ((< j stack-size) - (cons (gl-vector-ref v index) - (begin - (set! index (add1 index)) - (loop (add1 j))))) - (else null))))) - (loop (add1 hit))))))))) - - (provide get-gl-version-number get-glu-version-number) - (define (get-gl-version-number) - (let ((x (regexp-match "^([0-9]*)\\.([0-9*])" (get-string 'version)))) - (string->number (string-append (cadr x) (caddr x))))) - (define (get-glu-version-number) - (let ((x (regexp-match "^([0-9]*)\\.([0-9*])" (u-get-string 'version)))) - (string->number (string-append (cadr x) (caddr x))))) +;; 3.6.3, 3.6.4, 3.6.5, 3.7, 3.8, 3.10 not implemented - - - ) +;; 4.1.2 +(_provide (rename glScissor scissor)) + +;; 4.1.3 +(_provide (rename glSampleCoverage sample-coverage)) + +;; 4.1.4 +(_provide alpha-func) +(make-enum-table func-table + GL_NEVER GL_ALWAYS GL_LESS GL_LEQUAL GL_EQUAL + GL_GEQUAL GL_GREATER GL_NOTEQUAL) +(define (alpha-func func ref) + (glAlphaFunc (func-table func 'alpha-func) ref)) + +;; 4.1.5 +(_provide stencil-func stencil-op) +(define (stencil-func func ref mask) + (glStencilFunc (func-table func 'stencil-func) ref mask)) + +(make-enum-table stencil-op-table + GL_KEEP GL_ZERO GL_REPLACE GL_INCR GL_DECR GL_INVERT + GL_INCR_WRAP GL_DECR_WRAP) +(define (stencil-op sfail dpfail dppass) + (glStencilOp (stencil-op-table sfail 'stencil-op) + (stencil-op-table dpfail 'stencil-op) + (stencil-op-table dppass 'stencil-op))) + +;; 4.1.6 +(_provide depth-func) +(define (depth-func func) + (glDepthFunc (func-table func 'depth-func))) + +;; 4.1.7 +(_provide begin-query end-query + (rename glGenQueries gen-queries) + (rename glDeleteQueries delete-queries)) +(make-enum-table query-table GL_SAMPLES_PASSED) +(define (begin-query target id) + (glBeginQuery (query-table target 'begin-query) id)) +(define (end-query target) + (glEndQuery (query-table target 'end-query))) + + +;; 4.1.8 +(_provide blend-equation blend-func blend-func-separate + (rename glBlendColor blend-color)) + +(make-enum-table blend-equation-table + GL_FUNC_ADD GL_FUNC_SUBTRACT GL_FUNC_REVERSE_SUBTRACT + GL_MIN GL_MAX) +(define (blend-equation func) + (glBlendEquation (blend-equation-table func 'blend-equation))) + +(make-enum-table blend-func-table + GL_ZERO GL_ONE + GL_SRC_COLOR GL_ONE_MINUS_SRC_COLOR + GL_DST_COLOR GL_ONE_MINUS_DST_COLOR + GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA + GL_DST_ALPHA GL_ONE_MINUS_DST_ALPHA + GL_CONSTANT_COLOR GL_ONE_MINUS_CONSTANT_COLOR + GL_CONSTANT_ALPHA GL_ONE_MINUS_CONSTANT_ALPHA + GL_SRC_ALPHA_SATURATE) +(define (blend-func src dest) + (glBlendFunc (blend-func-table src 'blend-func) + (blend-func-table dest 'blend-func))) + +(define (blend-func-separate src dest src-alpha dst-alpha) + (glBlendFuncSeparate (blend-func-table src 'blend-func) + (blend-func-table dest 'blend-func) + (blend-func-table src-alpha 'blend-func) + (blend-func-table dst-alpha 'blend-func))) + +;; 4.1.10 +(provide logic-op) +(make-enum-table logic-op-table + GL_CLEAR GL_AND GL_AND_REVERSE GL_COPY GL_AND_INVERTED + GL_NOOP GL_XOR GL_OR GL_NOR GL_EQUIV GL_INVERT GL_OR_REVERSE + GL_COPY_INVERTED GL_OR_INVERTED GL_NAND GL_SET) +(define (logic-op op) + (glLogicOp logic-op-table op 'logic-op)) + +;; 4.2.1 +(provide draw-buffer) +(make-enum-table draw-buffer-table + GL_NONE GL_FRONT_LEFT GL_FRONT_RIGHT GL_BACK_LEFT + GL_BACK_RIGHT GL_FRONT GL_BACK GL_LEFT GL_RIGHT + GL_FRONT_AND_BACK + GL_AUX0 GL_AUX1 GL_AUX2 GL_AUX3) +(define (draw-buffer buf) + (glDrawBuffer (draw-buffer-table buf 'draw-buffer))) + +;; 4.2.2 +(_provide (rename glIndexMask index-mask) + (rename glColorMask color-mask) + (rename glDepthMask depth-mask) + (rename glStencilMask stencil-mask)) + +;; 4.2.3 +(_provide clear + (rename glClearColor clear-color) + (rename glClearIndex clear-index) + (rename glClearDepth clear-depth) + (rename glClearStencil clear-stencil) + (rename glClearAccum clear-accum)) +(make-enum-table clear-table + GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT + GL_DEPTH_BUFFER_BIT GL_STENCIL_BUFFER_BIT) +(define (clear . x) + (glClear (apply bitwise-ior (map (lambda (x) (clear-table x 'clear)) x)))) + +;; 4.2.4 +(_provide accum) +(make-enum-table accum-table + GL_ACCUM GL_MULT GL_RETURN GL_MULT GL_ADD) +(define (accum op value) + (glAccum (accum-table op 'accum) value)) + +;; 4.3.2 not implemented + +;; 4.3.3 +(_provide copy-pixels) +(make-enum-table copy-pixels-table + GL_COLOR GL_STENCIL GL_DEPTH) +(define (copy-pixels a b c d e) + (glCopyPixels a b c d (copy-pixels-table e 'copy-pixels))) + +;; 5.1 +(_provide ;map1 map2 + eval-coord eval-coord-v map-grid eval-mesh eval-point) +(multi-arg eval-coord glEvalCoord () (1 2)) +(multi-type-v eval-coord-v glEvalCoord () (1 2) (dv fv) #t) +(define map-grid + (case-lambda + [(n a b) (glMapGrid1d n a b)] + [(m a b n c d) (glMapGrid2d m a b n c d)])) +(make-enum-table eval-mesh-table GL_POINT GL_LINE) +(define eval-mesh + (case-lambda + [(e a b) (glEvalMesh1 (eval-mesh-table e 'eval-mesh) a b)] + [(e a b c d) (glEvalMesh2 (eval-mesh-table e 'eval-mesh) a b c d)])) +(define eval-point + (case-lambda + [(x) (glEvalPoint1 x)] + [(x y) (glEvalPoint2 x y)])) + +;; 5.2 +(_provide (rename glInitNames init-names) + (rename glPopName pop-name) + (rename glPushName push-name) + (rename glLoadName load-name) + render-mode + select-buffer->gl-uint-vector) +(make-enum-table render-mode-table GL_RENDER GL_SELECT GL_FEEDBACK) +(define (render-mode x) + (glRenderMode (render-mode-table x 'render-mode))) + +;; 5.3 +(_provide feedback-buffer->gl-float-vector + (rename glPassThrough pass-through)) + +;; 5.4 +(_provide new-list + (rename glEndList end-list) + (rename glCallList call-list) + ;; call-lists + (rename glListBase list-base) + (rename glGenLists gen-lists) + (rename glIsList is-list) + (rename glDeleteLists delete-lists)) +(make-enum-table new-list-table GL_COMPILE GL_COMPILE_AND_EXECUTE) +(define (new-list n mode) + (glNewList n (new-list-table mode 'new-list))) + +;; 5.5 +(_provide (rename glFlush flush) + (rename glFinish finish)) + +;; 5.6 +(_provide hint) +(make-enum-table hint-target-table + GL_PERSPECTIVE_CORRECTION_HINT GL_POINT_SMOOTH_HINT + GL_LINE_SMOOTH_HINT GL_POLYGON_SMOOTH_HINT GL_FOG_HINT + GL_GENERATE_MIPMAP_HINT GL_TEXTURE_COMPRESSION_HINT) +(make-enum-table hint-hint-table GL_FASTEST GL_NICEST GL_DONT_CARE) +(define (hint target hint) + (glHint (hint-target-table target 'hint) + (hint-hint-table hint 'hint))) + +;; 6.1.1 +(_provide ;glGetBooleanv glGetIntegerv glGetFloatv glGetDoublev + is-enabled) +(define (is-enabled e) + (glIsEnabled (enable-table e 'is-enabled))) + +;; 6.1.3, 6.1.4, 6.1.5, 6.1.7, 6.1.8, 6.1.9, 6.1.10 not implemented + +;; 6.1.11 +(_provide ;get-pointer-v + get-string) + +(make-enum-table get-string-table + GL_VENDOR GL_RENDERER GL_VERSION GL_EXTENSIONS) +(define (get-string x) + (glGetString (get-string-table x 'get-string))) + +;; 6.1.12 +(_provide (rename glIsQuery is-query) + ;; get-query get-query-object + ) + +;; 6.1.13 +(_provide (rename glIsBuffer is-buffer) + ;; get-buffer-sub-data get-buffer-pointer-v + ) + +;; 6.1.14 +(_provide push-attrib push-client-attrib + (rename glPopAttrib pop-attrib) + (rename glPopClientAttrib pop-client-attrib)) +(make-enum-table push-attrib-table + GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT GL_CURRENT_BIT + GL_DEPTH_BUFFER_BIT GL_ENABLE_BIT GL_EVAL_BIT GL_FOG_BIT GL_HINT_BIT + GL_LIGHTING_BIT GL_LINE_BIT GL_LIST_BIT GL_MULTISAMPLE_BIT + GL_PIXEL_MODE_BIT GL_POINT_BIT GL_POLYGON_BIT GL_POLYGON_STIPPLE_BIT + GL_SCISSOR_BIT GL_STENCIL_BUFFER_BIT GL_TEXTURE_BIT + GL_TRANSFORM_BIT GL_VIEWPORT_BIT GL_ALL_ATTRIB_BITS) +(define (push-attrib . x) + (glPushAttrib + (apply bitwise-ior (map (lambda (x) (push-attrib-table x 'clear)) x)))) +(make-enum-table push-client-attrib-table + GL_CLIENT_VERTEX_ARRAY_BIT + GL_CLIENT_PIXEL_STORE_BIT + GL_CLIENT_ALL_ATTRIB_BITS) +(define (push-client-attrib . x) + (glPushClientAttrib + (apply bitwise-ior + (map (lambda (x) (push-client-attrib-table x 'clear)) x)))) + +;; 2 +(_provide u-get-string + (rename gluCheckExtension check-extension)) +(make-enum-table u-get-string-table GLU_VERSION GLU_EXTENSIONS) +(define (u-get-string x) + (gluGetString (u-get-string-table x 'u-get-string))) + +;; 3 not implemented + +;; 4.1 +(_provide (rename gluOrtho2D ortho-2d) + (rename gluPerspective perspective) + (rename gluLookAt look-at) + pick-matrix) +(define (pick-matrix a b c d v) + (unless (gl-int-vector? v) + (raise-type-error 'pick-matrix + "gl-int-vector" + 4 a b c d v)) + (check-length 'pick-matrix v 4) + (gluPickMatrix a b c d v)) + +;; 4.2 +(_provide project un-project un-project4) +(define (project a b c d e f) + (unless (gl-double-vector? d) + (raise-type-error 'project "gl-double-vector" 3 a b c d e f)) + (unless (gl-double-vector? e) + (raise-type-error 'project "gl-double-vector" 4 a b c d e f)) + (unless (gl-int-vector? f) + (raise-type-error 'project "gl-double-vector" 5 a b c d e f)) + (check-length 'project d 16) + (check-length 'project e 16) + (check-length 'project f 4) + (gluProject a b c d e f)) + +(define (un-project a b c d e f) + (unless (gl-double-vector? d) + (raise-type-error 'un-project "gl-double-vector" 3 a b c d e f)) + (unless (gl-double-vector? e) + (raise-type-error 'un-project "gl-double-vector" 4 a b c d e f)) + (unless (gl-int-vector? f) + (raise-type-error 'un-project "gl-double-vector" 5 a b c d e f)) + (check-length 'un-project d 16) + (check-length 'un-project e 16) + (check-length 'un-project f 4) + (gluUnProject a b c d e f)) + +(define (un-project4 a b c d e f g h i) + (unless (gl-double-vector? e) + (raise-type-error 'un-project "gl-double-vector" 4 a b c d e f g h i)) + (unless (gl-double-vector? f) + (raise-type-error 'un-project "gl-double-vector" 5 a b c d e f g h i)) + (unless (gl-int-vector? g) + (raise-type-error 'un-project "gl-double-vector" 6 a b c d e f g h i)) + (check-length 'un-project4 e 16) + (check-length 'un-project4 f 16) + (check-length 'un-project4 g 4) + (gluUnProject4 a b c d e f g h i)) + +;; 5 not implemented + +;; 6.1 +(_provide (rename gluNewQuadric new-quadric)) + +;; 6.2 not implemented + +;; 6.3 +(_provide quadric-normals + (rename gluQuadricTexture quadric-texture) + quadric-orientation quadric-draw-style) + +(make-enum-table quadric-normals-table GLU_NONE GLU_FLAT GLU_SMOOTH) +(define (quadric-normals q e) + (gluQuadricNormals q (quadric-normals-table e 'quadric-normals))) + +(make-enum-table quadric-orientation-table GLU_INSIDE GLU_OUTSIDE) +(define (quadric-orientation q e) + (gluQuadricOrientation q (quadric-orientation-table e 'quadric-normals))) + +(make-enum-table quadric-draw-style-table + GLU_POINT GLU_LINE GLU_SILHOUETTE GLU_FILL) +(define (quadric-draw-style q e) + (gluQuadricDrawStyle q (quadric-draw-style-table e 'quadric-draw-style))) + +;; 6.4 +(_provide (rename gluCylinder cylinder) + (rename gluDisk disk) + (rename gluSphere sphere) + (rename gluPartialDisk partial-disk)) + +;; 7 not implemented + +;; 8 +(_provide ;error-string + ) + +;; Utils + +(_provide process-selection (struct selection-record (min-z max-z stack))) +;; A selection-record is +;; (make-selection-record number number (listof positive-int)) +(define-struct selection-record (min-z max-z stack)) + +;; process-selection : gl-uint-vector int -> (listof selection-record) +(define (process-selection v hits) + (unless (gl-uint-vector? v) + (raise-type-error 'process-selection "gl-uint-vector" 0 v hits)) + (let ([index 0]) + (let loop ([hit 0]) + (if (>= hit hits) + null + (let ([stack-size (gl-vector-ref v index)]) + (cons (make-selection-record + (gl-vector-ref v (add1 index)) + (gl-vector-ref v (+ index 2)) + (begin (set! index (+ 3 index)) + (let loop ([j 0]) + (if (< j stack-size) + (cons (gl-vector-ref v index) + (begin (set! index (add1 index)) + (loop (add1 j)))) + null)))) + (loop (add1 hit)))))))) + +(provide get-gl-version-number get-glu-version-number) +(define (get-gl-version-number) + (let ([x (regexp-match "^([0-9]*)\\.([0-9*])" (get-string 'version))]) + (string->number (string-append (cadr x) (caddr x))))) +(define (get-glu-version-number) + (let ([x (regexp-match "^([0-9]*)\\.([0-9*])" (u-get-string 'version))]) + (string->number (string-append (cadr x) (caddr x)))))