;;;; Run the GLXGears demo.
+(load-option 'CREF)
+(load-option 'SOS)
+(load-option 'FFI)
(load-option 'GTK)
(if (gtk-thread-running?)
/* Adapters for the GL graphics library. */
-#include "gl-shim.h"
#include <GL/glu.h>
#include <gdk/gdkx.h>
#include <malloc.h>
#include <mit-scheme.h>
+#include "gl-shim.h"
void
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)
{
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)
{
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)
}
}
-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)));
}
(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 ()
(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 (<glx-widget> (constructor %make-glx-widget () (width height)))
+(define-class (<glx-widget> (constructor () (width height)))
(<fix-widget>)
(xdisplay define standard
(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)
(call-next-method widget))
(define-method fix-widget-realize-callback ((widget <glx-widget>))
- (%trace "; (fix-widget-realize-callback <glx-widget>) "widget"\n")
(let* ((GtkWidget (gobject-alien widget))
(parent
(C-call "gtk_widget_get_parent_window" (make-alien '|GdkWindow|)
(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)))
(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)
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*))))))
\f
-(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 (<glx-viewport> (constructor (draw) (width height)))
- ;; A <glx-widget> 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 (<glx-viewport> (constructor () (width height)))
+ ;; A <glx-widget> with camera parameters, and a default key-press
+ ;; handler to fly the camera.
(<glx-widget>)
- (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 <glx-viewport>) 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 <glx-viewport>))
+ (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 <glx-viewport>) key bits)
(%trace "; (key-press <glx-viewport>) "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)
;; 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
(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.)))
#include <gtk/gtk.h>
#include <GL/glx.h>
-/* #include <GL/glu.h> for gluLookAt, which doesn't need a declaration(?) */
+#include <GL/glu.h>
+
+/* 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
(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)
(extern void glColorMaterial (face GLenum) (mode GLenum))
-(enum (GL_DIFFUSE))
-
(extern void glClear (mask GLbitfield))
(enum (GL_COLOR_BUFFER_BIT)
(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))
(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))
(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))
\f
(typedef GLXFBConfig (* (struct __GLXFBConfigRec)))
(typedef GLXContext (* (struct __GLXcontextRec)))
(typedef GLXPixmap XID)
+(typedef GLXWindow XID)
(typedef GLXDrawable XID)
#;(extern (* GLXFBConfig) glXChooseFBConfig
(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)))
\f
+(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
(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)))
(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
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
gl:frustum
gl:gen-lists
gl:light
+ gl:light-model
gl:material
gl:matrix-mode
gl:new-list
gl:rotate
gl:translate
gl:viewport
- gl:flush))
+ gl:flush
+ glu:look-at
+ glu:perspective))
(define-package (gl internals glx)
(parent (gl internals))
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
gtk-widget-show-all
<fix-widget>
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 <glx-widget>
- with-glx-viewport <glx-viewport>))
+ make-glx-widget <glx-widget>
+ with-glx-widget glx:swap-buffers
+ make-glx-viewport <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")
((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))))
((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"
(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)
(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)
(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)
(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)
(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))
(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)
(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))
\f
(define gl-library-mutex)
(<= 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
projects / mit-scheme.git / commitdiff