1;; sgl -- An OpenGL extension of Racket 2;; 3;; Copyright (C) 2007-2014 PLT Design Inc. 4;; Copyright (C) 2003-2007 Scott Owens <sowens@cs.utah.edu> 5;; 6;; This library is free software; you can redistribute it and/or 7;; modify it under the terms of the GNU Lesser General Public License 8;; as published by the Free Software Foundation; either version 2.1 of 9;; the License, or (at your option) any later version. 10;; 11;; This library is distributed in the hope that it will be useful, but 12;; WITHOUT ANY WARRANTY; without even the implied warranty of 13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14;; Lesser General Public License for more details. 15 16#lang mzscheme 17 18(require mzlib/etc 19 "gl-vectors.rkt" 20 "gl.rkt") 21 22(define-syntax (_provide stx) 23 (syntax-case stx () 24 [(_ x ...) 25 (begin 26 #; 27 (for-each 28 (lambda (x) 29 (syntax-case x (rename) 30 [(rename _ n) 31 (display (syntax-object->datum #'n))] 32 [_ (display (syntax-object->datum x))]) 33 (newline)) 34 (syntax->list #'(x ...))) 35 #'(provide x ...))])) 36 37(define (combine-syms strs) 38 (string-append "(or/c" 39 (apply 40 string-append 41 (map (lambda (s) 42 (format " '~s" s)) 43 strs)) 44 ")")) 45 46(define-syntax-set (multi-arg multi-type-v) 47 48 (define (iota n) 49 (if (= 0 n) null (cons n (iota (sub1 n))))) 50 51 (define (get-possible-types-v ts) 52 (combine-str 53 (map (lambda (t) 54 (case t 55 [(iv) "gl-int-vector?"] 56 [(sv) "gl-short-vector?"] 57 [(bv) "gl-byte-vector?"] 58 [(uiv) "gl-uint-vector?"] 59 [(usv) "gl-ushort-vector?"] 60 [(ubv) "gl-ubyte-vector?"] 61 [(dv) "gl-double-vector?"] 62 [(fv) "gl-float-vector?"] 63 [else (error (format "~a?" t))])) 64 ts))) 65 66 (define (combine-str strs) 67 (string-append "(or/c" 68 (apply 69 string-append 70 (map (lambda (s) 71 (string-append " " s)) 72 strs)) 73 ")")) 74 75 (define (multi-arg/proc stx) 76 (syntax-case stx () 77 [(_ name gl-name ((pre-arg-name pre-arg) ...) (num-arg ...)) 78 (let ([build-clause 79 (lambda (num-arg) 80 (with-syntax ([(arg ...) 81 (generate-temporaries (iota num-arg))] 82 [gl-name 83 (datum->syntax-object 84 #'gl-name 85 (string->symbol 86 (format "~a~ad" 87 (syntax-object->datum #'gl-name) 88 num-arg)) 89 #'gl-name 90 #'gl-name)]) 91 #`((pre-arg-name ... arg ...) 92 (if (and (real? arg) ...) 93 (gl-name pre-arg ... arg ...) 94 (raise-argument-error 95 'name "(listof real?)" (list arg ...))))))]) 96 (with-syntax ([(clauses ...) 97 (map build-clause 98 (syntax-object->datum #'(num-arg ...)))]) 99 #`(define name 100 (case-lambda clauses ...))))])) 101 102 (define (multi-type-v/proc stx) 103 (syntax-case stx () 104 [(_ name gl-name ((pre-arg-name pre-arg ) ...) 105 (length ...) (type ...) num? ) 106 (with-syntax ([arg (car (generate-temporaries (list #'name)))]) 107 (let* ([num? (syntax-object->datum #'num?)] 108 [lengths (syntax-object->datum #'(length ...))] 109 [build-clause 110 (lambda (type) 111 (with-syntax ([pred? 112 (case type 113 [(dv) #'gl-double-vector?] 114 [(fv) #'gl-float-vector?] 115 [(iv) #'gl-int-vector?] 116 [(sv) #'gl-short-vector?] 117 [(bv) #'gl-byte-vector?] 118 [(uiv) #'gl-uint-vector?] 119 [(usv) #'gl-ushort-vector?] 120 [(ubv) #'gl-ubyte-vector?])] 121 [(clause ...) 122 (map 123 (lambda (length) 124 (with-syntax ([name 125 (datum->syntax-object 126 #'gl-name 127 (string->symbol 128 (format "~a~a~a" 129 (syntax-object->datum #'gl-name) 130 (if num? length "") 131 type)) 132 #'gl-name 133 #'gl-name)]) 134 #`((#,length) (name pre-arg ... arg)))) 135 lengths)]) 136 #`((pred? arg) 137 (case (gl-vector-length arg) 138 clause ... 139 [else (error 140 'name 141 "expects vector with length in ~a: given vector has length ~a" 142 '(length ...) 143 (gl-vector-length arg))]))))] 144 [types (syntax-object->datum #'(type ...))]) 145 (with-syntax ([(clause ...) (map build-clause types)]) 146 #`(define (name pre-arg-name ... arg) 147 (cond 148 clause ... 149 [else 150 (raise-argument-error 'name 151 #,(get-possible-types-v types) 152 arg)])))))]))) 153 154(define-for-syntax (translate-cname name) 155 (let* ([r (symbol->string name)] 156 [r (regexp-replace* #rx"_" r "-")] 157 [r (regexp-replace #rx"^GLU?-" r "")] 158 [r (string-downcase r)]) 159 (string->symbol r))) 160 161(define-syntax (make-enum-table stx) 162 (syntax-case stx () 163 [(_ name const ...) 164 (with-syntax ([(sym ...) 165 (map translate-cname 166 (syntax-object->datum #'(const ...)))]) 167 (if (< (length (syntax->list #'(const ...))) 8) 168 (quasisyntax/loc stx 169 (define name 170 (let ([l `((sym . ,const) ...)]) 171 (lambda (enum-sym name) 172 (let ([v (assq enum-sym l)]) 173 (unless v 174 (raise-argument-error name 175 (combine-syms '(sym ...)) 176 enum-sym)) 177 (cdr v)))))) 178 (quasisyntax/loc stx 179 (define name 180 (let ([ht (make-hash-table)]) 181 (for-each (lambda (key value) 182 (hash-table-put! ht key value)) 183 '(sym ...) (list const ...)) 184 (lambda (enum-sym name) 185 (let ([v (hash-table-get ht enum-sym (lambda () #f))]) 186 (unless v 187 (raise-argument-error name 188 (combine-syms '(sym ...)) 189 enum-sym)) 190 v)))))))])) 191 192(define-syntax (make-inv-enum-table stx) 193 (syntax-case stx () 194 [(_ name const ...) 195 (with-syntax ([(sym ...) 196 (map translate-cname 197 (syntax-object->datum #'(const ...)))]) 198 (quasisyntax/loc stx 199 (define name 200 (let ([l `((,const . sym) ...)]) 201 (lambda (enum-val) 202 (cdr (assq enum-val l)))))))])) 203 204(define check-length 205 (case-lambda 206 [(name v desired-length sym) 207 (unless (= desired-length (gl-vector-length v)) 208 (error name "expects vector of length ~a for ~a: argument vector has length ~a" 209 desired-length sym (gl-vector-length v)))] 210 [(name v desired-length) 211 (unless (= desired-length (gl-vector-length v)) 212 (error name "expects vector of length ~a: argument vector has length ~a" 213 desired-length (gl-vector-length v)))])) 214 215;; 2.5 216(_provide get-error) 217(make-inv-enum-table get-error-table 218 GL_NO_ERROR 219 GL_INVALID_ENUM 220 GL_INVALID_VALUE 221 GL_INVALID_OPERATION 222 GL_STACK_OVERFLOW 223 GL_STACK_UNDERFLOW 224 GL_OUT_OF_MEMORY) 225(define (get-error) 226 (get-error-table (glGetError))) 227 228;; 2.6.1 229(_provide (rename gl-begin begin) (rename glEnd end)) 230(make-enum-table begin-table 231 GL_LINES 232 GL_LINE_LOOP 233 GL_LINE_STRIP 234 GL_POINTS 235 GL_POLYGON 236 GL_QUADS 237 GL_QUAD_STRIP 238 GL_TRIANGLES 239 GL_TRIANGLE_FAN 240 GL_TRIANGLE_STRIP) 241(define (gl-begin enum) 242 (glBegin (begin-table enum 'begin))) 243 244;; 2.6.2 245(_provide (rename glEdgeFlag edge-flag)) 246 247;; 2.7 248(_provide vertex vertex-v 249 tex-coord tex-coord-v 250 multi-tex-coord multi-tex-coord-v 251 (rename glNormal3d normal) normal-v 252 color color-v 253 (rename glSecondaryColor3d secondary-color) secondary-color-v 254 (rename glIndexd index) index-v) 255 256(multi-arg vertex glVertex () (2 3 4)) 257(multi-type-v vertex-v glVertex () (2 3 4) (dv iv fv sv) #t) 258(multi-arg tex-coord glTexCoord () (1 2 3 4)) 259(multi-type-v tex-coord-v glTexCoord () (1 2 3 4) (dv iv fv sv) #t) 260(make-enum-table multi-tex-coord-table 261 GL_TEXTURE0 GL_TEXTURE1 GL_TEXTURE2 GL_TEXTURE3 GL_TEXTURE4 262 GL_TEXTURE5 GL_TEXTURE6 GL_TEXTURE7 GL_TEXTURE8 GL_TEXTURE9 263 GL_TEXTURE10 GL_TEXTURE11 GL_TEXTURE12 GL_TEXTURE13 264 GL_TEXTURE14 GL_TEXTURE15 GL_TEXTURE16 GL_TEXTURE17 265 GL_TEXTURE18 GL_TEXTURE19 GL_TEXTURE20 GL_TEXTURE21 266 GL_TEXTURE22 GL_TEXTURE23 GL_TEXTURE24 GL_TEXTURE25 267 GL_TEXTURE26 GL_TEXTURE27 GL_TEXTURE28 GL_TEXTURE29 268 GL_TEXTURE30 GL_TEXTURE31) 269(multi-arg multi-tex-coord glMultiTexCoord 270 ((e (multi-tex-coord-table e 'multi-tex-coord))) 271 (1 2 3 4)) 272(multi-type-v multi-tex-coord-v glMultiTexCoord 273 ((e (multi-tex-coord-table e 'multi-tex-coord))) 274 (1 2 3 4) 275 (sv iv fv dv) 276 #t) 277(multi-type-v normal-v glNormal () (3) (dv iv fv sv bv) #t) 278(multi-arg color glColor () (3 4)) 279(multi-type-v color-v glColor () (3 4) (dv iv uiv fv ubv bv usv sv) #t) 280(multi-type-v secondary-color-v glSecondaryColor () (3) (bv sv iv fv dv ubv usv uiv) #t) 281(multi-type-v index-v glIndex () (1) (dv iv fv sv ubv) #f) 282 283;; 2.8, 2.9 not implemented 284 285;; 2.10 286(_provide (rename glRectd rect) rect-v) 287(multi-type-v rect-v glRect () (4) (dv iv fv sv) #f) 288 289;; 2.11.1 290(_provide (rename glDepthRange depth-range) (rename glViewport viewport)) 291 292;; 2.11.2 293(_provide matrix-mode load-matrix mult-matrix 294 load-transpose-matrix mult-transpose-matrix 295 (rename glLoadIdentity load-identity) 296 (rename glRotated rotate) 297 (rename glTranslated translate) 298 (rename glScaled scale) 299 (rename glFrustum frustum) 300 (rename glOrtho ortho) 301 active-texture 302 (rename glPushMatrix push-matrix) 303 (rename glPopMatrix pop-matrix)) 304 305(make-enum-table matrix-mode-table 306 GL_MODELVIEW GL_PROJECTION GL_TEXTURE GL_COLOR) 307(define (matrix-mode x) 308 (glMatrixMode (matrix-mode-table x 'matrix-mode))) 309(define-values (glLoadMatrixfv glLoadMatrixdv glMultMatrixfv glMultMatrixdv 310 glLoadTransposeMatrixfv glLoadTransposeMatrixdv 311 glMultTransposeMatrixfv glMultTransposeMatrixdv) 312 (values glLoadMatrixf glLoadMatrixd glMultMatrixf glMultMatrixd 313 glLoadTransposeMatrixf glLoadTransposeMatrixd 314 glMultTransposeMatrixf glMultTransposeMatrixd)) 315(multi-type-v load-matrix glLoadMatrix () (16) (fv dv) #f) 316(multi-type-v mult-matrix glMultMatrix () (16) (fv dv) #f) 317(multi-type-v load-transpose-matrix glLoadTransposeMatrix () (16) (fv dv) #f) 318(multi-type-v mult-transpose-matrix glMultTransposeMatrix () (16) (fv dv) #f) 319 320(define (active-texture texture) 321 (glActiveTexture (multi-tex-coord-table texture 'active-texture texture))) 322 323;; 2.11.3 324(_provide enable disable) 325(make-enum-table enable-table 326 GL_VERTEX_ARRAY GL_NORMAL_ARRAY GL_FOG_COORD_ARRAY 327 GL_COLOR_ARRAY GL_SECONDARY_COLOR_ARRAY GL_INDEX_ARRAY 328 GL_TEXTURE_COORD_ARRAY GL_EDGE_FLAG_ARRAY 329 GL_NORMALIZE GL_RESCALE_NORMAL 330 GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 GL_CLIP_PLANE3 331 GL_CLIP_PLANE4 GL_CLIP_PLANE5 332 GL_FOG GL_COLOR_SUM 333 GL_LIGHTING GL_COLOR_MATERIAL 334 GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 GL_LIGHT4 335 GL_LIGHT5 GL_LIGHT6 GL_LIGHT7 336 GL_POINT_SMOOTH GL_LINE_SMOOTH GL_LINE_STIPPLE GL_CULL_FACE 337 GL_POLYGON_SMOOTH GL_POLYGON_OFFSET_POINT 338 GL_POLYGON_OFFSET_LINE GL_POLYGON_OFFSET_FILL 339 GL_POLYGON_STIPPLE 340 GL_MULTISAMPLE GL_SAMPLE_ALPHA_TO_COVERAGE 341 GL_SAMPLE_ALPHA_TO_ONE GL_SAMPLE_COVERAGE 342 GL_TEXTURE_1D GL_TEXTURE_2D GL_TEXTURE_3D 343 GL_TEXTURE_CUBE_MAP 344 GL_TEXTURE_GEN_S GL_TEXTURE_GEN_T 345 GL_TEXTURE_GEN_R GL_TEXTURE_GEN_Q 346 GL_SCISSOR_TEST GL_ALPHA_TEST GL_STENCIL_TEST 347 GL_DEPTH_TEST GL_BLEND GL_DITHER 348 GL_INDEX_LOGIC_OP GL_LOGIC_OP GL_COLOR_LOGIC_OP 349 GL_COLOR_TABLE GL_POST_CONVOLUTION_COLOR_TABLE 350 GL_POST_COLOR_MATRIX_COLOR_TABLE 351 GL_CONVOLUTION_1D GL_CONVOLUTION_2D GL_SEPARABLE_2D 352 GL_HISTOGRAM GL_MINMAX 353 GL_MAP1_VERTEX_3 GL_MAP1_VERTEX_4 GL_MAP1_INDEX 354 GL_MAP1_COLOR_4 GL_MAP1_NORMAL 355 GL_MAP1_TEXTURE_COORD_1 GL_MAP1_TEXTURE_COORD_2 356 GL_MAP1_TEXTURE_COORD_3 GL_MAP1_TEXTURE_COORD_4 357 GL_MAP2_VERTEX_3 GL_MAP2_VERTEX_4 GL_MAP2_INDEX 358 GL_MAP2_COLOR_4 GL_MAP2_NORMAL 359 GL_MAP2_TEXTURE_COORD_1 GL_MAP2_TEXTURE_COORD_2 360 GL_MAP2_TEXTURE_COORD_3 GL_MAP2_TEXTURE_COORD_4 361 GL_AUTO_NORMAL) 362(define (enable x) 363 (glEnable (enable-table x 'enable))) 364(define (disable x) 365 (glDisable (enable-table x 'disable))) 366 367;; 2.11.4 368(_provide tex-gen tex-gen-v) 369(make-enum-table tex-gen-coord-table GL_S GL_T GL_R GL_Q) 370(make-enum-table tex-gen-pname-table 371 GL_TEXTURE_GEN_MODE GL_OBJECT_PLANE GL_EYE_PLANE) 372(make-enum-table tex-gen-param-table 373 GL_OBJECT_LINEAR GL_EYE_LINEAR GL_SPHERE_MAP 374 GL_REFLECTION_MAP GL_NORMAL_MAP) 375(define (tex-gen c p n) 376 (let ([cv (tex-gen-coord-table c 'tex-gen)] 377 [pv (tex-gen-pname-table p 'tex-gen)]) 378 (unless (= pv GL_TEXTURE_GEN_MODE) 379 (error 'tex-gen "does not accept ~a, use tex-gen-v instead" p)) 380 (glTexGeni cv pv (tex-gen-param-table n 'tex-gen)))) 381(define (tex-gen-v c p v) 382 (let ([cv (tex-gen-coord-table c 'tex-gen-v)] 383 [pv (tex-gen-pname-table p 'tex-gen-v)]) 384 (when (= pv GL_TEXTURE_GEN_MODE) 385 (error 'tex-gen-v "does not accept ~a, use tex-gen instead" p)) 386 (let ([f (cond [(gl-int-vector? v) glTexGeniv] 387 [(gl-float-vector? v) glTexGenfv] 388 [(gl-double-vector? v) glTexGendv] 389 [else (raise-argument-error 390 'tex-gen-v 391 "(or/c gl-int-vector? gl-float-vector? gl-double-vector?)" 392 2 c p v)])]) 393 (check-length 'tex-gen-v v 4) 394 (f cv pv v)))) 395 396;; 2.12 397(_provide clip-plane) 398(make-enum-table clip-plane-table 399 GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 400 GL_CLIP_PLANE3 GL_CLIP_PLANE4 GL_CLIP_PLANE5) 401(define (clip-plane p eqn) 402 (let ([v (clip-plane-table p 'clip-plane)]) 403 (unless (gl-double-vector? eqn) 404 (raise-argument-error 'clip-plane "gl-double-vector?" 1 p eqn)) 405 (check-length 'clip-plane eqn 4) 406 (glClipPlane v eqn))) 407 408;; 2.13 409(_provide raster-pos raster-pos-v 410 window-pos window-pos-v) 411(multi-arg raster-pos glRasterPos () (2 3 4)) 412(multi-type-v raster-pos-v glRasterPos () (2 3 4) (dv iv fv sv) #t) 413(multi-arg window-pos glWindowPos () (2 3)) 414(multi-type-v window-pos-v glWindowPos () (2 3) (dv iv fv sv) #t) 415 416;; 2.14.1 417(_provide front-face) 418(make-enum-table front-face-table GL_CCW GL_CW) 419(define (front-face x) 420 (glFrontFace (front-face-table x 'front-face))) 421 422;; 2.14.2 423(_provide material material-v light light-v light-model light-model-v) 424(make-enum-table face-table GL_FRONT GL_BACK GL_FRONT_AND_BACK) 425(make-enum-table material-pname-table 426 GL_AMBIENT GL_DIFFUSE GL_AMBIENT_AND_DIFFUSE 427 GL_SPECULAR GL_EMISSION GL_SHININESS GL_COLOR_INDEXES) 428 429(define (get-f v iv fv name a1 a2) 430 (cond [(gl-int-vector? v) iv] 431 [(gl-float-vector? v) fv] 432 [else (raise-argument-error name 433 "(or/c gl-int-vector? gl-float-vector?)" 434 2 a1 a2 v)])) 435(define (do-f n v0 v1 i f name a0 a1) 436 (unless (real? n) 437 (raise-argument-error name "real?" 2 a0 a1 n)) 438 (if (exact-integer? n) 439 (i v0 v1 n) 440 (f v0 v1 n))) 441 442(define (material face pname param) 443 (let ([v0 (face-table face 'material)] 444 [v1 (material-pname-table pname 'material)]) 445 (unless (= v1 GL_SHININESS) 446 (error 'material "does not accept ~a, use material-v instead" pname)) 447 (do-f param v0 v1 glMateriali glMaterialf 'material face pname))) 448 449(define (material-v face pname params) 450 (let ([v0 (face-table face 'material-v)] 451 [v1 (material-pname-table pname 'material-v)] 452 [f (get-f params glMaterialiv glMaterialfv 'material-v face pname)]) 453 (check-length 'material-v params 454 (cond [(= GL_SHININESS v1) 1] 455 [(= GL_COLOR_INDEXES v1) 3] 456 [else 4]) 457 pname) 458 (f v0 v1 params))) 459 460(make-enum-table light-light-table 461 GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 462 GL_LIGHT4 GL_LIGHT5 GL_LIGHT6 GL_LIGHT7) 463(make-enum-table light-pname-table 464 GL_AMBIENT GL_DIFFUSE GL_SPECULAR GL_POSITION 465 GL_SPOT_DIRECTION 466 GL_SPOT_EXPONENT GL_SPOT_CUTOFF 467 GL_CONSTANT_ATTENUATION GL_LINEAR_ATTENUATION 468 GL_QUADRATIC_ATTENUATION) 469(define (light light pname param) 470 (let ([v0 (light-light-table light 'light)] 471 [v1 (light-pname-table pname 'light)]) 472 (unless (memv v1 `(,GL_SPOT_EXPONENT ,GL_SPOT_CUTOFF 473 ,GL_CONSTANT_ATTENUATION ,GL_LINEAR_ATTENUATION 474 ,GL_QUADRATIC_ATTENUATION)) 475 (error 'light "does not accept ~a, use light-v instead" pname)) 476 (do-f param v0 v1 glLighti glLightf 'light light pname))) 477 478(define (light-v light pname params) 479 (let ([v0 (light-light-table light 'light-v)] 480 [v1 (light-pname-table pname 'light-v)] 481 [f (get-f params glLightiv glLightfv 'light-v light pname)]) 482 (check-length 483 'light-v params 484 (cond [(= GL_SPOT_DIRECTION v1) 3] 485 [(memv v1 `(,GL_AMBIENT ,GL_DIFFUSE ,GL_SPECULAR ,GL_POSITION)) 4] 486 [else 1]) 487 pname) 488 (f v0 v1 params))) 489 490(make-enum-table light-model-table 491 GL_LIGHT_MODEL_AMBIENT 492 GL_LIGHT_MODEL_COLOR_CONTROL 493 GL_LIGHT_MODEL_LOCAL_VIEWER 494 GL_LIGHT_MODEL_TWO_SIDE) 495 496(define (light-model pname param) 497 (let ([v (light-model-table pname 'light-model)]) 498 (when (= GL_LIGHT_MODEL_AMBIENT v) 499 (error 'light-model "does not accept ~a, use light-model-v instead" pname)) 500 (unless (real? param) 501 (raise-argument-error 'light-model "real?" 1 pname param)) 502 (if (exact-integer? param) 503 (glLightModeli v param) 504 (glLightModelf v param)))) 505 506(define (light-model-v pname params) 507 (let ([v (light-model-table pname 'light-model-v)] 508 [f (cond [(gl-int-vector? params) glLightModeliv] 509 [(gl-float-vector? params) glLightModelfv] 510 [else (raise-argument-error 'light-model-v 511 "(or/c gl-int-vector? gl-float-vector?)" 512 1 pname params)])]) 513 (check-length 'light-model-v params 514 (if (= GL_LIGHT_MODEL_AMBIENT v) 4 1) 515 pname) 516 (f v params))) 517 518;; 2.14.3 519(_provide color-material) 520(make-enum-table color-material-mode-table 521 GL_EMISSION GL_AMBIENT GL_DIFFUSE 522 GL_SPECULAR GL_AMBIENT_AND_DIFFUSE) 523(define (color-material x y) 524 (glColorMaterial (face-table x 'color-material) 525 (color-material-mode-table y 'color-material))) 526 527;; 2.14.7 528(_provide shade-model) 529(make-enum-table shade-model-table GL_FLAT GL_SMOOTH) 530(define (shade-model x) 531 (glShadeModel (shade-model-table x 'shade-model))) 532 533;; 3.3 534(_provide (rename glPointSize point-size) 535 point-parameter point-parameter-v) 536(make-enum-table point-parameter-table 537 GL_POINT_SIZE_MIN GL_POINT_SIZE_MAX 538 GL_POINT_DISTANCE_ATTENUATION 539 GL_POINT_FADE_THRESHOLD_SIZE) 540(define (point-parameter pname param) 541 (let ([v (point-parameter-table pname 'point-parameter)]) 542 (when (= GL_POINT_DISTANCE_ATTENUATION v) 543 (error 'point-parameter 544 "does not accept ~a, use point-parameter-v instead" pname)) 545 (unless (real? param) 546 (raise-argument-error 'point-parameter "real?" 1 pname param)) 547 (if (exact-integer? param) 548 (glPointParameteri v param) 549 (glPointParameterf v param)))) 550(define (point-parameter-v pname params) 551 (let ([v (point-parameter-table pname 'point-parameter)] 552 [f (cond [(gl-int-vector? params) glPointParameteriv] 553 [(gl-float-vector? params) glPointParameterfv] 554 [else (raise-argument-error 'point-parameter-v 555 "(or/c gl-int-vector? gl-float-vector?)" 556 1 pname params)])]) 557 (check-length 'point-parameter-v 558 (if (= GL_POINT_DISTANCE_ATTENUATION v) 3 1) 559 pname) 560 (f v params))) 561 562;; 3.4 563(_provide (rename glLineWidth line-width)) 564 565;; 3.4.2 566(_provide (rename glLineStipple line-stipple)) 567 568;; 3.5.1 569(_provide cull-face) 570(define (cull-face x) 571 (glCullFace (face-table x))) 572 573;; 3.5.2 574;; polygon-stipple 575 576;;3.5.4 577(_provide polygon-mode) 578(make-enum-table polygon-mode-mode-table GL_POINT GL_LINE GL_FILL) 579(define (polygon-mode x y) 580 (glPolygonMode (face-table x 'polygon-mode) 581 (polygon-mode-mode-table y 'polygon-mode))) 582 583;; 3.5.5 584(_provide (rename glPolygonOffset polygon-offset)) 585 586;; 3.6.1 587(_provide pixel-store) 588(make-enum-table pixel-store-table 589 GL_UNPACK_SWAP_BYTES GL_UNPACK_LSB_FIRST 590 GL_UNPACK_ROW_LENGTH GL_UNPACK_SKIP_ROWS 591 GL_UNPACK_SKIP_PIXELS GL_UNPACK_ALIGNMENT 592 GL_UNPACK_IMAGE_HEIGHT GL_UNPACK_SKIP_IMAGES) 593(define (pixel-store pname param) 594 (let ([v (pixel-store-table pname 'pixel-store)]) 595 (unless (real? param) 596 (raise-argument-error 'pixel-store "real?" 1 pname param)) 597 (if (exact-integer? param) 598 (glPixelStorei v param) 599 (glPixelStoref v param)))) 600 601;; 3.6.3, 3.6.4, 3.6.5, 3.7, 3.8, 3.10 not implemented 602 603;; 4.1.2 604(_provide (rename glScissor scissor)) 605 606;; 4.1.3 607(_provide (rename glSampleCoverage sample-coverage)) 608 609;; 4.1.4 610(_provide alpha-func) 611(make-enum-table func-table 612 GL_NEVER GL_ALWAYS GL_LESS GL_LEQUAL GL_EQUAL 613 GL_GEQUAL GL_GREATER GL_NOTEQUAL) 614(define (alpha-func func ref) 615 (glAlphaFunc (func-table func 'alpha-func) ref)) 616 617;; 4.1.5 618(_provide stencil-func stencil-op) 619(define (stencil-func func ref mask) 620 (glStencilFunc (func-table func 'stencil-func) ref mask)) 621 622(make-enum-table stencil-op-table 623 GL_KEEP GL_ZERO GL_REPLACE GL_INCR GL_DECR GL_INVERT 624 GL_INCR_WRAP GL_DECR_WRAP) 625(define (stencil-op sfail dpfail dppass) 626 (glStencilOp (stencil-op-table sfail 'stencil-op) 627 (stencil-op-table dpfail 'stencil-op) 628 (stencil-op-table dppass 'stencil-op))) 629 630;; 4.1.6 631(_provide depth-func) 632(define (depth-func func) 633 (glDepthFunc (func-table func 'depth-func))) 634 635;; 4.1.7 636(_provide begin-query end-query 637 (rename glGenQueries gen-queries) 638 (rename glDeleteQueries delete-queries)) 639(make-enum-table query-table GL_SAMPLES_PASSED) 640(define (begin-query target id) 641 (glBeginQuery (query-table target 'begin-query) id)) 642(define (end-query target) 643 (glEndQuery (query-table target 'end-query))) 644 645 646;; 4.1.8 647(_provide blend-equation blend-func blend-func-separate 648 (rename glBlendColor blend-color)) 649 650(make-enum-table blend-equation-table 651 GL_FUNC_ADD GL_FUNC_SUBTRACT GL_FUNC_REVERSE_SUBTRACT 652 GL_MIN GL_MAX) 653(define (blend-equation func) 654 (glBlendEquation (blend-equation-table func 'blend-equation))) 655 656(make-enum-table blend-func-table 657 GL_ZERO GL_ONE 658 GL_SRC_COLOR GL_ONE_MINUS_SRC_COLOR 659 GL_DST_COLOR GL_ONE_MINUS_DST_COLOR 660 GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA 661 GL_DST_ALPHA GL_ONE_MINUS_DST_ALPHA 662 GL_CONSTANT_COLOR GL_ONE_MINUS_CONSTANT_COLOR 663 GL_CONSTANT_ALPHA GL_ONE_MINUS_CONSTANT_ALPHA 664 GL_SRC_ALPHA_SATURATE) 665(define (blend-func src dest) 666 (glBlendFunc (blend-func-table src 'blend-func) 667 (blend-func-table dest 'blend-func))) 668 669(define (blend-func-separate src dest src-alpha dst-alpha) 670 (glBlendFuncSeparate (blend-func-table src 'blend-func) 671 (blend-func-table dest 'blend-func) 672 (blend-func-table src-alpha 'blend-func) 673 (blend-func-table dst-alpha 'blend-func))) 674 675;; 4.1.10 676(provide logic-op) 677(make-enum-table logic-op-table 678 GL_CLEAR GL_AND GL_AND_REVERSE GL_COPY GL_AND_INVERTED 679 GL_NOOP GL_XOR GL_OR GL_NOR GL_EQUIV GL_INVERT GL_OR_REVERSE 680 GL_COPY_INVERTED GL_OR_INVERTED GL_NAND GL_SET) 681(define (logic-op op) 682 (glLogicOp logic-op-table op 'logic-op)) 683 684;; 4.2.1 685(provide draw-buffer) 686(make-enum-table draw-buffer-table 687 GL_NONE GL_FRONT_LEFT GL_FRONT_RIGHT GL_BACK_LEFT 688 GL_BACK_RIGHT GL_FRONT GL_BACK GL_LEFT GL_RIGHT 689 GL_FRONT_AND_BACK 690 GL_AUX0 GL_AUX1 GL_AUX2 GL_AUX3) 691(define (draw-buffer buf) 692 (glDrawBuffer (draw-buffer-table buf 'draw-buffer))) 693 694;; 4.2.2 695(_provide (rename glIndexMask index-mask) 696 (rename glColorMask color-mask) 697 (rename glDepthMask depth-mask) 698 (rename glStencilMask stencil-mask)) 699 700;; 4.2.3 701(_provide clear 702 (rename glClearColor clear-color) 703 (rename glClearIndex clear-index) 704 (rename glClearDepth clear-depth) 705 (rename glClearStencil clear-stencil) 706 (rename glClearAccum clear-accum)) 707(make-enum-table clear-table 708 GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT 709 GL_DEPTH_BUFFER_BIT GL_STENCIL_BUFFER_BIT) 710(define (clear . x) 711 (glClear (apply bitwise-ior (map (lambda (x) (clear-table x 'clear)) x)))) 712 713;; 4.2.4 714(_provide accum) 715(make-enum-table accum-table 716 GL_ACCUM GL_MULT GL_RETURN GL_MULT GL_ADD) 717(define (accum op value) 718 (glAccum (accum-table op 'accum) value)) 719 720;; 4.3.2 not implemented 721 722;; 4.3.3 723(_provide copy-pixels) 724(make-enum-table copy-pixels-table 725 GL_COLOR GL_STENCIL GL_DEPTH) 726(define (copy-pixels a b c d e) 727 (glCopyPixels a b c d (copy-pixels-table e 'copy-pixels))) 728 729;; 5.1 730(_provide ;map1 map2 731 eval-coord eval-coord-v map-grid eval-mesh eval-point) 732(multi-arg eval-coord glEvalCoord () (1 2)) 733(multi-type-v eval-coord-v glEvalCoord () (1 2) (dv fv) #t) 734(define map-grid 735 (case-lambda 736 [(n a b) (glMapGrid1d n a b)] 737 [(m a b n c d) (glMapGrid2d m a b n c d)])) 738(make-enum-table eval-mesh-table GL_POINT GL_LINE) 739(define eval-mesh 740 (case-lambda 741 [(e a b) (glEvalMesh1 (eval-mesh-table e 'eval-mesh) a b)] 742 [(e a b c d) (glEvalMesh2 (eval-mesh-table e 'eval-mesh) a b c d)])) 743(define eval-point 744 (case-lambda 745 [(x) (glEvalPoint1 x)] 746 [(x y) (glEvalPoint2 x y)])) 747 748;; 5.2 749(_provide (rename glInitNames init-names) 750 (rename glPopName pop-name) 751 (rename glPushName push-name) 752 (rename glLoadName load-name) 753 render-mode 754 select-buffer->gl-uint-vector) 755(make-enum-table render-mode-table GL_RENDER GL_SELECT GL_FEEDBACK) 756(define (render-mode x) 757 (glRenderMode (render-mode-table x 'render-mode))) 758 759;; 5.3 760(_provide feedback-buffer->gl-float-vector 761 (rename glPassThrough pass-through)) 762 763;; 5.4 764(_provide new-list 765 (rename glEndList end-list) 766 (rename glCallList call-list) 767 ;; call-lists 768 (rename glListBase list-base) 769 (rename glGenLists gen-lists) 770 (rename glIsList is-list) 771 (rename glDeleteLists delete-lists)) 772(make-enum-table new-list-table GL_COMPILE GL_COMPILE_AND_EXECUTE) 773(define (new-list n mode) 774 (glNewList n (new-list-table mode 'new-list))) 775 776;; 5.5 777(_provide (rename glFlush flush) 778 (rename glFinish finish)) 779 780;; 5.6 781(_provide hint) 782(make-enum-table hint-target-table 783 GL_PERSPECTIVE_CORRECTION_HINT GL_POINT_SMOOTH_HINT 784 GL_LINE_SMOOTH_HINT GL_POLYGON_SMOOTH_HINT GL_FOG_HINT 785 GL_GENERATE_MIPMAP_HINT GL_TEXTURE_COMPRESSION_HINT) 786(make-enum-table hint-hint-table GL_FASTEST GL_NICEST GL_DONT_CARE) 787(define (hint target hint) 788 (glHint (hint-target-table target 'hint) 789 (hint-hint-table hint 'hint))) 790 791;; 6.1.1 792(_provide ;glGetBooleanv glGetIntegerv glGetFloatv glGetDoublev 793 is-enabled) 794(define (is-enabled e) 795 (glIsEnabled (enable-table e 'is-enabled))) 796 797;; 6.1.3, 6.1.4, 6.1.5, 6.1.7, 6.1.8, 6.1.9, 6.1.10 not implemented 798 799;; 6.1.11 800(_provide ;get-pointer-v 801 get-string) 802 803(make-enum-table get-string-table 804 GL_VENDOR GL_RENDERER GL_VERSION GL_EXTENSIONS) 805(define (get-string x) 806 (glGetString (get-string-table x 'get-string))) 807 808;; 6.1.12 809(_provide (rename glIsQuery is-query) 810 ;; get-query get-query-object 811 ) 812 813;; 6.1.13 814(_provide (rename glIsBuffer is-buffer) 815 ;; get-buffer-sub-data get-buffer-pointer-v 816 ) 817 818;; 6.1.14 819(_provide push-attrib push-client-attrib 820 (rename glPopAttrib pop-attrib) 821 (rename glPopClientAttrib pop-client-attrib)) 822(make-enum-table push-attrib-table 823 GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT GL_CURRENT_BIT 824 GL_DEPTH_BUFFER_BIT GL_ENABLE_BIT GL_EVAL_BIT GL_FOG_BIT GL_HINT_BIT 825 GL_LIGHTING_BIT GL_LINE_BIT GL_LIST_BIT GL_MULTISAMPLE_BIT 826 GL_PIXEL_MODE_BIT GL_POINT_BIT GL_POLYGON_BIT GL_POLYGON_STIPPLE_BIT 827 GL_SCISSOR_BIT GL_STENCIL_BUFFER_BIT GL_TEXTURE_BIT 828 GL_TRANSFORM_BIT GL_VIEWPORT_BIT GL_ALL_ATTRIB_BITS) 829(define (push-attrib . x) 830 (glPushAttrib 831 (apply bitwise-ior (map (lambda (x) (push-attrib-table x 'clear)) x)))) 832(make-enum-table push-client-attrib-table 833 GL_CLIENT_VERTEX_ARRAY_BIT 834 GL_CLIENT_PIXEL_STORE_BIT 835 GL_CLIENT_ALL_ATTRIB_BITS) 836(define (push-client-attrib . x) 837 (glPushClientAttrib 838 (apply bitwise-ior 839 (map (lambda (x) (push-client-attrib-table x 'clear)) x)))) 840 841;; 2 842(_provide u-get-string 843 (rename gluCheckExtension check-extension)) 844(make-enum-table u-get-string-table GLU_VERSION GLU_EXTENSIONS) 845(define (u-get-string x) 846 (gluGetString (u-get-string-table x 'u-get-string))) 847 848;; 3 not implemented 849 850;; 4.1 851(_provide (rename gluOrtho2D ortho-2d) 852 (rename gluPerspective perspective) 853 (rename gluLookAt look-at) 854 pick-matrix) 855(define (pick-matrix a b c d v) 856 (unless (gl-int-vector? v) 857 (raise-argument-error 'pick-matrix 858 "gl-int-vector?" 859 4 a b c d v)) 860 (check-length 'pick-matrix v 4) 861 (gluPickMatrix a b c d v)) 862 863;; 4.2 864(_provide project un-project un-project4) 865(define (project a b c d e f) 866 (unless (gl-double-vector? d) 867 (raise-argument-error 'project "gl-double-vector?" 3 a b c d e f)) 868 (unless (gl-double-vector? e) 869 (raise-argument-error 'project "gl-double-vector?" 4 a b c d e f)) 870 (unless (gl-int-vector? f) 871 (raise-argument-error 'project "gl-double-vector?" 5 a b c d e f)) 872 (check-length 'project d 16) 873 (check-length 'project e 16) 874 (check-length 'project f 4) 875 (gluProject a b c d e f)) 876 877(define (un-project a b c d e f) 878 (unless (gl-double-vector? d) 879 (raise-argument-error 'un-project "gl-double-vector?" 3 a b c d e f)) 880 (unless (gl-double-vector? e) 881 (raise-argument-error 'un-project "gl-double-vector?" 4 a b c d e f)) 882 (unless (gl-int-vector? f) 883 (raise-argument-error 'un-project "gl-double-vector?" 5 a b c d e f)) 884 (check-length 'un-project d 16) 885 (check-length 'un-project e 16) 886 (check-length 'un-project f 4) 887 (gluUnProject a b c d e f)) 888 889(define (un-project4 a b c d e f g h i) 890 (unless (gl-double-vector? e) 891 (raise-argument-error 'un-project "gl-double-vector?" 4 a b c d e f g h i)) 892 (unless (gl-double-vector? f) 893 (raise-argument-error 'un-project "gl-double-vector?" 5 a b c d e f g h i)) 894 (unless (gl-int-vector? g) 895 (raise-argument-error 'un-project "gl-double-vector?" 6 a b c d e f g h i)) 896 (check-length 'un-project4 e 16) 897 (check-length 'un-project4 f 16) 898 (check-length 'un-project4 g 4) 899 (gluUnProject4 a b c d e f g h i)) 900 901;; 5 not implemented 902 903;; 6.1 904(_provide (rename gluNewQuadric new-quadric)) 905 906;; 6.2 not implemented 907 908;; 6.3 909(_provide quadric-normals 910 (rename gluQuadricTexture quadric-texture) 911 quadric-orientation quadric-draw-style) 912 913(make-enum-table quadric-normals-table GLU_NONE GLU_FLAT GLU_SMOOTH) 914(define (quadric-normals q e) 915 (gluQuadricNormals q (quadric-normals-table e 'quadric-normals))) 916 917(make-enum-table quadric-orientation-table GLU_INSIDE GLU_OUTSIDE) 918(define (quadric-orientation q e) 919 (gluQuadricOrientation q (quadric-orientation-table e 'quadric-normals))) 920 921(make-enum-table quadric-draw-style-table 922 GLU_POINT GLU_LINE GLU_SILHOUETTE GLU_FILL) 923(define (quadric-draw-style q e) 924 (gluQuadricDrawStyle q (quadric-draw-style-table e 'quadric-draw-style))) 925 926;; 6.4 927(_provide (rename gluCylinder cylinder) 928 (rename gluDisk disk) 929 (rename gluSphere sphere) 930 (rename gluPartialDisk partial-disk)) 931 932;; 7 not implemented 933 934;; 8 935(_provide ;error-string 936 ) 937 938;; Utils 939 940(_provide process-selection (struct selection-record (min-z max-z stack))) 941;; A selection-record is 942;; (make-selection-record number number (listof positive-int)) 943(define-struct selection-record (min-z max-z stack)) 944 945;; process-selection : gl-uint-vector int -> (listof selection-record) 946(define (process-selection v hits) 947 (unless (gl-uint-vector? v) 948 (raise-argument-error 'process-selection "gl-uint-vector?" 0 v hits)) 949 (let ([index 0]) 950 (let loop ([hit 0]) 951 (if (>= hit hits) 952 null 953 (let ([stack-size (gl-vector-ref v index)]) 954 (cons (make-selection-record 955 (gl-vector-ref v (add1 index)) 956 (gl-vector-ref v (+ index 2)) 957 (begin (set! index (+ 3 index)) 958 (let loop ([j 0]) 959 (if (< j stack-size) 960 (cons (gl-vector-ref v index) 961 (begin (set! index (add1 index)) 962 (loop (add1 j)))) 963 null)))) 964 (loop (add1 hit)))))))) 965 966(provide get-gl-version-number get-glu-version-number) 967(define (get-gl-version-number) 968 (let ([x (regexp-match "^([0-9]*)\\.([0-9*])" (get-string 'version))]) 969 (string->number (string-append (cadr x) (caddr x))))) 970(define (get-glu-version-number) 971 (let ([x (regexp-match "^([0-9]*)\\.([0-9*])" (u-get-string 'version))]) 972 (string->number (string-append (cadr x) (caddr x))))) 973