From: Matt Birkholz Date: Mon, 4 Nov 2013 00:02:11 +0000 (-0700) Subject: gl: Add gl:display, gl:cull-face, gl:color-material, gl:scale... X-Git-Tag: mit-scheme-pucked-9.2.12~437 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=21439a7cab19b34a39bcd9ac571d32d4c9fdf7e8;p=mit-scheme.git gl: Add gl:display, gl:cull-face, gl:color-material, gl:scale... gl:scaled should have been gl:scale. --- diff --git a/src/gl/gl.cdecl b/src/gl/gl.cdecl index 5794d2b17..946cefca7 100644 --- a/src/gl/gl.cdecl +++ b/src/gl/gl.cdecl @@ -41,19 +41,31 @@ USA. (extern void glClearDepth (depth GLdouble)) (extern void glEnable (cap GLenum)) +(extern void glDisable (cap GLenum)) (enum (GL_DEPTH_TEST)) +(enum (GL_COLOR_MATERIAL)) (extern void glDepthFunc (func GLenum)) (enum (GL_LEQUAL)) +(extern void glCullFace (mode GLenum)) + +(enum (GL_FRONT) + (GL_FRONT_AND_BACK) + (GL_BACK)) + (extern void glHint (target GLenum) (mode GLenum)) (enum (GL_PERSPECTIVE_CORRECTION_HINT)) (enum (GL_NICEST)) +(extern void glColorMaterial (face GLenum) (mode GLenum)) + +(enum (GL_DIFFUSE)) + (extern void glClear (mask GLbitfield)) (enum (GL_COLOR_BUFFER_BIT) @@ -92,6 +104,7 @@ USA. (extern void gl_material (face GLenum) (pname GLenum) (params SCM)) (extern void glMatrixMode (mode GLenum)) +(enum (GL_PROJECTION) (GL_MODELVIEW)) (extern void glNewList (list GLuint) (mode GLenum)) @@ -120,10 +133,7 @@ USA. (GL_BACK_RIGHT) (GL_BACK_LEFT) (GL_POSITION) - (GL_FRONT) (GL_AMBIENT_AND_DIFFUSE) - (GL_PROJECTION) - (GL_MODELVIEW) (GL_COMPILE) (GL_FLAT)) diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg index 80bf1b3ab..4dc0e189a 100644 --- a/src/gl/gl.pkg +++ b/src/gl/gl.pkg @@ -39,12 +39,15 @@ USA. gl:clear-color gl:clear-depth gl:enable + gl:disable gl:depth-func + gl:cull-face gl:hint + gl:color-material gl:clear gl:load-identity glu:look-at - gl:scaled + gl:scale gl:begin gl:color gl:vertex @@ -82,6 +85,10 @@ USA. (import (gtk) add-gc-cleanup punt-gc-cleanup error-if-null gobject-alien gtk-window-new + gtk-widget-destroy gtk-widget-parent + gtk-widget-show-all + gtk-widget-queue-draw + set-gtk-widget-draw-callback! gtk-window-set-opacity gtk-window-set-title set-gtk-window-delete-event-callback! @@ -89,9 +96,11 @@ USA. gtk-container-add gtk-widget-show-all - fix-widget-realize-callback) + fix-widget-realize-callback + set-fix-widget-key-press-handler!) (export (gl) - make-glx-device with-glx-device glx:swap-buffers )) + make-glx-widget with-glx-widget glx:swap-buffers + with-glx-viewport )) (define-package (gl glxgears) (files "gl-glxgears") diff --git a/src/gl/gl.scm b/src/gl/gl.scm index d5fd4d72a..abc01ca31 100644 --- a/src/gl/gl.scm +++ b/src/gl/gl.scm @@ -44,16 +44,23 @@ USA. (guarantee-gl-depth depth 'GL:CLEAR-DEPTH) (C-call "glClearDepth" depth)) +(define (->capability cap operator) + (case cap + ((DEPTH-TEST) (C-enum "GL_DEPTH_TEST")) + ((CULL-FACE) (C-enum "GL_CULL_FACE")) + ((LIGHT0) (C-enum "GL_LIGHT0")) + ((LIGHTING) (C-enum "GL_LIGHTING")) + ((NORMALIZE) (C-enum "GL_NORMALIZE")) + ((COLOR-MATERIAL) (C-enum "GL_COLOR_MATERIAL")) + (else (error:wrong-type-argument cap "a GL capability" operator)))) + (define (gl:enable capability) (guarantee-current 'GL:ENABLE) - (C-call "glEnable" - (case capability - ((DEPTH-TEST) (C-enum "GL_DEPTH_TEST")) - ((CULL-FACE) (C-enum "GL_CULL_FACE")) - ((LIGHT0) (C-enum "GL_LIGHT0")) - ((LIGHTING) (C-enum "GL_LIGHTING")) - ((NORMALIZE) (C-enum "GL_NORMALIZE")) - (else (error "Unknown glEnable capability:" capability))))) + (C-call "glEnable" (->capability capability 'GL:ENABLE))) + +(define (gl:disable capability) + (guarantee-current 'GL:DISABLE) + (C-call "glDisable" (->capability capability 'GL:DISABLE))) (define (gl:depth-func function) (guarantee-current 'GL:DEPTH-FUNC) @@ -62,6 +69,15 @@ USA. ((LEQUAL) (C-enum "GL_LEQUAL")) (else (error "Unknown glDepthFunc function:" function))))) +(define (gl:cull-face mode) + (guarantee-current 'GL:CULL-FACE) + (C-call "glCullFace" + (case mode + ((FRONT) (C-enum "GL_FRONT")) + ((BACK) (C-enum "GL_BACK")) + ((FRONT-AND-BACK) (C-enum "GL_FRONT_AND_BACK")) + (else (error "Unknown glCullFace mode:" mode))))) + (define (gl:hint target mode) (guarantee-current 'GL:HINT) (C-call "glHint" @@ -72,6 +88,15 @@ USA. ((NICEST) (C-enum "GL_NICEST")) (else (error "Unknown glHint mode:" mode))))) +(define (gl:color-material face mode) + (C-call "glColorMaterial" + (case face + ((FRONT) (C-enum "GL_FRONT")) + (else (error "Unknown glColorMaterial face:" face))) + (case mode + ((DIFFUSE) (C-enum "GL_DIFFUSE")) + (else (error "Unknown glColorMaterial mode:" mode))))) + (define (gl:clear . bits) (guarantee-current 'GL:CLEAR) (C-call "glClear" @@ -94,11 +119,11 @@ USA. (guarantee-current 'GL:LOOK-AT) (C-call "glu_look_at" position aim up)) -(define (gl:scaled kx ky kz) - (guarantee-current 'GL:SCALED) - (guarantee-flonum kx 'GL:SCALED) - (guarantee-flonum ky 'GL:SCALED) - (guarantee-flonum kz 'GL:SCALED) +(define (gl:scale kx ky kz) + (guarantee-current 'GL:SCALE) + (guarantee-flonum kx 'GL:SCALE) + (guarantee-flonum ky 'GL:SCALE) + (guarantee-flonum kz 'GL:SCALE) (C-call "glScaled" kx ky kz)) (define (gl:begin mode)