From: Matt Birkholz Date: Mon, 11 Nov 2013 22:13:03 +0000 (-0700) Subject: Use glu:perspective and glu:look-at to "fly" a . X-Git-Tag: mit-scheme-pucked-9.2.12~425 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2a9e53c699fc4938dc25102e7f7c830fc1030d68;p=mit-scheme.git Use glu:perspective and glu:look-at to "fly" a . Also added gl:light-model, gl:blend-func all of the primitive, lights, material params... --- diff --git a/src/gl/check.scm b/src/gl/check.scm index ff67f2525..7379e6a86 100644 --- a/src/gl/check.scm +++ b/src/gl/check.scm @@ -2,6 +2,9 @@ ;;;; Run the GLXGears demo. +(load-option 'CREF) +(load-option 'SOS) +(load-option 'FFI) (load-option 'GTK) (if (gtk-thread-running?) diff --git a/src/gl/gl-adapter.c b/src/gl/gl-adapter.c index 0585393c2..cdbea1b92 100644 --- a/src/gl/gl-adapter.c +++ b/src/gl/gl-adapter.c @@ -26,11 +26,11 @@ USA. /* Adapters for the GL graphics library. */ -#include "gl-shim.h" #include #include #include #include +#include "gl-shim.h" void gl_clear_color (SCM color) @@ -41,14 +41,6 @@ gl_clear_color (SCM color) flovec_ref (color, 3)); } -void -glu_look_at (SCM eye, SCM center, SCM up) -{ - gluLookAt (flovec_ref (eye, 0), flovec_ref (eye, 1), flovec_ref (eye, 2), - flovec_ref(center,0),flovec_ref(center,1),flovec_ref(center,2), - flovec_ref (up, 0), flovec_ref (up, 1), flovec_ref (up, 2)); -} - void gl_color (SCM color) { @@ -75,6 +67,20 @@ gl_light (GLenum light, GLenum pname, SCM params) free (fvec); } +void +gl_light_model_v (GLenum pname, const GLfloat *params) +{ + int i, len = flovec_length (params); + GLfloat *fvec = malloc (len * sizeof (GLfloat)); + if (!fvec) + error_external_return (); + for (i = 0; i < len; i++) { + fvec[i] = flovec_ref (params, i); + } + glLightModelfv (pname, fvec); + free (fvec); +} + void gl_material (GLenum face, GLenum pname, SCM params) { @@ -95,51 +101,39 @@ gl_normal (SCM point) glNormal3dv (flovec_loc (point)); } -#if 0 -gboolean -glX_query_extension (void) -{ - return (glXQueryExtension (GDK_DISPLAY_XDISPLAY (gdk_display_get_default ()), - NULL, NULL)); -} -#endif - -Display * -gdk_window_xdisplay (GdkWindow *window) -{ - return (GDK_WINDOW_XDISPLAY (window)); -} - -int -gdk_window_screen_num (GdkWindow *window) -{ - return (gdk_screen_get_number (gdk_window_get_screen (window))); -} - -int -gdk_window_xid (GdkWindow *window) +void +glu_look_at (SCM eye, SCM center, SCM up) { - return (GDK_WINDOW_XID (window)); + gluLookAt (flovec_ref (eye, 0), flovec_ref (eye, 1), flovec_ref (eye, 2), + flovec_ref(center,0),flovec_ref(center,1),flovec_ref(center,2), + flovec_ref (up, 0), flovec_ref (up, 1), flovec_ref (up, 2)); } -#if 0 -GLXWindow* -glx_create_window (Display *dpy, GLXFBConfig config, GdkWindow *window) -{ - /* Return XID as if an address. */ - return ((GLXWindow *) glXCreateWindow (dpy, config, - (GDK_WINDOW_XID (window)), - NULL)); -} +static int gdk_visual_get_visual_class (GdkVisual *v); -void -glx_destroy_window (Display *dpy, GLXWindow *win) +GdkVisual* +glx_find_gdkvisual (GdkWindow *window, XVisualInfo *visinfo) { - /* Expect win is an XID, *not* the address of an XID. See - glx_create_window. */ - glXDestroyWindow (dpy, ((XID)win)); + GList *list = gdk_screen_list_visuals (gdk_window_get_screen (window)); + GdkVisual *found = NULL; + int match_class = visinfo->class; + int match_depth = visinfo->depth; + GList *scan = list; + while (scan) { + GdkVisual *v = scan->data; + if (gdk_visual_get_visual_class (v) == match_class + && gdk_visual_get_depth (v) == match_depth) + { + found = v; + break; + } + scan = scan->next; + } + g_list_free (list); + if (!found) + error_external_return (); + return (found); } -#endif static int gdk_visual_get_visual_class (GdkVisual *v) @@ -162,26 +156,20 @@ gdk_visual_get_visual_class (GdkVisual *v) } } -GdkVisual* -glx_find_gdkvisual (GdkWindow *window, XVisualInfo *visinfo) +int +gdk_window_xid (GdkWindow *window) { - GList *list = gdk_screen_list_visuals (gdk_window_get_screen (window)); - GdkVisual *found = NULL; - int match_class = visinfo->class; - int match_depth = visinfo->depth; - GList *scan = list; - while (scan) { - GdkVisual *v = scan->data; - if (gdk_visual_get_visual_class (v) == match_class - && gdk_visual_get_depth (v) == match_depth) - { - found = v; - break; - } - scan = scan->next; - } - g_list_free (list); - if (!found) - error_external_return (); - return (found); + return (GDK_WINDOW_XID (window)); +} + +Display * +gdk_window_xdisplay (GdkWindow *window) +{ + return (GDK_WINDOW_XDISPLAY (window)); +} + +int +gdk_window_screen_num (GdkWindow *window) +{ + return (gdk_screen_get_number (gdk_window_get_screen (window))); } diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm index 6184a3afb..60f08daa8 100644 --- a/src/gl/gl-glx.scm +++ b/src/gl/gl-glx.scm @@ -26,17 +26,6 @@ USA. (C-include "gl") -(define (make-glx-widget width height title) - (let ((window (gtk-window-new 'toplevel))) - (gtk-window-set-title window title) - (set-gtk-window-delete-event-callback! - window (lambda (w) (%trace ";closed "w"\n") 0)) - (gtk-container-set-border-width window 5) - (let ((widget (%make-glx-widget width height))) - (gtk-container-add window widget) - (gtk-widget-show-all window) - widget))) - (define (with-glx-widget widget thunk) (with-gl-library (lambda () @@ -53,10 +42,9 @@ USA. (define (glx:swap-buffers widget) (let ((xdisplay (glx-widget-xdisplay widget)) (xwindow (glx-widget-xwindow widget))) - (%trace "; glx:swap-buffers "xdisplay" "xwindow"\n") (C-call "glXSwapBuffers" xdisplay xwindow))) -(define-class ( (constructor %make-glx-widget () (width height))) +(define-class ( (constructor () (width height))) () (xdisplay define standard @@ -70,9 +58,7 @@ USA. (add-gc-cleanup widget (make-glx-widget-cleanup (glx-widget-xdisplay widget) (glx-widget-glxcontext widget))) - (let ((alien (gobject-alien widget))) - (C-call "gtk_widget_set_double_buffered" alien 0) - (C-call "gtk_widget_set_app_paintable" alien 1))) + (C-call "gtk_widget_set_double_buffered" (gobject-alien widget) 0)) (define (make-glx-widget-cleanup xdisplay glxcontext) (named-lambda (glx-widget-cleanup) @@ -94,7 +80,6 @@ USA. (call-next-method widget)) (define-method fix-widget-realize-callback ((widget )) - (%trace "; (fix-widget-realize-callback ) "widget"\n") (let* ((GtkWidget (gobject-alien widget)) (parent (C-call "gtk_widget_get_parent_window" (make-alien '|GdkWindow|) @@ -146,13 +131,9 @@ USA. (set-glx-widget-xwindow! widget (C-call "gdk_window_xid" GdkWindow)) (C-call "gtk_widget_set_window" GtkWidget GdkWindow) (C-call "gdk_window_set_user_data" GdkWindow GtkWidget) - (%trace "; window: "GdkWindow"\n") - - (%trace ";glXCreateContext "xdisplay" "visinfo"\n") (let ((alien (glx-widget-glxcontext widget))) (C-call "glXCreateContext" alien xdisplay visinfo 0 1) - (error-if-null alien "Could not create GLXContext.") - (%trace "; => "alien"\n"))))) + (error-if-null alien "Could not create GLXContext."))))) (C-call "gtk_widget_set_can_focus" GtkWidget 1))) @@ -168,7 +149,6 @@ USA. (add-gc-cleanup configs (make-fb-configs-cleanup copy)) (C-call "glXChooseFBConfig" copy display screen-num attribs num-configs) - (%trace ";glXChooseFBConfig returned "(C-> num-configs "int")" configs\n") (free attribs) (free num-configs) (if (alien-null? copy) @@ -212,141 +192,198 @@ USA. attrib))) alien)) -#;(define (gl-draw-callback widget cairo) - (%trace "; draw "widget" at " - (cairo-clip-extents - cr (lambda (min-x min-y max-x max-y) - (define-integrable n->s number->string) - (string-append (n->s min-x)","(n->s min-y) - " "(n->s (- max-x min-x)) - "x"(n->s (- max-y min-y))))) - "\n")) - -#;(define (gl-adjustments-callback widget hGtkAdjustment vGtkAdjustment) - (%trace ";set-scroll-adjustments "widget - " "hGtkAdjustment" "vGtkAdjustment"\n")) +#;(define (glx-widget-write-to-png widget filename) + (let* ((pixbuf (make-pixbuf)) + (alien (gobject-alien pixbuf)) + (geometry (fix-widget-geometry widget))) + (C-call "gdk_pixbuf_xlib_get_from_drawable" alien + 0 (glx-widget-xwindow widget) ;dest, src + 0 0 ;cmap, visual + 0 0 ;src_x, src_y + 0 0 ;dest_x, dest_y + (fix-rect-width geometry) + (fix-rect-height geometry)) + (let ((gerror* (make-gerror-pointer))) + (if (zero? (C-call "gdk_pixbuf_save" alien filename "png" gerror* 0 0 0)) + (let* ((gerror (C-> gerror* "* GError")) + (message + (or (and (not (alien-null? gerror)) + (c-peek-cstring (C-> gerror "GError message"))) + "GError pointer not set."))) + (gerror-pointer-free gerror*) + (error message)))))) + +#;(define (make-gerror-pointer) + (let ((alien (make-alien '(* |GError|))) + (copy (make-alien '(* |GError|)))) + (add-gc-cleanup alien (make-gerror-pointer-cleanup copy)) + (C-call "g_try_malloc0" copy (C-sizeof "* GError")) + (if (alien-null? copy) + (begin + (punt-gc-cleanup alien) + (error "Could not create:" alien)) + (begin + (copy-alien-address! alien copy) + alien)))) + +#;(define (make-gerror-pointer-cleanup gerror*) + (named-lambda (gerror-pointer-cleanup) + ;;without-interrupts + (if (not (alien-null? gerror*)) + (let ((gerror (make-alien '|GError|))) + (C-> gerror* "* GError" gerror) + (if (not (alien-null? gerror)) + (C-call "g_error_free" gerror)) + (C-call "g_free" gerror*) + (alien-null! gerror*))))) + +#;(define (gerror-pointer-free gerror*) + (without-interrupts + (lambda () + (if (not (alien-null? gerror*)) + (let ((cleanup (punt-gc-cleanup gerror*))) + (if cleanup (cleanup)) + (alien-null! gerror*)))))) -(define (with-glx-viewport width height title draw) - (let ((window (gtk-window-new 'toplevel))) - (gtk-window-set-title window title) - (set-gtk-window-delete-event-callback! - window (lambda (w) (%trace ";closed "w"\n") 0)) - (gtk-container-set-border-width window 5) - (let ((widget (make-glx-viewport draw width height))) - (gtk-container-add window widget) - (gtk-widget-show-all window) - widget))) - -(define-class ( (constructor (draw) (width height))) - ;; A with viewport parameters, thus implementing - ;; scrolling -- "orbiting" the viewport around a focus. It also - ;; supports stereo views and provides a key-press handler that - ;; orbits with the arrow keys. +(define-class ( (constructor () (width height))) + ;; A with camera parameters, and a default key-press + ;; handler to fly the camera. () - (stereo? define standard) - (eye-separation define standard initial-value 5.) - (fixation-distance define standard initial-value 40.) - (x-rotation define standard initial-value 20.) - (y-rotation define standard initial-value 30.) - (draw define accessor)) + (position define accessor initializer (lambda () (flo:3d 0. 0. 0.))) + (heading define standard initial-value 0.) + (tilt define standard initial-value 0.) + (step-size define standard initial-value 1.) + (fovy define standard initial-value 45.) + (near define standard initial-value .1) + (far define standard initial-value 1000.)) (define-method initialize-instance ((widget ) width height) (call-next-method widget width height) - - (set-glx-viewport-stereo?! widget #f) ;How to tell if display is stereo? - (set-gtk-widget-draw-callback! widget draw) + (set-gtk-widget-draw-callback! widget draw-callback) (set-fix-widget-key-press-handler! widget glx-viewport-key-press-handler)) -(define (draw widget cr) +(define-method fix-widget-new-geometry-callback ((widget )) + (call-next-method widget) + (if (glx-widget-xwindow widget) + (let ((geometry (fix-widget-geometry widget))) + (let ((w (fix-rect-width geometry)) + (h (fix-rect-height geometry))) + (let ((aspect (->flonum (/ w h)))) + (with-glx-widget widget + (lambda () + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:viewport 0 0 w h) + (glu:perspective (glx-viewport-fovy widget) + aspect + (glx-viewport-near widget) + (glx-viewport-far widget))))))))) + +(define (draw-callback widget cr) (declare (ignore cr)) - (%trace "; draw "widget"\n") + #;(%trace "; draw "widget" at " + (cairo-clip-extents + cr (lambda (min-x min-y max-x max-y) + (define-integrable n->s number->string) + (string-append (n->s min-x)","(n->s min-y) + " "(n->s (- max-x min-x)) + "x"(n->s (- max-y min-y))))) + "\n") (with-glx-widget widget (lambda () - (let ((geometry (fix-widget-geometry widget)) - (rotx (glx-viewport-x-rotation widget)) - (roty (glx-viewport-y-rotation widget)) - (DRAW (glx-viewport-draw widget))) - (let ((width (fix-rect-width geometry)) - (height (fix-rect-height geometry))) - (gl:viewport 0 0 width height) - (let ((aspect (->flonum (/ width height)))) - (if (glx-viewport-stereo? widget) - (let ((eyesep (glx-viewport-eye-separation widget)) - (fix-point (glx-viewport-fixation-distance widget))) - (let ((w (* fix-point (/ 1. 5.)))) - (let ((left (* -5. (/ (- w (* .5 eyesep)) fix-point))) - (right (* 5. (/ (+ w (* .5 eyesep)) fix-point)))) - - ;; First left eye. - (gl:draw-buffer 'BACK-LEFT) - - (gl:matrix-mode 'PROJECTION) - (gl:load-identity) - (gl:frustum left right (- aspect) aspect -1. 1.) - - (gl:matrix-mode 'MODELVIEW) - (gl:push-matrix) - (gl:translate (* .5 eyesep) 0. -2.) - (gl:rotate rotx 1. 0. 0.) - (gl:rotate roty 0. 1. 0.) - (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) - (DRAW widget) - (gl:pop-matrix) - - ;; Then right eye. - (gl:draw-buffer 'BACK-RIGHT) - - (gl:matrix-mode 'PROJECTION) - (gl:load-identity) - (gl:frustum (- right) (- left) (- aspect) aspect -1. 1.) - - (gl:matrix-mode 'MODELVIEW) - (gl:push-matrix) - (gl:translate (* -.5 eyesep) 0. -2.) - (gl:rotate rotx 1. 0. 0.) - (gl:rotate roty 0. 1. 0.) - (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) - (DRAW widget) - (gl:pop-matrix)))) - - (begin - (gl:matrix-mode 'PROJECTION) - (gl:load-identity) - (gl:frustum -1. 1. (- aspect) aspect -1. 1.) - (gl:rotate rotx 1. 0. 0.) - (gl:rotate roty 0. 1. 0.) - - (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) - (gl:matrix-mode 'MODELVIEW) - (gl:load-identity) - (gl:push-matrix) - (DRAW widget) - (gl:pop-matrix)))))) + (gl:matrix-mode 'MODELVIEW) + (gl:load-identity) + (let ((position (glx-viewport-position widget)) + ;; Heading 0. is N: ( 0. 0. -1.) + ;; Heading pi/2 is E: ( 1. 0. 0.) + ;; Heading pi is S: ( 0. 0. 1.) + ;; Heading 3pi/2 is W: (-1. 0. 0.) + ;; Heading h is: ((sin h) 0. (- (cos h))) + (heading (glx-viewport-heading widget)) + (tilt (glx-viewport-tilt widget))) + (let ((sin-heading (flo:sin heading)) + (-cos-heading (flo:- 0. (flo:cos heading))) + (sin-tilt (flo:sin tilt)) + (cos-tilt (flo:cos tilt))) + (let ((center (flo:3d (flo:+ (x position) sin-heading) + (flo:+ (y position) sin-tilt) + (flo:+ (z position) -cos-heading))) + (up (flo:3d (flo:* sin-tilt sin-heading) + cos-tilt + (flo:* sin-tilt -cos-heading)))) + (glu:look-at position center up)))) + (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) + (glx-viewport-draw widget) (glx:swap-buffers widget) (gl:flush) #t))) +(define-generic glx-viewport-draw (widget)) + (define-generic glx-viewport-key-press-handler (widget key bits)) (define-method glx-viewport-key-press-handler ((widget ) key bits) (%trace "; (key-press ) "widget" "key" "bits"\n") (case key - ((#\escape #\Q #\q) (gtk-widget-destroy (gtk-widget-parent widget)) #t) - ((#\? #\c-h) (popup-help widget)) - ((|Up|) (rotx! widget 5.)) - ((|Down|) (rotx! widget -5.)) - ((|Left|) (roty! widget 5.)) - ((|Right|) (roty! widget -5.)))) - -(define-integrable (rotx! widget incr) - (set-glx-viewport-x-rotation! - widget (+ incr (glx-viewport-x-rotation widget))) + ((#\escape #\Q #\q) + (gtk-widget-destroy (let loop ((w widget)) + (let ((p (gtk-widget-parent w))) + (if p + (loop p) + w)))) + #t) + ((#\? #\c-h) + (popup-help widget)) + ((|Up|) + (cond ((fix:= bits char-bit:control) (tilt! widget 5.)) + ((fix:= bits 0) (step! widget 1.)) + (else #f))) + ((|Down|) + (cond ((fix:= bits char-bit:control) (tilt! widget -5.)) + ((fix:= bits 0) (step! widget -1.)) + (else #f))) + ((|Right|) + (turn! widget 5.)) + ((|Left|) + (turn! widget -5.)) + (else + #f))) + +(define (turn! widget degrees) + (let ((new-heading (flo:+ (glx-viewport-heading widget) + (degrees->radians degrees)))) + (set-glx-viewport-heading! + widget (cond ((flo:> new-heading pi) (flo:- new-heading 2pi)) + ((flo:< new-heading -pi) (flo:+ new-heading 2pi)) + (else new-heading)))) (gtk-widget-queue-draw widget) #t) -(define-integrable (roty! widget incr) - (set-glx-viewport-y-rotation! - widget (+ incr (glx-viewport-y-rotation widget))) +(define (tilt! widget degrees) + (let ((tilt (flo:+ (glx-viewport-tilt widget) + (degrees->radians degrees)))) + (if (and (flo:< -pi/2 tilt) (flo:< tilt pi/2)) + (begin + (set-glx-viewport-tilt! widget tilt) + (gtk-widget-queue-draw widget) + #t) + #f))) + +(define (step! widget number) + (let ((distance (flo:* number (glx-viewport-step-size widget))) + (position (glx-viewport-position widget)) + (heading (glx-viewport-heading widget)) + (tilt (glx-viewport-tilt widget))) + (let ((sin-heading (flo:sin heading)) + (cos-heading (flo:cos heading)) + (sin-tilt (flo:sin tilt)) + (cos-tilt (flo:cos tilt))) + (set-x! position (flo:+ (x position) + (flo:* distance (flo:* cos-tilt sin-heading)))) + (set-y! position (flo:+ (y position) + (flo:* distance sin-tilt))) + (set-z! position (flo:- (z position) + (flo:* distance (flo:* cos-tilt cos-heading)))))) (gtk-widget-queue-draw widget) #t) @@ -354,12 +391,36 @@ USA. ;; For now, just write to stdout. (declare (ignore widget)) (display "ESC - quit -up arrow - move viewport up -down arrow - move viewport down -left arrow - move viewport left -right arrow - move viewport right\n") +Up/Down - move forward/backward +Left/Right - turn left/right +Ctrl-Up/Down - tilt up/down\n") #t) +(define-integrable (flo:3d x y z) + (let ((v (flo:vector-cons 3))) + (flo:vector-set! v 0 x) + (flo:vector-set! v 1 y) + (flo:vector-set! v 2 z) + v)) + +(define-integrable (x v) (flo:vector-ref v 0)) +(define-integrable (y v) (flo:vector-ref v 1)) +(define-integrable (z v) (flo:vector-ref v 2)) +(define-integrable (set-x! v f) (flo:vector-set! v 0 f)) +(define-integrable (set-y! v f) (flo:vector-set! v 1 f)) +(define-integrable (set-z! v f) (flo:vector-set! v 2 f)) + +(define-integrable pi/4 (flo:atan2 1. 1.)) +(define-integrable pi/2 (flo:* 2. pi/4)) +(define-integrable pi (flo:* 4. pi/4)) +(define-integrable 2pi (flo:* 8. pi/4)) +(define-integrable -pi (flo:- 0. pi)) +(define-integrable -pi/2 (flo:- 0. pi/2)) + +(define-integrable (degrees->radians degrees) (flo:* degrees (flo:/ 2pi 360.))) + +(define-integrable (radians->degrees radians) (flo:* radians (flo:/ 360. 2pi))) + (define %trace? #f) (define-syntax %trace diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm index 25c83fb8c..4d62c72b5 100644 --- a/src/gl/gl-glxgears.scm +++ b/src/gl/gl-glxgears.scm @@ -513,11 +513,7 @@ USA. (gl:end))))) (define-integrable (gl:vertex3 x y z) - (let ((v (flo:vector-cons 3))) - (flo:vector-set! v 0 x) - (flo:vector-set! v 1 y) - (flo:vector-set! v 2 z) - (gl:vertex v))) + (gl:vertex (flo:3d x y z))) (define-integrable 2pi (* 8. (flo:atan2 1. 1.))) diff --git a/src/gl/gl-shim.h b/src/gl/gl-shim.h index 5fdadaaeb..160eea432 100644 --- a/src/gl/gl-shim.h +++ b/src/gl/gl-shim.h @@ -25,4 +25,20 @@ USA. #include #include -/* #include for gluLookAt, which doesn't need a declaration(?) */ +#include + +/* Do not declare in gl-const.c, which does not include mit-scheme.h. */ +#ifdef CSTACK_PUSH +extern void gl_clear_color (SCM color); +extern void gl_color (SCM color); +extern void gl_vertex (SCM point); +extern void gl_light (GLenum light, GLenum pname, SCM params); +extern void gl_light_model_v (GLenum pname, const GLfloat *params); +extern void gl_material (GLenum face, GLenum pname, SCM params); +extern void gl_normal (SCM point); +extern void glu_look_at (SCM eye, SCM center, SCM up); +extern GdkVisual* glx_find_gdkvisual (GdkWindow *window, XVisualInfo *visinfo); +extern int gdk_window_xid (GdkWindow *window); +extern Display* gdk_window_xdisplay (GdkWindow *window); +extern int gdk_window_screen_num (GdkWindow *window); +#endif diff --git a/src/gl/gl.cdecl b/src/gl/gl.cdecl index 946cefca7..bb1210ec5 100644 --- a/src/gl/gl.cdecl +++ b/src/gl/gl.cdecl @@ -50,6 +50,15 @@ USA. (enum (GL_LEQUAL)) +(extern void glBlendFunc(sfactor GLenum) (dfactor GLenum)) + +(enum (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)) + (extern void glCullFace (mode GLenum)) (enum (GL_FRONT) @@ -64,8 +73,6 @@ USA. (extern void glColorMaterial (face GLenum) (mode GLenum)) -(enum (GL_DIFFUSE)) - (extern void glClear (mask GLbitfield)) (enum (GL_COLOR_BUFFER_BIT) @@ -74,13 +81,21 @@ USA. (extern void glLoadIdentity) -(extern void glu_look_at (eye SCM) (center SCM) (up SCM)) - (extern void glScaled (kx GLdouble) (ky GLdouble) (kz GLdouble)) (extern void glBegin (mode GLenum)) -(enum (GL_QUAD_STRIP) (GL_QUADS) (GL_LINES)) +;; Primitives +(enum (GL_POINTS) + (GL_LINES) + (GL_LINE_LOOP) + (GL_LINE_STRIP) + (GL_TRIANGLES) + (GL_TRIANGLE_STRIP) + (GL_TRIANGLE_FAN) + (GL_QUADS) + (GL_QUAD_STRIP) + (GL_POLYGON)) (extern void gl_color (color SCM)) @@ -101,6 +116,17 @@ USA. (extern void gl_light (light GLenum) (pname GLenum) (params SCM)) +(extern void glLightModelf (pname GLenum) (param GLfloat)) +(extern void glLightModeli (pname GLenum) (param GLint)) +(extern void gl_light_model_v (pname GLenum) (params SCM)) + +(enum (GL_LIGHT_MODEL_AMBIENT) + (GL_LIGHT_MODEL_COLOR_CONTROL) + (GL_LIGHT_MODEL_LOCAL_VIEWER) + (GL_LIGHT_MODEL_TWO_SIDE) + (GL_SEPARATE_SPECULAR_COLOR) + (GL_SINGLE_COLOR)) + (extern void gl_material (face GLenum) (pname GLenum) (params SCM)) (extern void glMatrixMode (mode GLenum)) @@ -127,19 +153,29 @@ USA. (extern void glFlush) (enum (GL_NORMALIZE) - (GL_LIGHTING) - (GL_LIGHT0) + (GL_RESCALE_NORMAL)) + +(enum (GL_LIGHTING) + (GL_LIGHT0)(GL_LIGHT1)(GL_LIGHT2)(GL_LIGHT3)(GL_LIGHT4)(GL_LIGHT5)(GL_LIGHT6)(GL_LIGHT7) (GL_CULL_FACE) (GL_BACK_RIGHT) (GL_BACK_LEFT) (GL_POSITION) - (GL_AMBIENT_AND_DIFFUSE) + (GL_AMBIENT)(GL_DIFFUSE)(GL_SPECULAR)(GL_EMISSION)(GL_SHININESS) + (GL_AMBIENT_AND_DIFFUSE)(GL_COLOR_INDEXES) + (GL_COMPILE) (GL_FLAT)) + +(extern void glu_look_at (eye SCM) (center SCM) (up SCM)) + +(extern void gluPerspective + (fovy GLdouble) (aspect GLdouble) (zNear GLdouble) (zFar GLdouble)) (typedef GLXFBConfig (* (struct __GLXFBConfigRec))) (typedef GLXContext (* (struct __GLXcontextRec))) (typedef GLXPixmap XID) +(typedef GLXWindow XID) (typedef GLXDrawable XID) #;(extern (* GLXFBConfig) glXChooseFBConfig @@ -212,12 +248,21 @@ USA. (GLX_RED_SIZE) (GLX_GREEN_SIZE) (GLX_BLUE_SIZE)) + +(extern (* GdkVisual) glx_find_gdkvisual + (window (* GdkWindow)) + (visinfo (* XVisualInfo))) + +(extern GLXWindow gdk_window_xid (window (* GdkWindow))) +(typedef gchar char) (typedef gint int) +(typedef gsize uint) (typedef gpointer (* void)) (typedef gboolean int) (typedef Window XID) ;X11/X.h -(typedef GLXWindow XID) ;X11/X.h +(typedef Drawable XID) ;X11/X.h +(typedef Colormap XID) ;X11/X.h (typedef Pixmap XID) ;X11/X.h (typedef Font XID) ;X11/Xdefs.h (typedef Bool int) ;X11/Xdefs.h @@ -228,15 +273,9 @@ USA. (extern int gdk_window_screen_num (window (* GdkWindow))) -(extern GLXWindow gdk_window_xid (window (* GdkWindow))) - (extern (* GtkWindow) gtk_widget_get_parent_window (widget (* GtkWidget))) -(extern (* GdkVisual) glx_find_gdkvisual - (window (* GdkWindow)) - (visinfo (* XVisualInfo))) - (extern void gtk_widget_set_window (widget (* GtkWidget)) (window (* GdkWindow))) @@ -296,4 +335,35 @@ USA. (window (* GdkWindow)) (user_data gpointer)) -(enum (GDK_ALL_EVENTS_MASK)) \ No newline at end of file +(enum (GDK_ALL_EVENTS_MASK)) + +#;(extern (* GdkPixbuf) gdk_pixbuf_xlib_get_from_drawable + (dest (* GdkPixbuf)) + (src Drawable) + (cmap Colormap) + (visual (* Visual)) + (src_x int) (src_y int) + (dest_x int) (dest_y int) + (width int) (height int)) + +#;(extern gboolean gdk_pixbuf_save + (pixbuf (* GdkPixbuf)) + (filename (* (const gchar))) + (type (* (const gchar))) + (error (* (* GError))) + (arg1 (* (const gchar))) + (arg2 (* (const gchar))) + (arg3 (* (const gchar)))) + +#;(typedef GError (struct _GError)) + +#;(struct _GError + ;;(domain GQuark) + (code gint) + (message (* gchar))) + +#;(extern gpointer g_try_malloc0 (n_bytes gsize)) + +#;(extern void g_free (mem gpointer)) + +#;(extern void g_error_free (error (* GError))) \ No newline at end of file diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg index 4dc0e189a..790d7ed5f 100644 --- a/src/gl/gl.pkg +++ b/src/gl/gl.pkg @@ -41,12 +41,12 @@ USA. gl:enable gl:disable gl:depth-func + gl:blend-func gl:cull-face gl:hint gl:color-material gl:clear gl:load-identity - glu:look-at gl:scale gl:begin gl:color @@ -57,6 +57,7 @@ USA. gl:frustum gl:gen-lists gl:light + gl:light-model gl:material gl:matrix-mode gl:new-list @@ -68,7 +69,9 @@ USA. gl:rotate gl:translate gl:viewport - gl:flush)) + gl:flush + glu:look-at + glu:perspective)) (define-package (gl internals glx) (parent (gl internals)) @@ -77,12 +80,16 @@ USA. ucode-primitive) (import (runtime ffi) %set-alien/address!) + (import (gtk gobject) + make-pixbuf) (import (gtk gtk-widget) gtk-widget-destroy-callback) (import (gtk fix-layout) fix-rect-x fix-rect-y fix-rect-width fix-rect-height - fix-widget-geometry fix-widget-window) + fix-widget-geometry fix-widget-window + set-fix-widget-map-handler! set-fix-widget-unmap-handler!) (import (gtk) + cairo-clip-extents add-gc-cleanup punt-gc-cleanup error-if-null gobject-alien gtk-window-new gtk-widget-destroy gtk-widget-parent @@ -97,10 +104,21 @@ USA. gtk-widget-show-all fix-widget-realize-callback + fix-widget-new-geometry-callback set-fix-widget-key-press-handler!) (export (gl) - make-glx-widget with-glx-widget glx:swap-buffers - with-glx-viewport )) + make-glx-widget + with-glx-widget glx:swap-buffers + make-glx-viewport + glx-viewport-draw + glx-viewport-key-press-handler + glx-viewport-position + glx-viewport-heading + glx-viewport-tilt + glx-viewport-step-size + glx-viewport-fovy + glx-viewport-near + glx-viewport-far)) (define-package (gl glxgears) (files "gl-glxgears") diff --git a/src/gl/gl.scm b/src/gl/gl.scm index abc01ca31..d77326ced 100644 --- a/src/gl/gl.scm +++ b/src/gl/gl.scm @@ -49,8 +49,16 @@ USA. ((DEPTH-TEST) (C-enum "GL_DEPTH_TEST")) ((CULL-FACE) (C-enum "GL_CULL_FACE")) ((LIGHT0) (C-enum "GL_LIGHT0")) + ((LIGHT1) (C-enum "GL_LIGHT1")) + ((LIGHT2) (C-enum "GL_LIGHT2")) + ((LIGHT3) (C-enum "GL_LIGHT3")) + ((LIGHT4) (C-enum "GL_LIGHT4")) + ((LIGHT5) (C-enum "GL_LIGHT5")) + ((LIGHT6) (C-enum "GL_LIGHT6")) + ((LIGHT7) (C-enum "GL_LIGHT7")) ((LIGHTING) (C-enum "GL_LIGHTING")) ((NORMALIZE) (C-enum "GL_NORMALIZE")) + ((RESCALE-NORMAL) (C-enum "GL_RESCALE_NORMAL")) ((COLOR-MATERIAL) (C-enum "GL_COLOR_MATERIAL")) (else (error:wrong-type-argument cap "a GL capability" operator)))) @@ -69,6 +77,31 @@ USA. ((LEQUAL) (C-enum "GL_LEQUAL")) (else (error "Unknown glDepthFunc function:" function))))) +(define (gl:blend-func sfactor dfactor) + (guarantee-current 'GL:BLEND-FUNC) + (let ((s (->blend-factor sfactor 'GL:BLEND-FUNC)) + (d (->blend-factor dfactor 'GL:BLEND-FUNC))) + (C-call "glBlendFunc" s d))) + +(define (->blend-factor f op) + (case f + ((ZERO) (C-enum "GL_ZERO")) + ((ONE) (C-enum "GL_ONE")) + ((SRC-COLOR) (C-enum "GL_SRC_COLOR")) + ((ONE-MINUS-SRC-COLOR) (C-enum "GL_ONE_MINUS_SRC_COLOR")) + ((DST-COLOR) (C-enum "GL_DST_COLOR")) + ((ONE-MINUS-DST-COLOR) (C-enum "GL_ONE_MINUS_DST_COLOR")) + ((SRC-ALPHA) (C-enum "GL_SRC_ALPHA")) + ((ONE-MINUS-SRC-ALPHA) (C-enum "GL_ONE_MINUS_SRC_ALPHA")) + ((DST-ALPHA) (C-enum "GL_DST_ALPHA")) + ((ONE-MINUS-DST-ALPHA) (C-enum "GL_ONE_MINUS_DST_ALPHA")) + ((CONSTANT-COLOR) (C-enum "GL_CONSTANT_COLOR")) + ((ONE-MINUS-CONSTANT-COLOR) (C-enum "GL_ONE_MINUS_CONSTANT_COLOR")) + ((CONSTANT-ALPHA) (C-enum "GL_CONSTANT_ALPHA")) + ((ONE-MINUS-CONSTANT-ALPHA) (C-enum "GL_ONE_MINUS_CONSTANT_ALPHA")) + ((SRC-ALPHA-SATURATE) (C-enum "GL_SRC_ALPHA_SATURATE")) + (else (error:wrong-type-argument f "GL blend factor" op)))) + (define (gl:cull-face mode) (guarantee-current 'GL:CULL-FACE) (C-call "glCullFace" @@ -92,9 +125,15 @@ USA. (C-call "glColorMaterial" (case face ((FRONT) (C-enum "GL_FRONT")) + ((FRONT-AND-BACK) (C-enum "GL_FRONT_AND_BACK")) + ((BACK) (C-enum "GL_BACK")) (else (error "Unknown glColorMaterial face:" face))) (case mode + ((EMISSION) (C-enum "GL_EMISSION")) + ((AMBIENT) (C-enum "GL_AMBIENT")) ((DIFFUSE) (C-enum "GL_DIFFUSE")) + ((SPECULAR) (C-enum "GL_SPECULAR")) + ((AMBIENT-AND-DIFFUSE) (C-enum "GL_AMBIENT_AND_DIFFUSE")) (else (error "Unknown glColorMaterial mode:" mode))))) (define (gl:clear . bits) @@ -115,10 +154,6 @@ USA. (guarantee-current 'GL:LOAD-IDENTITY) (C-call "glLoadIdentity")) -(define (glu:look-at position aim up) - (guarantee-current 'GL:LOOK-AT) - (C-call "glu_look_at" position aim up)) - (define (gl:scale kx ky kz) (guarantee-current 'GL:SCALE) (guarantee-flonum kx 'GL:SCALE) @@ -130,9 +165,16 @@ USA. (guarantee-current 'GL:BEGIN) (C-call "glBegin" (case mode - ((QUAD-STRIP) (C-enum "GL_QUAD_STRIP")) - ((QUADS) (C-enum "GL_QUADS")) + ((POINTS) (C-enum "GL_POINTS")) ((LINES) (C-enum "GL_LINES")) + ((LINE-LOOP) (C-enum "GL_LINE_LOOP")) + ((LINE-STRIP) (C-enum "GL_LINE_STRIP")) + ((TRIANGLES) (C-enum "GL_TRIANGLES")) + ((TRIANGLE-STRIP) (C-enum "GL_TRIANGLE_STRIP")) + ((TRIANGLE-FAN) (C-enum "GL_TRIANGLE_FAN")) + ((QUADS) (C-enum "GL_QUADS")) + ((QUAD-STRIP) (C-enum "GL_QUAD_STRIP")) + ((POLYGON) (C-enum "GL_POLYGON")) (else (error "Unknown glBegin mode:" mode))))) (define (gl:color color) @@ -142,7 +184,7 @@ USA. (define (gl:vertex point) (guarantee-current 'GL:VERTEX) - (guarantee-3d-point point 'GL:VERTEX) + (guarantee-3d point 'GL:VERTEX) (C-call "gl_vertex" point)) (define (gl:end) @@ -182,24 +224,80 @@ USA. (C-call "gl_light" (case light ((LIGHT0) (C-enum "GL_LIGHT0")) + ((LIGHT1) (C-enum "GL_LIGHT1")) + ((LIGHT2) (C-enum "GL_LIGHT2")) + ((LIGHT3) (C-enum "GL_LIGHT3")) + ((LIGHT4) (C-enum "GL_LIGHT4")) + ((LIGHT5) (C-enum "GL_LIGHT5")) + ((LIGHT6) (C-enum "GL_LIGHT6")) + ((LIGHT7) (C-enum "GL_LIGHT7")) (else (error "gl:light: Unknown light:" light))) (case param ((POSITION) (guarantee-4d values 'GL:LIGHT) (C-enum "GL_POSITION")) + ((AMBIENT) + (guarantee-4d values 'GL:LIGHT) + (C-enum "GL_AMBIENT")) + ((DIFFUSE) + (guarantee-4d values 'GL:LIGHT) + (C-enum "GL_DIFFUSE")) + ((SPECULAR) + (guarantee-4d values 'GL:LIGHT) + (C-enum "GL_SPECULAR")) (else (error "gl:light: Unknown parameter:" param))) values)) +(define (gl:light-model param value) + (case param + ((LOCAL-VIEWER) + (guarantee-flonum value 'gl:light-model) + (C-call "glLightModelf" (C-enum "GL_LIGHT_MODEL_LOCAL_VIEWER") value)) + ((COLOR-CONTROL) + (C-call "glLightModeli" (C-enum "GL_LIGHT_MODEL_COLOR_CONTROL") + (case value + ((SEPARATE-SPECULAR-COLOR) (C-enum "GL_SEPARATE_SPECULAR_COLOR")) + ((SINGLE-COLOR) (C-enum "GL_SINGLE_COLOR")) + (else (error "gl:light-model: Unknown color-control:" value))))) + ((TWO-SIDE) + (guarantee-flonum value 'gl:light-model) + (C-call "glLightModelf" (C-enum "GL_LIGHT_MODEL_TWO_SIDE") value)) + ((AMBIENT) + (guarantee-4d value 'gl:light-model) + (C-call "gl_light_model_v" (C-enum "GL_LIGHT_MODEL_AMBIENT") value)) + (else + (error "gl:light-model: Unknown parameter:" param)))) + (define (gl:material face param values) (guarantee-current 'GL:MATERIAL) (C-call "gl_material" (case face ((FRONT) (C-enum "GL_FRONT")) + ((BACK) (C-enum "GL_BACK")) + ((FRONT-AND-BACK) (C-enum "GL_FRONT_AND_BACK")) (else (error "gl:material: Unknown face:" face))) (case param + ((AMBIENT) + (guarantee-4d values 'GL:MATERIAL) + (C-enum "GL_AMBIENT")) + ((DIFFUSE) + (guarantee-4d values 'GL:MATERIAL) + (C-enum "GL_DIFFUSE")) + ((SPECULAR) + (guarantee-4d values 'GL:MATERIAL) + (C-enum "GL_SPECULAR")) + ((EMISSION) + (guarantee-4d values 'GL:MATERIAL) + (C-enum "GL_EMISSION")) + ((SHININESS) + (guarantee-flonum values 'GL:MATERIAL) + (C-enum "GL_SHININESS")) ((AMBIENT-AND-DIFFUSE) (guarantee-4d values 'GL:MATERIAL) (C-enum "GL_AMBIENT_AND_DIFFUSE")) + ((COLOR-INDEXES) + (guarantee-3d values 'GL:MATERIAL) + (C-enum "GL_COLOR_INDEXES")) (else (error "gl:material: Unknown parameter:" param))) values)) @@ -231,7 +329,7 @@ USA. (define (gl:normal 3d) (guarantee-current 'GL:NORMAL) - (guarantee-3d-point 3d 'GL:NORMAL) + (guarantee-3d 3d 'GL:NORMAL) (C-call "gl_normal" 3d)) (define (gl:pop-matrix) @@ -267,6 +365,14 @@ USA. (define (gl:flush) (guarantee-current 'GL:FLUSH) (C-call "glFlush")) + +(define (glu:look-at position aim up) + (guarantee-current 'GL:LOOK-AT) + (C-call "glu_look_at" position aim up)) + +(define (glu:perspective fovy aspect z-near z-far) + (guarantee-current 'GL:PERSPECTIVE) + (C-call "gluPerspective" fovy aspect z-near z-far)) (define gl-library-mutex) @@ -302,14 +408,14 @@ USA. (<= 0.0 object) (<= object 1.0))) (error:wrong-type-argument object "a GL depth" operator))) -(define (guarantee-3d-point object operator) +(define (guarantee-3d object operator) (if (not (and (flo:flonum? object) (fix:= 3 (flo:vector-length object)))) - (error:wrong-type-argument object "a 3d point" operator))) + (error:wrong-type-argument object "three flonums" operator))) (define (guarantee-4d object operator) (if (not (and (flo:flonum? object) (fix:= 4 (flo:vector-length object)))) - (error:wrong-type-argument object "a 4d point" operator))) + (error:wrong-type-argument object "four flonums" operator))) (initialize-package!) \ No newline at end of file