--- /dev/null
+# Copyright (C) 2011, 2012, 2013 Matthew Birkholz
+#
+# This file is part of an extension to MIT/GNU Scheme.
+#
+# MIT/GNU Scheme is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+exe = '$(MIT_SCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+all: gl-shim.so gl-types.bin gl-const.bin
+ echo '(load "compile")' | $(exe)
+ @if [ -s gl-unx.crf ]; then \
+ echo "gl-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check: glxgears
+ echo '(load "check")' | $(exe)
+
+glxgears: glxgears-shim.so glxgears-types.bin glxgears-const.bin
+ echo '(load "glxgears-compile")' | $(exe)
+ @if [ -s glxgears-unx.crf ]; then \
+ echo "glxgears-unx.crf:0: warning: non-empty"; exit 1; fi
+
+doc: mit-scheme-gl.info
+doc: mit-scheme-gl.html
+
+mit-scheme-gl.info: gl.texinfo
+ makeinfo --no-split --output=$@ $^
+
+mit-scheme-gl.html: gl.texinfo
+ makeinfo --html --no-split --output=$@ $^
+
+.PHONY: all check doc
+
+install:
+ ( echo '(begin'; \
+ echo ' (install-shim "$(DESTDIR)" "gl")'; \
+ echo ' (install-load-option "$(DESTDIR)" "gl"))' ) \
+ | $(exe) -- gl gl-glx gl-glxgears *.pkd make.scm
+
+# install-doc:
+# echo '(install-info "gl")' | $(exe)
+# echo '(install-html "gl")' | $(exe)
+
+.PHONY: install
+
+clean:
+ rm -f gl-const.scm gl-const gl-const.c gl-shim.c
+ rm -f glxgears-const.scm glxgears-const glxgears-const.c glxgears-shim.c
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd
+ rm -f mit-scheme-gl.html mit-scheme-gl.info
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+tags:
+ etags *.h \
+ `echo *.c | sed 's/ gl-const.c//; s/ gl-shim.c//'` \
+ `echo *.scm | sed 's/ gl-const.scm//'` gl.cdecl
+
+.PHONY: clean distclean maintainer-clean tags
+
+gl-shim.so: gl-shim.o gl-adapter.o
+ echo "(link-shim)" \
+ | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
+ `pkg-config --libs gl glu gtk+-3.0`
+
+gl-adapter.o: gl-adapter.c gl-shim.h
+ echo '(compile-shim)' \
+ | $(exe) -- $(CPPFLAGS) `pkg-config --cflags gl gtk+-3.0` \
+ $(CFLAGS) -c $<
+
+gl-shim.o: gl-shim.c gl-shim.h
+ echo "(compile-shim)" \
+ | $(exe) -- $(CPPFLAGS) `pkg-config --cflags gl gtk+-3.0` \
+ $(CFLAGS) -c $<
+
+gl-shim.c gl-const.c gl-types.bin: gl-shim.h gl.cdecl
+ echo '(generate-shim "gl" "#include \"gl-shim.h\"")' | $(exe)
+
+gl-const.bin: gl-const.scm
+ echo '(sf "gl-const")' | $(exe)
+
+gl-const.scm: gl-const
+ ./gl-const
+
+gl-const: gl-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS) `pkg-config --libs gl gtk+-3.0`
+
+gl-const.o: gl-const.c gl-shim.h
+ $(CC) `pkg-config --cflags gl gtk+-3.0` $(CPPFLAGS) $(CFLAGS) -c $<
+\f
+glxgears-shim.so: glxgears-shim.o
+ echo "(link-shim)" \
+ | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) `pkg-config --libs gl glu x11`
+
+glxgears-shim.o: glxgears-shim.c glxgears-shim.h
+ echo "(compile-shim)" \
+ | $(exe) -- $(CPPFLAGS) `pkg-config --cflags gl glu x11` \
+ $(CFLAGS) -c $<
+
+glxgears-shim.c glxgears-const.c glxgears-types.bin: glxgears-shim.h glxgears.cdecl
+ echo '(generate-shim "glxgears" "#include \"glxgears-shim.h\"")' \
+ | $(exe)
+
+glxgears-const.bin: glxgears-const.scm
+ echo '(sf "glxgears-const")' | $(exe)
+
+glxgears-const.scm: glxgears-const
+ ./glxgears-const
+
+glxgears-const: glxgears-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS) `pkg-config --libs gl glu x11`
+
+glxgears-const.o: glxgears-const.c glxgears-shim.h
+ $(CC) $(CPPFLAGS) `pkg-config --cflags gl glu x11` $(CFLAGS) -c $<
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Run the GLXGears demo.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load-package-set "glxgears")
+ ((access main (->environment '(gl glxgears))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compile the GL wrapper.
+
+(load-option 'CREF)
+(load-option 'SOS)
+(load-option 'FFI)
+(load-option 'GTK)
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (with-system-library-directories
+ '("./")
+ (lambda ()
+ (if (name->package '(GL))
+ (error "The GL package already exists.")
+ (let ((package-set (package-set-pathname "gl")))
+ (if (not (file-modification-time<? "gl.pkg" package-set))
+ (cref/generate-trivial-constructor "gl"))
+ (construct-packages-from-file (fasload package-set))))
+
+ (let ((deps '("gl-const.bin"))
+ (internals (->environment '(gl internals)))
+ (glx (->environment '(gl internals glx)))
+ (glxgears (->environment '(gl glxgears))))
+ (compile-file "gl" deps internals)
+ (load "gl" internals)
+ (compile-file "gl-glx" deps glx)
+ (load "gl-glx" glx)
+ (compile-file "gl-glxgears" deps glxgears)
+ (load "gl-glxgears" glxgears))))
+ (cref/generate-constructors "gl" 'ALL)))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme gl interface],
+ [0.1],
+ [puck@birchwood-abbey.net],
+ [mit-scheme-gl])
+AC_CONFIG_SRCDIR([gl.pkg])
+
+AC_COPYRIGHT(
+[Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+])
+
+AH_TOP([/*
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/])
+
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+
+if ! pkg-config --exists gl 2>/dev/null; then
+ AC_ERROR([libGL not found.])
+fi
+
+AC_SUBST([CFLAGS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_SUBST([LIBS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* 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>
+
+void
+gl_clear_color (SCM color)
+{
+ glClearColor (flovec_ref (color, 0),
+ flovec_ref (color, 1),
+ flovec_ref (color, 2),
+ 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)
+{
+ glColor4dv (flovec_loc (color));
+}
+
+void
+gl_vertex (SCM point)
+{
+ glVertex3dv (flovec_loc (point));
+}
+
+void
+gl_light (GLenum light, GLenum pname, SCM 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);
+ }
+ glLightfv (light, pname, fvec);
+ free (fvec);
+}
+
+void
+gl_material (GLenum face, GLenum pname, SCM 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);
+ }
+ glMaterialfv (face, pname, fvec);
+ free (fvec);
+}
+
+void
+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)
+{
+ return (GDK_WINDOW_XID (window));
+}
+
+#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));
+}
+
+void
+glx_destroy_window (Display *dpy, GLXWindow *win)
+{
+ /* Expect win is an XID, *not* the address of an XID. See
+ glx_create_window. */
+ glXDestroyWindow (dpy, ((XID)win));
+}
+#endif
+
+static int
+gdk_visual_get_visual_class (GdkVisual *v)
+{
+ GdkVisualType type = gdk_visual_get_visual_type (v);
+ switch (type)
+ {
+ case GDK_VISUAL_STATIC_GRAY:
+ return (StaticGray);
+ case GDK_VISUAL_GRAYSCALE:
+ return (GrayScale);
+ case GDK_VISUAL_STATIC_COLOR:
+ return (StaticColor);
+ case GDK_VISUAL_PSEUDO_COLOR:
+ return (PseudoColor);
+ case GDK_VISUAL_TRUE_COLOR:
+ return (TrueColor);
+ case GDK_VISUAL_DIRECT_COLOR:
+ return (DirectColor);
+ }
+}
+
+GdkVisual*
+glx_find_gdkvisual (GdkWindow *window, XVisualInfo *visinfo)
+{
+ 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);
+}
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; A few GLX wraps.
+;;; package: (gl glx)
+
+(C-include "gl")
+
+(define (make-glx-device width height title)
+ (let ((window (gtk-window-new 'toplevel)))
+ (gtk-window-set-opacity window 1.0)
+ (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-device widget thunk)
+ (with-gl-library
+ (lambda ()
+ (let ((xdisplay (glx-widget-xdisplay widget))
+ (xwindow (glx-widget-xwindow widget))
+ (glxcontext (glx-widget-glxcontext widget)))
+ (if (zero? (C-call "glXMakeCurrent" xdisplay xwindow glxcontext))
+ (error "glXMakeCurrent failed"))
+ (let ((value (thunk)))
+ (if (zero? (C-call "glXMakeCurrent" xdisplay (C-enum "None") 0))
+ (error "glXMakeCurrent NULL failed"))
+ value)))))
+
+(define (glx:swap-buffers widget)
+ (let ((xdisplay (glx-widget-xdisplay widget))
+ (xwindow (glx-widget-xwindow widget)))
+ (%trace2 "; glx:swap-buffers "xdisplay" "xwindow"\n")
+ (C-call "glXSwapBuffers" xdisplay xwindow)))
+\f
+#| Replace gdk_window_new with XCreateWindow, following example of
+ <fix-widget>.
+
+ (define-class (<glx-widget> (constructor () (width height)))
+ (<scm-widget>)
+
+ ;; Our xwindow. Until realized, a NULL pointer.
+ (xwindow define accessor
+ initializer (lambda () (make-alien '|Window|)))
+
+ ;; Our window geometry (allocation) -- a rectangular extent in
+ ;; fixnum device coordinates (e.g. size in pixels, offset within
+ ;; parent window [ancestor widget]).
+ (geometry define accessor initializer (lambda () (make-fix-rect)))
+
+ (event-handlers define accessor initializer
+ (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))
+
+ ;; Used by glXfunctions.
+ (display define standard
+ initializer (lambda () (make-alien '|Display|)))
+ (glxwindow define standard
+ ;; This alien's address is the GLXWindow XID.
+ initializer (lambda () (make-alien 'XID)))
+ (glxcontext define standard
+ initializer (lambda () (make-alien '(struct |__GLXcontextRec|)))))
+
+ (define-guarantee glx-widget "a <glx-widget>")
+
+ (define-integrable guarantee-size guarantee-non-negative-fixnum)
+
+ (define-method initialize-instance ((widget <glx-widget>) width height)
+ (call-next-method widget)
+ (%trace "; (initialize-instance <glx-widget>) "widget" "width"x"height"\n")
+ (set-scm-widget-natural-size! widget width height)
+ ;; Init. size, for a realize signal arriving before an allocation.
+ (flo:vector-set! (glx-widget-geometry widget) 2 width)
+ (flo:vector-set! (glx-widget-geometry widget) 3 height)
+ (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1)
+
+ (set-gtk-widget-realize-callback! widget glx-widget-realize-callback)
+ (set-gtk-widget-size-allocate-callback! widget glx-widget-allocate-callback)
+ (set-gtk-widget-event-callback! widget glx-widget-event-callback))
+
+ (define (glx-widget-realize-callback widget)
+ (%trace "; glx-widget-realize-callback "widget"\n")
+ (let* ((GtkWidget (gobject-alien widget))
+ (parent-GdkWindow
+ (C-call "gtk_widget_get_parent_window" (make-alien '|GdkWindow|)
+ GtkWidget)))
+ (error-if-null parent-GdkWindow "Could not get parent:" widget)
+
+ ;; Create widget xwindow.
+ (let* ((display (C-call "gdk_window_xdisplay" (make-alien '|Display|)
+ parent-GdkWindow))
+ (screen-num (C-call "gdk_window_screen_num" parent-GdkWindow))
+ #;(fb-configs (or (choose-fb-config
+ display screen-num
+ (list (C-enum "GLX_DEPTH_SIZE")
+ 1
+ (C-enum "GLX_DOUBLEBUFFER")
+ (C-enum "GLX_NONE")))
+ (choose-fb-config
+ display screen-num
+ (list (C-enum "GLX_DEPTH_SIZE")
+ 1
+ (C-enum "GLX_NONE")))
+ (error "Could not find suitable GLXFBConfigs.")))
+ #;(fb-config (C-> fb-configs "GLXFBConfig"
+ (make-alien '(struct |__GLXFBConfigRec|))))
+ (parent-Window (C-call "gdk_window_Window" parent-GdkWindow))
+ (attribs (make-attribs
+ `(
+ ;; Singleton attributes.
+ ,(C-enum "GLX_RGBA")
+ ,(C-enum "GLX_DOUBLEBUFFER")
+
+ ;; Key/value attributes.
+ ,(C-enum "GLX_RED_SIZE") 1
+ ,(C-enum "GLX_GREEN_SIZE") 1
+ ,(C-enum "GLX_BLUE_SIZE") 1
+ ,(C-enum "GLX_DEPTH_SIZE") 1
+
+ ,(C-enum "None"))))
+ (visinfo (C-call "glXChooseVisual" (make-alien '|XVisualInfo|)
+ display screen-num attribs)))
+ #;(xfree fb-configs)
+ (free attribs)
+ (let ((visual #;(let ((alien (malloc (C-sizeof "int") 'int)))
+ (C-call "glXGetFBConfigAttrib" display fb-config
+ (C-enum "GLX_VISUAL_ID") alien)
+ (let ((value (C-> alien "int")))
+ (free alien)
+ value))
+ (C-> visinfo "XVisualInfo visual"))
+ (depth #;(... (C-call "glXGetFBConfigAttrib"...
+ "GLX_VISUAL_DEPTH"???...)... )
+ (C-> visinfo "XVisualInfo depth"))
+ (geometry (glx-widget-geometry widget))
+ (attr (malloc (C-sizeof "XSetWindowAttributes")
+ '|XSetWindowAttributes|))
+ (xwindow (glx-widget-xwindow widget))
+ (mask (bit-ior (C-enum "CWBackPixel")
+ (C-enum "CWBorderPixel")
+ (C-enum "CWColormap")
+ (C-enum "CWEventMask"))))
+ (C->= attr "XSetWindowAttributes background_pixel" 0)
+ (C->= attr "XSetWindowAttributes border_pixel" 0)
+ (let ((colormap (C-call "XCreateColormap" display parent-Window
+ visual (C-enum "AllocNone"))))
+ (%trace ";XCreateColormap => "colormap"\n")
+ (C->= attr "XSetWindowAttributes colormap" colormap))
+ (C->= attr "XSetWindowAttributes event_mask"
+ (bit-ior (C-enum "StructureNotifyMask")
+ (C-enum "ExposureMask")
+ (C-enum "KeyPressMask")
+ #;ALL-EVENTS-AND-DELIVERED-HOW???))
+ (let ((win (C-call "x_create_window" display root
+ (fix-rect-x geometry)
+ (fix-rect-y geometry)
+ (fix-rect-width geometry)
+ (fix-rect-height geometry)
+ 0 ;pixmap
+ depth
+ (C-enum "InputOutput") ;type
+ visual
+ mask
+ attr)))
+ (%trace ";XCreateWindow => "win"\n")
+ (error-if-null win "Could not create GLX window:" widget)
+ ;;(C-call "gtk_widget_set_window" GtkWidget main-GdkWindow)
+ ;;(C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
+ (%trace "; xwindow: "win"\n"))))
+
+ (define (allocate-callback widget GtkAllocation)
+ (let ((x (C-> GtkAllocation "GtkAllocation x"))
+ (y (C-> GtkAllocation "GtkAllocation y"))
+ (width (C-> GtkAllocation "GtkAllocation width"))
+ (height (C-> GtkAllocation "GtkAllocation height"))
+ (rect (gtk-widget-geometry widget)))
+ (%trace "; allocated "width"x"height" at "x","y" for "widget"\n")
+ (C-call "gtk_widget_set_allocation" (gobject-alien widget) GtkAllocation)
+ (set-fix-rect! rect x y width height)
+ (if (gtk-widget-realized? widget)
+ (C-call "gdk_window_move_resize"
+ (gtk-widget-window widget)
+ x y width height))))
+
+ (define (gtk-widget-realized? widget)
+ (not (alien-null? (gtk-widget-window widget))))
+|#
+(define-class (<glx-widget> (constructor () (width height)))
+ (<fix-widget>)
+
+ (xdisplay define standard
+ initializer (lambda () (make-alien '|Display|)))
+ (xwindow define standard initial-value #f)
+ (glxcontext define standard
+ initializer (lambda () (make-alien '(struct |__GLXcontextRec|)))))
+
+(define-method initialize-instance ((widget <glx-widget>) width height)
+ (call-next-method widget width height)
+ (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)))
+
+(define (make-glx-widget-cleanup display context)
+ (named-lambda (glx-widget-cleanup)
+ (cleanup-glx-widget display context)))
+
+(define (cleanup-glx-widget xdisplay glxcontext)
+ ;;without-interrupts
+ (if (not (alien-null? glxcontext))
+ (begin
+ (C-call "glXDestroyContext" xdisplay glxcontext)
+ (alien-null! glxcontext))))
+
+(define-method gtk-widget-destroy-callback ((widget <glx-widget>))
+ (without-interrupts
+ (lambda ()
+ (punt-gc-cleanup widget)
+ (cleanup-glx-widget (glx-widget-xdisplay widget)
+ (glx-widget-glxcontext widget))))
+ (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|)
+ GtkWidget)))
+ (error-if-null parent "Could not get parent:" widget)
+
+ ;; Create widget GdkWindow.
+ (let ((xdisplay (C-call "gdk_window_xdisplay" (glx-widget-xdisplay widget)
+ parent))
+ (screen-num (C-call "gdk_window_screen_num" parent))
+ (attribs (make-attribs
+ `(
+ ;; Singleton attributes.
+ ,(C-enum "GLX_RGBA")
+ ,(C-enum "GLX_DOUBLEBUFFER")
+
+ ;; Key/value attributes.
+ ,(C-enum "GLX_RED_SIZE") 1
+ ,(C-enum "GLX_GREEN_SIZE") 1
+ ,(C-enum "GLX_BLUE_SIZE") 1
+ ,(C-enum "GLX_DEPTH_SIZE") 1
+
+ ,(C-enum "None")))))
+ (let ((visinfo (C-call "glXChooseVisual" (make-alien '|XVisualInfo|)
+ xdisplay screen-num attribs)))
+ (free attribs)
+ (let ((gdkvisual (C-call "glx_find_gdkvisual" (make-alien '|GdkVisual|)
+ parent visinfo))
+ (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|))
+ (GdkWindow (fix-widget-window widget)))
+ (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD"))
+ (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT"))
+ (C->= attr "GdkWindowAttr visual" gdkvisual)
+ (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK"))
+ (let ((geometry (fix-widget-geometry widget)))
+ (let ((x (fix-rect-x geometry))
+ (y (fix-rect-y geometry))
+ (width (fix-rect-width geometry))
+ (height (fix-rect-height geometry)))
+ (if x (C->= attr "GdkWindowAttr x" x))
+ (if y (C->= attr "GdkWindowAttr y" y))
+ (C->= attr "GdkWindowAttr width" width)
+ (C->= attr "GdkWindowAttr height" height)
+ (C-call "gdk_window_new" GdkWindow parent attr
+ (bit-ior (if x (C-enum "GDK_WA_X") 0)
+ (if y (C-enum "GDK_WA_Y") 0)
+ (C-enum "GDK_WA_VISUAL")))))
+ (error-if-null GdkWindow "Could not create GdkWindow:" widget)
+ (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")))))
+
+ (C-call "gtk_widget_set_can_focus" GtkWidget 1)))
+
+(declare (integrate-operator bit-ior))
+(define (bit-ior . ints)
+ (reduce bitwise-ior 0 ints))
+
+#;(define (choose-fb-config display screen-num attrib-list)
+ (let ((configs (make-alien '|GLXFBConfig|))
+ (copy (make-alien '|GLXFBConfig|))
+ (attribs (make-attribs attrib-list))
+ (num-configs (malloc (C-sizeof "int") 'int)))
+ (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)
+ (begin
+ (punt-gc-cleanup configs)
+ #f)
+ (begin
+ (copy-alien-address! configs copy)
+ configs))))
+
+#;(define (make-fb-configs-cleanup alien)
+ (named-lambda (fb-configs-cleanup)
+ (cleanup-fb-configs alien)))
+
+#;(define (cleanup-fb-configs alien)
+ ;;without-interrupts
+ (if (not (alien-null? alien))
+ (begin
+ (C-call "XFree" alien)
+ (alien-null! alien))))
+
+#;(define (xfree alien)
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? alien))
+ (let ((cleanup (punt-gc-cleanup alien)))
+ (if cleanup (cleanup))
+ (alien-null! alien))))))
+
+(define (make-attribs attribs)
+ (let* ((len (length attribs))
+ (alien (malloc (* len (C-sizeof "int")) '|int|)))
+ (do ((attribs attribs (cdr attribs))
+ (i 0 (fix:1+ i)))
+ ((fix:= i len))
+ (let ((attrib (car attribs)))
+ (guarantee-integer attrib 'make-attribs)
+ ((ucode-primitive c-poke-int 3)
+ alien
+ (fix:* i (C-sizeof "int"))
+ 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 (%trace . objects)
+ (for-each display objects))
+
+(define (%trace2 . objects)
+ (declare (ignore objects))
+ unspecific)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; The GLX Gears Demo
+
+;;(declare (no-type-checks) (no-range-checks))
+
+#;(declare (reduce-operator (sin flo:sin)
+ (cos flo:cos)
+ (sqrt flo:sqrt)
+ (= flo:=)
+ (< flo:<)
+ (> flo:>)
+ (+ flo:+)
+ (- flo:- (null-value 0. single) (group left))
+ (* flo:*)
+ (/ flo:/ (null-value 1. single) (group left))))
+
+(define (make-glxgears-demo)
+ (let ((dev (make-glxgears-demo-device 400 400 "glxgears.scm")))
+ (set-gtk-widget-unrealize-callback! dev unrealize-callback)
+ (set-gtk-widget-draw-callback! dev draw-callback)
+ (set-fix-widget-map-handler! dev map-handler)
+ (set-fix-widget-unmap-handler! dev unmap-handler)
+ (set-fix-widget-enter-notify-handler! dev enter-notify-handler)
+ (set-fix-widget-leave-notify-handler! dev leave-notify-handler)
+ (set-fix-widget-focus-change-handler! dev focus-change-handler)
+ (set-fix-widget-visibility-notify-handler! dev visibility-notify-handler)
+ (set-fix-widget-key-press-handler! dev key-press-handler)
+ (set-fix-widget-motion-handler! dev motion-handler)
+ (set-fix-widget-button-handler! dev 'press button-handler)
+ (set-fix-widget-button-handler! dev 'release button-handler)
+ (set-fix-widget-button-handler! dev 'double-press button-handler)
+ (set-fix-widget-button-handler! dev 'triple-press button-handler)
+ dev))
+
+(define (make-glxgears-demo-device width height title)
+ (let ((window (gtk-window-new 'toplevel)))
+ (gtk-window-set-opacity window 1.0)
+ (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-glxgears-demo width height)))
+ (gtk-container-add window widget)
+ (gtk-widget-show-all window)
+ widget)))
+
+(define-class (<glxgears-demo>
+ (constructor %make-glxgears-demo () (width height)))
+ (<glx-widget>)
+ (view-rotx define standard initial-value 20.)
+ (view-roty define standard initial-value 30.)
+ (angle define standard initial-value 0.)
+ (gears define standard initial-value #f)
+
+ (shape define standard initial-value '(0 . 0))
+ (mapped? define standard initial-value #f)
+ (animate? define standard initial-value #f)
+ (animation-thread define standard)
+ (animation-halt define standard)
+ ;; For smooth rotation at any frame rate?
+ (frame-start define standard initial-value #f)
+
+ ;; For frame rate reports:
+ (frame-count define standard initial-value 0)
+ (frame-count-start define standard initial-value #f))
+
+(define-method initialize-instance ((widget <glxgears-demo>) width height)
+ (call-next-method widget width height)
+ (make-animation-thread widget))
+
+(define-method fix-widget-new-geometry-callback ((widget <glxgears-demo>))
+ (%trace "; (fix-widget-new-geometry-callback <glxgears-demo>)\n")
+ (wake-animation-thread widget))
+
+(define (unrealize-callback widget)
+ (for-each display (list "; unrealize-callback"
+ " "widget" "(gtk-widget-destroyed? widget)"\n"))
+ ;; Is this necessary when the context is about to be (already?) destroyed?
+ #;(let ((gears (glxgears-demo-gears widget)))
+ (with-glx-device widget
+ (lambda ()
+ (gl:delete-lists (car gears) 1)
+ (gl:delete-lists (cadr gears) 1)
+ (gl:delete-lists (caddr gears) 1))))
+ (halt-animation-thread widget))
+
+(define (draw-callback widget area)
+ (%trace "; draw-callback "widget" "area"\n"))
+
+(define (map-handler widget)
+ (%trace "; map-handler "widget"\n")
+ (set-glxgears-demo-mapped?! widget #t)
+ (wake-animation-thread widget)
+ #f)
+
+(define (unmap-handler widget)
+ (%trace "; unmap-handler "widget"\n")
+ (set-glxgears-demo-mapped?! widget #f)
+ #f)
+
+(define (enter-notify-handler widget)
+ (%trace "; enter-notify-handler "widget"\n")
+ #f)
+
+(define (leave-notify-handler widget)
+ (%trace "; leave-notify-handler "widget"\n")
+ #f)
+
+(define (focus-change-handler widget in?)
+ (%trace "; focus-change-handler "widget" "in?"\n")
+ #f)
+
+(define (visibility-notify-handler widget how)
+ (%trace "; visibility-notify-handler "widget" "how"\n")
+ #f)
+
+(define (key-press-handler widget key bits)
+ (%trace "; key-press-handler "widget" "key" "bits"\n")
+ ;;(declare (ignore bits))
+ (case key
+ ((#\escape) (gtk-widget-destroy (gtk-widget-parent widget)))
+ ((#\a) (if (glxgears-demo-animate? widget)
+ (set-glxgears-demo-animate?! widget #f)
+ (begin
+ (set-glxgears-demo-animate?! widget #t)
+ (wake-animation-thread widget))))
+ ((|Up|) (rotx! widget 5.) (wake-animation-thread widget))
+ ((|Down|) (rotx! widget -5.) (wake-animation-thread widget))
+ ((|Left|) (roty! widget 5.) (wake-animation-thread widget))
+ ((|Right|) (roty! widget -5.) (wake-animation-thread widget)))
+ #t)
+
+(define-integrable (rotx! widget incr)
+ (set-glxgears-demo-view-rotx!
+ widget (+ incr (glxgears-demo-view-rotx widget))))
+
+(define-integrable (roty! widget incr)
+ (set-glxgears-demo-view-roty!
+ widget (+ incr (glxgears-demo-view-roty widget))))
+
+(define (motion-handler widget modifiers x y)
+ (%trace ";motion-handler "widget" "modifiers" "x"x"y"\n")
+ #f)
+
+(define (button-handler widget name button modifiers x y)
+ (%trace ";button-handler "widget" "name" "button" "modifiers" "x"x"y"\n")
+ #f)
+
+(define (make-animation-thread widget)
+ (let ((thread
+ (create-thread
+ #f
+ (lambda ()
+ (call-with-current-continuation
+ (lambda (halt)
+ (set-glxgears-demo-animation-halt! widget halt)
+ (let loop ()
+
+ ;; Sleep when not animate? nor mapped?.
+ (without-interrupts
+ (lambda ()
+ (if (or (not (glxgears-demo-mapped? widget))
+ (not (glxgears-demo-animate? widget)))
+ (begin
+ (display ";glxgears: sleeping...\n")
+ (suspend-current-thread)
+ (display ";glxgears: ...awake!\n")))))
+
+ (if (not (glxgears-demo-mapped? widget))
+ (display ";glxgears: not mapped\n")
+ (begin
+ ;; Init, if necessary.
+ (if (not (glxgears-demo-gears widget))
+ (init widget))
+
+ ;; Draw.
+ (draw-frame widget)))
+ (loop))))
+ (display ";glxgears: done\n")))))
+ (set-glxgears-demo-animation-thread! widget thread)
+ (detach-thread thread)
+ thread))
+
+(define (wake-animation-thread widget)
+ (signal-thread-event
+ (glxgears-demo-animation-thread widget)
+ (lambda () unspecific)))
+
+(define (halt-animation-thread widget)
+ (signal-thread-event
+ (glxgears-demo-animation-thread widget)
+ (lambda ()
+ ((glxgears-demo-animation-halt widget) unspecific))))
+
+(define (draw-frame widget)
+ (%trace "; draw-frame\n")
+
+ (if (glxgears-demo-animate? widget)
+ (let ((now (real-time-clock))
+ (start (glxgears-demo-frame-start widget))
+ (count (glxgears-demo-frame-count widget))
+ (angle (glxgears-demo-angle widget)))
+ (set-glxgears-demo-frame-start! widget now)
+ (set-glxgears-demo-angle! widget
+ (let ((dt (if (not start)
+ 0.
+ (internal-time/ticks->seconds
+ (- now start)))))
+ (+ angle (* 70. dt))))
+ (set-glxgears-demo-frame-count! widget (1+ count))))
+ (with-glx-device widget
+ (lambda ()
+ (draw widget)
+ (%trace "; swap-buffers\n")
+ (glx:swap-buffers widget)
+ (%trace "; flush\n")
+ (gl:flush)))
+ (if (glxgears-demo-animate? widget)
+ (let ((now (glxgears-demo-frame-start widget))
+ (count (glxgears-demo-frame-count widget))
+ (start (glxgears-demo-frame-count-start widget)))
+ (if start
+ (let ((seconds (internal-time/ticks->seconds (- now start))))
+ (if (>= seconds 5.0)
+ (let ((fps (/ count seconds)))
+ (define-integrable (%3.1f n)
+ (number->string (/ (round (* 10. n)) 10.)))
+ (define-integrable (%6.3f n)
+ (number->string (/ (round (* 1000. n)) 1000.)))
+ (for-each display
+ (list count" frames"
+ " in "(%3.1f seconds)" seconds"
+ " = "(%6.3f fps)" FPS\n"))
+ (set-glxgears-demo-frame-count-start! widget now)
+ (set-glxgears-demo-frame-count! widget 0))))
+ (begin
+ (set-glxgears-demo-frame-count-start! widget now)
+ (set-glxgears-demo-frame-count! widget 0))))))
+
+(define (draw widget)
+ (%trace "; draw "widget"\n")
+ (let ((angle (glxgears-demo-angle widget))
+ (gears (glxgears-demo-gears widget))
+ (view-rotx (glxgears-demo-view-rotx widget))
+ (view-roty (glxgears-demo-view-roty widget)))
+ (let ((gear1 (car gears))
+ (gear2 (cadr gears))
+ (gear3 (caddr gears)))
+ ;;(if stereo
+ #;(begin
+ ;; First left eye.
+ (gl:draw-buffer 'BACK-LEFT)
+
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum left right (- asp) asp 5. 60.)
+
+ (gl:matrix-mode 'MODELVIEW)
+
+ (gl:push-matrix)
+ (gl:translate (* .5 eyesep) 0. 0.)
+ (draw-gears angle gear1 gear2 gear3)
+ (gl:pop-matrix)
+
+ ;; Then right eye.
+ (gl:draw-buffer 'BACK-RIGHT)
+
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum (- right) (- left) (- asp) asp 5. 60.)
+
+ (gl:matrix-mode 'MODELVIEW)
+
+ (gl:push-matrix)
+ (gl:translate (* -.5 eyesep) 0. 0.)
+ (draw-gears angle gear1 gear2 gear3)
+ (gl:pop-matrix))
+ (begin
+ (draw-gears angle gear1 gear2 gear3 view-rotx view-roty)))));)
+
+(define (draw-gears angle gear1 gear2 gear3 view-rotx view-roty)
+ (%trace "; draw-gears "angle" "gear1" "gear2" "gear3" "view-rotx" "view-roty"\n")
+ (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER)
+ (gl:push-matrix)
+ (gl:rotate view-rotx 1. 0. 0.)
+ (gl:rotate view-roty 0. 1. 0.)
+ #;(gl:rotate view-rotz 0. 0. 1.)
+
+ (gl:push-matrix)
+ (gl:translate -3. -2. 0.)
+ (gl:rotate angle 0. 0. 1.)
+ (gl:call-list gear1)
+ (gl:pop-matrix)
+
+ (gl:push-matrix)
+ (gl:translate 3.1 -2. 0.)
+ (gl:rotate (- (* -2.0 angle) 9.) 0. 0. 1.)
+ (gl:call-list gear2)
+ (gl:pop-matrix)
+
+ (gl:push-matrix)
+ (gl:translate -3.1 4.2 0.)
+ (gl:rotate (- (* -2.0 angle) 25.) 0. 0. 1.)
+ (gl:call-list gear3)
+ (gl:pop-matrix)
+
+ (gl:pop-matrix))
+
+(define (reshape widget)
+ (let ((geo (fix-widget-geometry widget))
+ (w.h (glxgears-demo-shape widget)))
+ (let ((width (fix-rect-width geo))
+ (height (fix-rect-height geo)))
+ (if (not (and (fix:= (car w.h) width)
+ (fix:= (cdr w.h) height)))
+ (begin
+ (%trace ";glxgears: reshape "width" "height" "widget"\n")
+ (with-glx-device widget
+ (lambda ()
+ (gl:viewport 0 0 width height)
+ (let ((widthf (->flonum width))
+ (heightf (->flonum height)))
+
+ #;(if stereo
+ (let ((w (* fix-point (/ 1. 5.))))
+ (set! asp (/ heightf widthf))
+ (set! left (* -5. (/ (- w (* .5 eyesep)) fix-point)))
+ (set! right (* 5. (/ (+ w (* .5 eyesep)) fix-point))))
+ (let ((h (/ heightf widthf)))
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum -1. 1. (- h) h 5. 60.)))
+
+ (let ((h (/ heightf widthf)))
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum -1. 1. (- h) h 5. 60.))
+
+ (gl:matrix-mode 'MODELVIEW)
+ (gl:load-identity)
+ (gl:translate 0. 0. -40.))))
+ (set-glxgears-demo-frame-start! widget #f)
+ (set-glxgears-demo-frame-count! widget 0)
+ (set-glxgears-demo-shape! widget (cons width height)))))))
+
+(define (init widget)
+ (for-each display (list "; glxgears: init "widget"\n"))
+ (reshape widget)
+ (with-glx-device widget
+ (lambda ()
+ (let ((pos (flo:4d 5.0 5.0 10.0 0.0))
+ (red (color 0.8 0.1 0.0 1.0))
+ (green (color 0.0 0.8 0.2 1.0))
+ (blue (color 0.2 0.2 1.0 1.0)))
+ (%trace ";light\n")
+ (gl:light 'LIGHT0 'POSITION pos)
+ (gl:enable 'CULL-FACE)
+ (gl:enable 'LIGHTING)
+ (gl:enable 'LIGHT0)
+ (gl:enable 'DEPTH-TEST)
+
+ ;; make the gears
+ (let ((gear1 (gl:gen-lists 1)))
+ (%trace ";gear1 => "gear1"\n")
+ (gl:new-list gear1 'COMPILE)
+ (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE red)
+ (draw-gear 1.0 4.0 1.0 20. 0.7)
+ (gl:end-list)
+
+ (let ((gear2 (gl:gen-lists 1)))
+ (%trace ";gear2 => "gear2"\n")
+ (gl:new-list gear2 'COMPILE)
+ (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE green)
+ (draw-gear 0.5 2.0 2.0 10. 0.7)
+ (gl:end-list)
+
+ (let ((gear3 (gl:gen-lists 1)))
+ (%trace ";gear3 => "gear3"\n")
+ (gl:new-list gear3 'COMPILE)
+ (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE blue)
+ (draw-gear 1.3 2.0 0.5 10. 0.7)
+ (gl:end-list)
+
+ (gl:enable 'NORMALIZE)
+ (set-glxgears-demo-gears! widget (list gear1 gear2 gear3)))))))))
+
+(define (draw-gear inner-radius ; radius of hole at center
+ outer-radius ; radius at center of teeth
+ width ; width of gear
+ teeth ; number of teeth
+ tooth-depth) ; depth of tooth
+ (%trace "; draw-gear "inner-radius" "outer-radius" "width" "teeth" "tooth-depth"\n")
+ (let ((r0 inner-radius)
+ (r1 (- outer-radius (/ tooth-depth 2.)))
+ (r2 (+ outer-radius (/ tooth-depth 2.)))
+ (2pi/teeth (/ 2pi teeth))
+ (width/2 (* width .5))
+ (-width/2 (* (- width) .5)))
+ (let ((da (/ 2pi/teeth 4.)))
+ (let ((2da (* 2. da))
+ (3da (* 3. da)))
+
+ (gl:shade-model 'FLAT)
+ (gl:normal (flo:3d 0. 0. 1.))
+
+ ;; draw front face
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2)
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) width/2)
+ (if (< i teeth)
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2)
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2)))))
+ (gl:end)
+
+ ;; draw front sides of teeth
+ (gl:begin 'QUADS)
+ (do ((i 0. (+ i 1.)))
+ ((= i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (let ((angl1 angle))
+ (gl:vertex3 (* r1 (cos angl1)) (* r1 (sin angl1)) width/2))
+ (let ((angl2 (+ angle da)))
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) width/2))
+ (let ((angl3 (+ angle 2da)))
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) width/2))
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2))))
+ (gl:end)
+
+ (gl:normal (flo:3d 0. 0. -1.))
+
+ ;; draw back face
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) -width/2)
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2)
+ (if (< i teeth)
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2)
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2)
+ ))))
+ (gl:end)
+
+ ;; draw back sides of teeth
+ (gl:begin 'QUADS)
+ (do ((i 0. (+ i 1.)))
+ ((= i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2))
+ (let ((angl3 (+ angle 2da)))
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) -width/2))
+ (let ((angl2 (+ angle da)))
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) -width/2))
+ (let ((angl1 angle))
+ (gl:vertex3 (* r1 (cos angl1)) (* r1 (sin angl1)) -width/2))))
+ (gl:end)
+
+ ;; draw outward faces of teeth
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((= i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (let ((angl2 (+ angle da))
+ (angl3 (+ angle 2da))
+ (angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) width/2)
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) -width/2)
+ (let ((u (- (* r2 (cos angl2)) (* r1 (cos angle))))
+ (v (- (* r2 (sin angl2)) (* r1 (sin angle)))))
+ (let ((len (sqrt (+ (* u u) (* v v)))))
+ (gl:normal (flo:3d (/ v len) (- (/ u len)) 0.))))
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) width/2)
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) -width/2)
+ (gl:normal (flo:3d (cos angle) (sin angle) 0.))
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) width/2)
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) -width/2)
+ (let ((u (- (* r1 (cos angl4)) (* r2 (cos angl3))))
+ (v (- (* r1 (sin angl4)) (* r2 (sin angl3)))))
+ (gl:normal (flo:3d v (- u) 0.)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2)
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2)
+ (gl:normal (flo:3d (cos angle) (sin angle) 0.)))))
+ (gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) width/2)
+ (gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) -width/2)
+ (gl:end)
+
+ (gl:shade-model 'SMOOTH)
+
+ ;; draw inside radius cylinder
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (gl:normal (flo:3d (- (cos angle)) (- (sin angle)) 0.))
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2)
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2)))
+ (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)))
+
+(define-integrable 2pi (* 8. (flo:atan2 1. 1.)))
+
+(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 (flo:4d r g b a)
+ (let ((v (flo:vector-cons 4)))
+ (flo:vector-set! v 0 r)
+ (flo:vector-set! v 1 g)
+ (flo:vector-set! v 2 b)
+ (flo:vector-set! v 3 a)
+ v))
+
+(define-integrable color flo:4d)
+
+(define (%trace . msg)
+ (declare (ignore msg))
+ unspecific
+ #;(for-each display msg))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; A few gtkglext wraps.
+;;; package: (gl gtk)
+
+(define (make-gl-device width height)
+ (let ((window (gtk-window-new 'toplevel)))
+ (gtk-window-set-opacity window 1.0)
+ (gtk-window-set-title window "google-elevations")
+ (set-gtk-window-delete-event-callback!
+ window (lambda (w) (%trace ";closed "w"\n") 0))
+ (gtk-container-set-border-width window 5)
+ (let ((widget (make-gl-widget width height)))
+ (gtk-container-add window widget)
+ (gtk-widget-show-all window)
+ widget)))
+
+(C-include "gtkglext")
+
+(define (with-gl-device widget thunk)
+ (with-gl-library
+ (lambda ()
+ (let ((drawable (gl-widget-gl-window widget))
+ (context (gl-widget-context widget)))
+ (if (zero? (C-call "gdk_gl_drawable_gl_begin" drawable context))
+ (error "gdk_gl_drawable_gl_begin failed"))
+ (let ((value (thunk)))
+ (C-call "gdk_gl_drawable_gl_end" drawable)
+ value)))))
+
+(define initted? #f)
+(define gdk-gl-config)
+(define double-buffered?)
+
+(define (gtk-gl-init)
+ (if (not initted?)
+ (let* ((size (+ (C-sizeof "int") (C-sizeof "* char")))
+ (bytes (malloc size #f))
+ (count-var bytes)
+ (vector-var (alien-byte-increment count-var (C-sizeof "int"))))
+ (C->= count-var "int" 0)
+ (C->= vector-var "* char" 0)
+ (if (zero? (C-call "gtk_gl_init_check" count-var vector-var))
+ (error "gtk_gl_init_check failed."))
+ (free bytes)
+ (set! gdk-gl-config
+ (let ((alien (make-alien '|GdkGLConfig|)))
+ (C-call "gdk_gl_config_new_by_mode"
+ alien (+ (C-enum "GDK_GL_MODE_RGBA")
+ (C-enum "GDK_GL_MODE_DEPTH")
+ (C-enum "GDK_GL_MODE_DOUBLE")))
+ (if (alien-null? alien)
+ (begin
+ (C-call "gdk_gl_config_new_by_mode"
+ alien (+ (C-enum "GDK_GL_MODE_RGBA")
+ (C-enum "GDK_GL_MODE_DEPTH")))
+ (if (alien-null? alien)
+ (error "Could not find an GL-capable visual."))
+ (set! double-buffered? #f)
+ alien)
+ (begin
+ (set! double-buffered? #t)
+ alien))))
+ (set! initted? #t))))
+
+(define (initialize-package!)
+ (reset-gl-config)
+ (add-event-receiver! event:after-restore reset-gl-config))
+
+(define (reset-gl-config)
+ (set! initted? #f)
+ (set! gdk-gl-config)
+ (set! double-buffered?))
+
+(define-class <gl-widget> (<fix-widget>)
+ (gl-window define standard)
+ (context define standard))
+
+(define-method initialize-instance ((widget <gl-widget>) width height)
+ (call-next-method widget width height)
+ (gtk-gl-init)
+ (let ((alien (gobject-alien widget)))
+ (let ((gl-window (make-alien '|GdkGLWindow|))
+ (gl-context (make-alien '|GdkGLContext|)))
+
+ (C-call "gtk_widget_set_gl_capability" gl-window
+ alien gdk-gl-config 0 double-buffered? (C-enum "GDK_GL_RGBA_TYPE"))
+ (if (alien-null? gl-window)
+ (error "gdk_window_set_gl_capability failed")
+ (set-gl-widget-gl-window! widget gl-window))
+
+ (C-call "gtk_widget_get_gl_context" gl-context alien)
+ (set-gl-widget-context! widget gl-context))
+ #;(set-gtk-widget-draw-callback! widget gl-draw-callback)
+ #;(set-scm-widget-set-scroll-adjustments-callback! widget
+ gl-adjustments-callback)
+ (C-call "gtk_widget_set_can_focus" alien 1)))
+
+#;(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 (%trace . objects) (for-each display objects))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Header for gl-shim.c and gl-const.c. */
+
+#include <gtk/gtk.h>
+#include <GL/glx.h>
+/* #include <GL/glu.h> for gluLookAt, which doesn't need a declaration(?) */
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for gl-shim.so.
+
+(typedef GLenum uint)
+(typedef GLbitfield uint)
+(typedef GLint int)
+(typedef GLuint uint)
+(typedef GLsizei int)
+(typedef GLfloat float)
+(typedef GLdouble double)
+(typedef SCM (* void))
+
+(extern void glShadeModel (mode GLenum))
+
+(enum (GL_SMOOTH))
+
+(extern void gl_clear_color (color SCM))
+
+(extern void glClearDepth (depth GLdouble))
+
+(extern void glEnable (cap GLenum))
+
+(enum (GL_DEPTH_TEST))
+
+(extern void glDepthFunc (func GLenum))
+
+(enum (GL_LEQUAL))
+
+(extern void glHint (target GLenum) (mode GLenum))
+
+(enum (GL_PERSPECTIVE_CORRECTION_HINT))
+
+(enum (GL_NICEST))
+
+(extern void glClear (mask GLbitfield))
+
+(enum (GL_COLOR_BUFFER_BIT)
+ (GL_DEPTH_BUFFER_BIT)
+ (GL_STENCIL_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))
+
+(extern void gl_color (color SCM))
+
+(extern void gl_vertex (point SCM))
+
+(extern void glEnd)
+
+(extern void glCallList (list GLuint))
+
+(extern void glDrawBuffer (mode GLenum))
+
+(extern void glFrustum
+ (left GLdouble) (right GLdouble)
+ (bottom GLdouble) (top GLdouble)
+ (near_val GLdouble) (far_val GLdouble))
+
+(extern GLuint glGenLists (range GLsizei))
+
+(extern void gl_light (light GLenum) (pname GLenum) (params SCM))
+
+(extern void gl_material (face GLenum) (pname GLenum) (params SCM))
+
+(extern void glMatrixMode (mode GLenum))
+
+(extern void glNewList (list GLuint) (mode GLenum))
+
+(extern void glEndList)
+
+(extern void glDeleteLists (list GLuint) (range GLsizei))
+
+(extern void gl_normal (point SCM))
+
+(extern void glPopMatrix)
+
+(extern void glPushMatrix)
+
+(extern void glRotated (angle GLdouble) (x GLdouble) (y GLdouble) (z GLdouble))
+
+(extern void glTranslated (x GLdouble) (y GLdouble) (z GLdouble))
+
+(extern void glViewport (x GLint) (y GLint) (width GLsizei) (height GLsizei))
+
+(extern void glFlush)
+
+(enum (GL_NORMALIZE)
+ (GL_LIGHTING)
+ (GL_LIGHT0)
+ (GL_CULL_FACE)
+ (GL_BACK_RIGHT)
+ (GL_BACK_LEFT)
+ (GL_POSITION)
+ (GL_FRONT)
+ (GL_AMBIENT_AND_DIFFUSE)
+ (GL_PROJECTION)
+ (GL_MODELVIEW)
+ (GL_COMPILE)
+ (GL_FLAT))
+\f
+(typedef GLXFBConfig (* (struct __GLXFBConfigRec)))
+(typedef GLXContext (* (struct __GLXcontextRec)))
+(typedef GLXPixmap XID)
+(typedef GLXDrawable XID)
+
+#;(extern (* GLXFBConfig) glXChooseFBConfig
+ (dpy (* Display))
+ (screen int)
+ (attrib_list (* (const int)))
+ (nelements (* int)))
+
+(extern (* XVisualInfo) glXChooseVisual
+ (dpy (* Display)) (screen int) (attribList (* int)))
+
+#;(extern void XFree (configs (* GLXFBConfig)))
+
+#;(extern int glXGetFBConfigAttrib
+ (dpy (* Display))
+ (config GLXFBConfig)
+ (attribute int)
+ (value (* int)))
+
+#;(extern GLXWindow glXCreateWindow
+ (dpy (* Display)) (config GLXFBConfig) (wind Window)
+ (attrib_list (* (const int))))
+#;(extern (* GLXWindow) glx_create_window
+ (dpy (* Display)) (config GLXFBConfig) (window (* GdkWindow)))
+
+#;(extern GLXPixmap glXCreatePixmap
+ (dpy (* Display))
+ (config GLXFBConfig)
+ (pixmap Pixmap)
+ (attrib_list (* (const int))))
+
+(extern void glXDestroyWindow (dpy (* Display)) (window GLXWindow))
+
+#;(extern void glXDestroyPixmap (dpy (* Display)) (pixmap GLXPixmap))
+#;(extern void glx_destroy_pixmap (dpy (* Display)) (pixmap GLXPixmap))
+
+#;(extern GLXContext glXCreateNewContext
+ (dpy (* Display))
+ (config GLXFBConfig)
+ (render_type int)
+ (share_list GLXContext)
+ (direct Bool))
+
+(extern GLXContext glXCreateContext
+ (dpy (* Display))
+ (vis (* XVisualInfo))
+ (shareList GLXContext)
+ (direct Bool))
+
+(extern void glXDestroyContext (dpy (* Display)) (ctx GLXContext))
+
+#;(extern Bool glXMakeContextCurrent
+ (dpy (* Display))
+ (draw GLXDrawable) (read GLXDrawable)
+ (ctx GLXContext))
+(extern Bool glXMakeCurrent
+ (dpy (* Display)) (drawable GLXDrawable) (ctx GLXContext))
+
+(extern void glXWaitGL)
+
+(extern void glXWaitX)
+
+(extern void glXSwapBuffers (dpy (* Display)) (drawable GLXDrawable))
+
+(extern void glXUseXFont (font Font) (first int) (count int) (list_base int))
+
+(enum (GLX_RGBA)
+ (GLX_DEPTH_SIZE)
+ (GLX_DOUBLEBUFFER)
+ (GLX_RED_SIZE)
+ (GLX_GREEN_SIZE)
+ (GLX_BLUE_SIZE))
+\f
+(typedef gint int)
+(typedef gpointer (* void))
+(typedef gboolean int)
+(typedef Window XID) ;X11/X.h
+(typedef GLXWindow XID) ;X11/X.h
+(typedef Pixmap XID) ;X11/X.h
+(typedef Font XID) ;X11/Xdefs.h
+(typedef Bool int) ;X11/Xdefs.h
+(typedef XID ulong) ;X11/Xdefs.h
+(enum (None))
+
+(extern (* Display) gdk_window_xdisplay (window (* GdkWindow)))
+
+(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)))
+
+(extern void gtk_widget_set_can_focus
+ (widget (* GtkWidget))
+ (can_focus gboolean))
+
+(extern void gtk_widget_set_app_paintable
+ (widget (* GtkWidget))
+ (app_paintable gboolean))
+
+(extern void gtk_widget_set_double_buffered
+ (width (* GtkWidget))
+ (double_buffered gboolean))
+
+(typedef GdkWindowWindowClass
+ (enum
+ (GDK_INPUT_OUTPUT) (GDK_INPUT_ONLY)))
+
+(typedef GdkWindowType
+ (enum
+ (GDK_WINDOW_ROOT)
+ (GDK_WINDOW_TOPLEVEL)
+ (GDK_WINDOW_CHILD)
+ (GDK_WINDOW_TEMP)
+ (GDK_WINDOW_FOREIGN)))
+
+(typedef GdkWindowAttributesType
+ (enum
+ (GDK_WA_TITLE)
+ (GDK_WA_X)
+ (GDK_WA_Y)
+ (GDK_WA_CURSOR)
+ (GDK_WA_VISUAL)
+ (GDK_WA_WMCLASS)
+ (GDK_WA_NOREDIR)))
+
+(typedef GdkWindowAttr (struct _GdkWindowAttr))
+
+(struct _GdkWindowAttr
+ (event_mask gint)
+ (x gint)
+ (y gint)
+ (width gint)
+ (height gint)
+ (wclass GdkWindowWindowClass)
+ (visual (* GdkVisual))
+ (window_type GdkWindowType))
+
+(extern (* GdkWindow) gdk_window_new
+ (parent (* GdkWindow))
+ (attributes (* GdkWindowAttr))
+ (attributes_mask gint))
+
+(extern void gdk_window_set_user_data
+ (window (* GdkWindow))
+ (user_data gpointer))
+
+(enum (GDK_ALL_EVENTS_MASK))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Gl System Packaging
+
+(global-definitions runtime/)
+(global-definitions ffi/)
+(global-definitions sos/)
+(global-definitions gtk/)
+
+(define-package (gl)
+ (parent ()))
+
+(define-package (gl internals)
+ (parent ())
+ (files "gl")
+ (export (gl)
+ gl:shade-model
+ gl:clear-color
+ gl:clear-depth
+ gl:enable
+ gl:depth-func
+ gl:hint
+ gl:clear
+ gl:load-identity
+ glu:look-at
+ gl:scaled
+ gl:begin
+ gl:color
+ gl:vertex
+ gl:end
+ gl:call-list
+ gl:draw-buffer
+ gl:frustum
+ gl:gen-lists
+ gl:light
+ gl:material
+ gl:matrix-mode
+ gl:new-list
+ gl:end-list
+ gl:delete-lists
+ gl:normal
+ gl:pop-matrix
+ gl:push-matrix
+ gl:rotate
+ gl:translate
+ gl:viewport
+ gl:flush))
+
+(define-package (gl internals glx)
+ (parent (gl internals))
+ (files "gl-glx")
+ (import (runtime)
+ ucode-primitive)
+ (import (runtime ffi)
+ %set-alien/address!)
+ (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)
+ (import (gtk)
+ add-gc-cleanup punt-gc-cleanup error-if-null
+ gobject-alien gtk-window-new
+ gtk-window-set-opacity
+ gtk-window-set-title
+ set-gtk-window-delete-event-callback!
+ gtk-container-set-border-width
+ gtk-container-add
+ gtk-widget-show-all
+ <fix-widget>
+ fix-widget-realize-callback)
+ (export (gl)
+ make-glx-device with-glx-device glx:swap-buffers <glx-widget>))
+
+(define-package (gl glxgears)
+ (files "gl-glxgears")
+ (parent (gl))
+ (import (gtk)
+ gtk-widget-destroyed? gtk-widget-destroy
+ gtk-widget-parent gtk-widget-show-all
+ gtk-container-add gtk-container-set-border-width
+ gtk-window-new gtk-window-set-opacity gtk-window-set-title
+ set-gtk-window-delete-event-callback!
+ set-fix-widget-key-press-handler!
+ fix-widget-new-geometry-callback)
+
+ (import (gtk)
+ set-gtk-widget-draw-callback!
+ set-gtk-widget-unrealize-callback!
+ set-fix-widget-button-handler!
+ set-fix-widget-enter-notify-handler!
+ set-fix-widget-focus-change-handler!
+ set-fix-widget-leave-notify-handler!
+ set-fix-widget-map-handler!
+ set-fix-widget-motion-handler!
+ set-fix-widget-unmap-handler!
+ set-fix-widget-visibility-notify-handler!)
+
+ (import (gtk fix-layout)
+ fix-rect-width fix-rect-height
+ fix-widget-geometry)
+ (export ()
+ make-glxgears-demo))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; A few gl wraps.
+;;; package: (gl)
+
+(C-include "gl")
+
+(define (gl:shade-model model)
+ (guarantee-current 'GL:SHADE-MODEL)
+ (C-call "glShadeModel"
+ (case model
+ ((FLAT) (C-enum "GL_FLAT"))
+ ((SMOOTH) (C-enum "GL_SMOOTH"))
+ (else (error "gl:shade-model: Unknown model:" model)))))
+
+(define (gl:clear-color color)
+ (guarantee-current 'GL:CLEAR-COLOR)
+ (guarantee-color color 'gl:clear-color)
+ (C-call "gl_clear_color" color))
+
+(define (gl:clear-depth depth)
+ (guarantee-current 'GL:CLEAR-DEPTH)
+ (guarantee-gl-depth depth 'GL:CLEAR-DEPTH)
+ (C-call "glClearDepth" depth))
+
+(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)))))
+
+(define (gl:depth-func function)
+ (guarantee-current 'GL:DEPTH-FUNC)
+ (C-call "glDepthFunc"
+ (case function
+ ((LEQUAL) (C-enum "GL_LEQUAL"))
+ (else (error "Unknown glDepthFunc function:" function)))))
+
+(define (gl:hint target mode)
+ (guarantee-current 'GL:HINT)
+ (C-call "glHint"
+ (case target
+ ((PERSPECTIVE-CORRECTION) (C-enum "GL_PERSPECTIVE_CORRECTION_HINT"))
+ (else (error "Unknown glHint target:" target)))
+ (case mode
+ ((NICEST) (C-enum "GL_NICEST"))
+ (else (error "Unknown glHint mode:" mode)))))
+
+(define (gl:clear . bits)
+ (guarantee-current 'GL:CLEAR)
+ (C-call "glClear"
+ (reduce + 0 (map (lambda (bit)
+ (case bit
+ ((COLOR-BUFFER)
+ (C-enum "GL_COLOR_BUFFER_BIT"))
+ ((DEPTH-BUFFER)
+ (C-enum "GL_DEPTH_BUFFER_BIT"))
+ ((STENCIL-BUFFER)
+ (C-enum "GL_STENCIL_BUFFER_BIT"))
+ (else (error "Unknwon glClear bit:" bit))))
+ bits))))
+
+(define (gl:load-identity)
+ (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:scaled kx ky kz)
+ (guarantee-current 'GL:SCALED)
+ (guarantee-flonum kx 'GL:SCALED)
+ (guarantee-flonum ky 'GL:SCALED)
+ (guarantee-flonum kz 'GL:SCALED)
+ (C-call "glScaled" kx ky kz))
+
+(define (gl:begin mode)
+ (guarantee-current 'GL:BEGIN)
+ (C-call "glBegin"
+ (case mode
+ ((QUAD-STRIP) (C-enum "GL_QUAD_STRIP"))
+ ((QUADS) (C-enum "GL_QUADS"))
+ ((LINES) (C-enum "GL_LINES"))
+ (else (error "Unknown glBegin mode:" mode)))))
+
+(define (gl:color color)
+ (guarantee-current 'GL:COLOR)
+ (guarantee-color color 'GL:COLOR)
+ (C-call "gl_color" color))
+
+(define (gl:vertex point)
+ (guarantee-current 'GL:VERTEX)
+ (guarantee-3d-point point 'GL:VERTEX)
+ (C-call "gl_vertex" point))
+
+(define (gl:end)
+ (guarantee-current 'GL:END)
+ (C-call "glEnd"))
+
+(define (gl:call-list lst)
+ (guarantee-current 'GL:CALL-LIST)
+ (guarantee-integer lst 'GL:CALL-LIST)
+ (C-call "glCallList" lst))
+
+(define (gl:draw-buffer buffer)
+ (guarantee-current 'GL:DRAW-BUFFER)
+ (C-call "glDrawBuffer"
+ (case buffer
+ ((BACK-LEFT) (C-enum "GL_BACK_LEFT"))
+ ((BACK-RIGHT) (C-enum "GL_BACK_RIGHT"))
+ (else (error "gl:draw-buffer: Unknown buffer:" buffer)))))
+
+(define (gl:frustum left right bottom top near-val far-val)
+ (guarantee-current 'GL:DRAW-BUFFER)
+ (guarantee-flonum left 'GL:DRAW-BUFFER)
+ (guarantee-flonum right 'GL:DRAW-BUFFER)
+ (guarantee-flonum bottom 'GL:DRAW-BUFFER)
+ (guarantee-flonum top 'GL:DRAW-BUFFER)
+ (guarantee-flonum near-val 'GL:DRAW-BUFFER)
+ (guarantee-flonum far-val 'GL:DRAW-BUFFER)
+ (C-call "glFrustum" left right bottom top near-val far-val))
+
+(define (gl:gen-lists range)
+ (guarantee-current 'GL:GEN-LISTS)
+ (guarantee-integer range 'GL:GEN-LISTS)
+ (C-call "glGenLists" range))
+
+(define (gl:light light param values)
+ (guarantee-current 'GL:LIGHT)
+ (C-call "gl_light"
+ (case light
+ ((LIGHT0) (C-enum "GL_LIGHT0"))
+ (else (error "gl:light: Unknown light:" light)))
+ (case param
+ ((POSITION)
+ (guarantee-4d values 'GL:LIGHT)
+ (C-enum "GL_POSITION"))
+ (else (error "gl:light: Unknown parameter:" param)))
+ values))
+
+(define (gl:material face param values)
+ (guarantee-current 'GL:MATERIAL)
+ (C-call "gl_material"
+ (case face
+ ((FRONT) (C-enum "GL_FRONT"))
+ (else (error "gl:material: Unknown face:" face)))
+ (case param
+ ((AMBIENT-AND-DIFFUSE)
+ (guarantee-4d values 'GL:MATERIAL)
+ (C-enum "GL_AMBIENT_AND_DIFFUSE"))
+ (else (error "gl:material: Unknown parameter:" param)))
+ values))
+
+(define (gl:matrix-mode mode)
+ (guarantee-current 'GL:MATRIX-MODE)
+ (C-call "glMatrixMode"
+ (case mode
+ ((MODELVIEW) (C-enum "GL_MODELVIEW"))
+ ((PROJECTION) (C-enum "GL_PROJECTION"))
+ (else (error "gl:matrix-mode: Unknown mode:" mode)))))
+
+(define (gl:new-list lst mode)
+ (guarantee-current 'GL:NEW-LIST)
+ (guarantee-integer lst 'GL:NEW-LIST)
+ (C-call "glNewList"
+ lst
+ (case mode
+ ((COMPILE) (C-enum "GL_COMPILE"))
+ (else (error "gl:new-list: Unknown mode:" mode)))))
+
+(define (gl:end-list)
+ (C-call "glEndList"))
+
+(define (gl:delete-lists lst range)
+ (guarantee-current 'GL:DELETE-LISTS)
+ (guarantee-integer lst 'GL:DELETE-LISTS)
+ (guarantee-integer range 'GL:DELETE-LISTS)
+ (C-call "glDeleteLists" lst range))
+
+(define (gl:normal 3d)
+ (guarantee-current 'GL:NORMAL)
+ (guarantee-3d-point 3d 'GL:NORMAL)
+ (C-call "gl_normal" 3d))
+
+(define (gl:pop-matrix)
+ (guarantee-current 'GL:POP-MATRIX)
+ (C-call "glPopMatrix"))
+
+(define (gl:push-matrix)
+ (guarantee-current 'GL:PUSH-MATRIX)
+ (C-call "glPushMatrix"))
+
+(define (gl:rotate angle x y z)
+ (guarantee-current 'GL:ROTATE)
+ (guarantee-flonum x 'GL:ROTATE)
+ (guarantee-flonum y 'GL:ROTATE)
+ (guarantee-flonum z 'GL:ROTATE)
+ (C-call "glRotated" angle x y z))
+
+(define (gl:translate x y z)
+ (guarantee-current 'GL:TRANSLATE)
+ (guarantee-flonum x 'GL:TRANSLATE)
+ (guarantee-flonum y 'GL:TRANSLATE)
+ (guarantee-flonum z 'GL:TRANSLATE)
+ (C-call "glTranslated" x y z))
+
+(define (gl:viewport x y width height)
+ (guarantee-current 'GL:VIEWPORT)
+ (guarantee-integer x 'GL:VIEWPORT)
+ (guarantee-integer y 'GL:VIEWPORT)
+ (guarantee-integer width 'GL:VIEWPORT)
+ (guarantee-integer height 'GL:VIEWPORT)
+ (C-call "glViewport" x y width height))
+
+(define (gl:flush)
+ (guarantee-current 'GL:FLUSH)
+ (C-call "glFlush"))
+\f
+(define gl-library-mutex)
+
+(define (init)
+ (set! gl-library-mutex (make-thread-mutex)))
+
+(define (initialize-package!)
+ (init)
+ (add-event-receiver! event:after-restore reset-gl))
+
+(define (reset-gl)
+ (init))
+
+(define (with-gl-library thunk)
+ (with-thread-mutex-locked gl-library-mutex thunk))
+
+(define (guarantee-current operator)
+ (if (not (eq? (current-thread)
+ (thread-mutex-owner gl-library-mutex)))
+ (error "The GL library has not been locked:" operator)))
+
+(define (guarantee-flonum object operator)
+ (if (not (flo:flonum? object))
+ (error:wrong-type-argument object "a flonum" operator)))
+
+(define (guarantee-color object operator)
+ (if (not (and (flo:flonum? object)
+ (fix:= 4 (flo:vector-length object))))
+ (error:wrong-type-argument object "a GL color" operator)))
+
+(define (guarantee-gl-depth object operator)
+ (if (not (and (flo:flonum? object)
+ (<= 0.0 object) (<= object 1.0)))
+ (error:wrong-type-argument object "a GL depth" operator)))
+
+(define (guarantee-3d-point object operator)
+ (if (not (and (flo:flonum? object)
+ (fix:= 3 (flo:vector-length object))))
+ (error:wrong-type-argument object "a 3d point" 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)))
+
+(initialize-package!)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compile the GLX Gears demo.
+
+(load-option 'CREF)
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+
+ (if (name->package '(GL GLX-GEARS))
+ (error "The GLX-GEARS package already exists.")
+ (let ((package-set (package-set-pathname "glxgears")))
+ (if (not (file-exists? package-set))
+ (cref/generate-trivial-constructor "glxgears"))
+ (construct-packages-from-file (fasload package-set))))
+
+ (fluid-let ((compile-file:sf-only? #t))
+ (let ((deps '("glxgears-const.bin"))
+ (env (->environment '(gl glxgears))))
+ (compile-file "glxgears" deps env)
+ (load "glxgears" env)))))
+(cref/generate-constructors "glxgears" 'ALL)
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Header for glxgears-shim.c and glxgears-const.c. */
+
+#include <X11/Xutil.h>
+#include <GL/glx.h>
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; This is a port of the infamous "gears" demo to straight GLX.
+
+(typedef XEvent (union _XEvent))
+
+(union _XEvent
+ (type int))
+
+(typedef XConfigureEvent
+ (struct
+ (height int)
+ (width int)))
+
+(typedef XVisualInfo ;X11/Xutil.h
+ (struct
+ (depth int)
+ (visual (* Visual))))
+
+(typedef XSetWindowAttributes
+ (struct
+ (background_pixel ulong)
+ (border_pixel ulong)
+ (colormap Colormap)
+ (event_mask long)))
+
+(typedef XSizeHints
+ (struct
+ (flags long)
+ (height int)
+ (width int)
+ (x int)
+ (y int)))
+
+(typedef Bool int)
+(typedef XID ulong)
+(typedef Window XID)
+(typedef Colormap XID)
+(typedef KeySym XID)
+(typedef Pixmap XID)
+
+(extern int DefaultScreen
+ (display (* Display)))
+
+(extern int DisplayHeight
+ (display (* Display))
+ (scrnum int))
+
+(extern int DisplayWidth
+ (display (* Display))
+ (scrnum int))
+
+(extern Window RootWindow
+ (display (* Display))
+ (scrnum int))
+
+(extern Colormap XCreateColormap
+ (display (* Display))
+ (w Window)
+ (visual (* Visual))
+ (alloc int))
+
+(extern Window XCreateWindow
+ (display (* Display))
+ (parent Window)
+ (x int) (y int) (width uint) (height uint)
+ (border_width int)
+ (depth int)
+ (class uint)
+ (visual (* Visual))
+ (valuemask ulong)
+ (attributes (* XSetWindowAttributes)))
+
+(extern int XDestroyWindow
+ (display (* Display))
+ (w Window))
+
+(extern int XFree (data (* void)))
+
+(extern KeySym XLookupKeysym
+ (key_event (* XKeyEvent))
+ (index int))
+
+(extern int XLookupString
+ (event_struct (* XKeyEvent))
+ (buffer_return (* char))
+ (bytes_buffer int)
+ (keysym_return (* KeySym))
+ (status_in_out (* XComposeStatus)))
+
+(extern int XMapWindow
+ (display (* Display))
+ (w Window))
+
+(extern int XNextEvent
+ (display (* Display))
+ (event_return (* XEvent)))
+
+(extern (* Display) XOpenDisplay
+ (display_name (* char)))
+
+(extern int XCloseDisplay
+ (display (* Display)))
+
+(extern int XParseGeometry
+ (parsestring (* (const char)))
+ (x_return (* int))
+ (y_return (* int))
+ (width_return (* uint))
+ (height_return (* uint)))
+
+(extern int XPending
+ (display (* Display)))
+
+(extern int XSetNormalHints ;X11/Xutil.h
+ (display (* Display))
+ (w Window)
+ (hints (* XSizeHints)))
+
+(extern int XSetStandardProperties ;X11/Xutil.h
+ (display (* Display))
+ (w Window)
+ (window_name (* (const char)))
+ (icon_name (* (const char)))
+ (icon_pixmap Pixmap)
+ (argv (* (* char)))
+ (argc int)
+ (hints (* XSizeHints)))
+
+(extern (* (const char)) glGetString
+ (which int))
+
+(extern (* XVisualInfo) glXChooseVisual
+ (dpy (* Display))
+ (screen int)
+ (attrib_list (* int)))
+
+(typedef GLXContext (* mumble))
+
+(extern GLXContext glXCreateContext
+ (dpy (* Display))
+ (visual (* XVisualInfo))
+ (share_list GLXContext)
+ (direct Bool))
+
+(extern void glXDestroyContext (dpy (* Display)) (ctx GLXContext))
+
+(typedef GLXDrawable XID)
+
+(extern Bool glXMakeCurrent
+ (dpy (* Display))
+ (draw GLXDrawable)
+ (ctx GLXContext))
+
+(extern void glXSwapBuffers
+ (dpy (* Display))
+ (draw GLXDrawable))
+
+(enum
+ (AllocNone)
+ (CWBackPixel)
+ (CWBorderPixel)
+ (CWColormap)
+ (CWEventMask)
+ (ConfigureNotify)
+ (Expose)
+ (ExposureMask)
+ (GLX_BLUE_SIZE)
+ (GLX_DEPTH_SIZE)
+ (GLX_DOUBLEBUFFER)
+ (GLX_GREEN_SIZE)
+ (GLX_RED_SIZE)
+ (GLX_RGBA)
+ (GLX_SAMPLES)
+ (GLX_SAMPLE_BUFFERS)
+ (GLX_STEREO)
+ (GL_EXTENSIONS)
+ (GL_RENDERER)
+ (GL_VENDOR)
+ (GL_VERSION)
+ (HeightValue)
+ (InputOutput)
+ (KeyPress)
+ (KeyPressMask)
+ (None)
+ (StructureNotifyMask)
+ (True)
+ (USPosition)
+ (USSize)
+ (WidthValue)
+ (XK_Down)
+ (XK_Left)
+ (XK_Right)
+ (XK_Up)
+ (XValue)
+ (YValue))
--- /dev/null
+#| -*-Scheme-*- |#
+
+(global-definitions runtime/)
+(global-definitions ffi/)
+(global-definitions "./gl")
+
+(define-package (gl glxgears)
+ (files "glxgears")
+ (parent (gl))
+ (import (gl internals)
+ with-gl-library))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; This is a translation of the C code for the venerable GLX Gears demo.
+
+(C-include "glxgears")
+
+(define view-rotx 20.)
+(define view-roty 30.)
+(define view-rotz 0.)
+
+(define gear1)
+(define gear2)
+(define gear3)
+(define angle 0.)
+
+(define fullscreen #f) ; Create a single fullscreen window
+(define stereo #f) ; Enable stereo.
+(define samples) ; Choose visual with at least N samples.
+(define animate #f) ; Animation
+(define eyesep 5.) ; Eye separation.
+(define fix-point 40.) ; Fixation point distance.
+(define left) ; Stereo frustum params.
+(define right)
+(define asp)
+
+(define (draw-gear inner-radius ; radius of hole at center
+ outer-radius ; radius at center of teeth
+ width ; width of gear
+ teeth ; number of teeth
+ tooth-depth) ; depth of tooth
+ (let ((r0 inner-radius)
+ (r1 (- outer-radius (/ tooth-depth 2.)))
+ (r2 (+ outer-radius (/ tooth-depth 2.)))
+ (2pi/teeth (/ 2pi teeth))
+ (width/2 (* width .5))
+ (-width/2 (* (- width) .5)))
+ (let ((da (/ 2pi/teeth 4.)))
+ (let ((2da (* 2. da))
+ (3da (* 3. da)))
+
+ (gl:shade-model 'FLAT)
+ (gl:normal (flo:3d 0. 0. 1.))
+
+ ;; draw front face
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2)
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) width/2)
+ (if (< i teeth)
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2)
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2)))))
+ (gl:end)
+
+ ;; draw front sides of teeth
+ (gl:begin 'QUADS)
+ (do ((i 0. (+ i 1.)))
+ ((= i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (let ((angl1 angle))
+ (gl:vertex3 (* r1 (cos angl1)) (* r1 (sin angl1)) width/2))
+ (let ((angl2 (+ angle da)))
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) width/2))
+ (let ((angl3 (+ angle 2da)))
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) width/2))
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2))))
+ (gl:end)
+
+ (gl:normal (flo:3d 0. 0. -1.))
+
+ ;; draw back face
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) -width/2)
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2)
+ (if (< i teeth)
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2)
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2)
+ ))))
+ (gl:end)
+
+ ;; draw back sides of teeth
+ (gl:begin 'QUADS)
+ (do ((i 0. (+ i 1.)))
+ ((= i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (let ((angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2))
+ (let ((angl3 (+ angle 2da)))
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) -width/2))
+ (let ((angl2 (+ angle da)))
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) -width/2))
+ (let ((angl1 angle))
+ (gl:vertex3 (* r1 (cos angl1)) (* r1 (sin angl1)) -width/2))))
+ (gl:end)
+
+ ;; draw outward faces of teeth
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((= i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (let ((angl2 (+ angle da))
+ (angl3 (+ angle 2da))
+ (angl4 (+ angle 3da)))
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) width/2)
+ (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) -width/2)
+ (let ((u (- (* r2 (cos angl2)) (* r1 (cos angle))))
+ (v (- (* r2 (sin angl2)) (* r1 (sin angle)))))
+ (let ((len (sqrt (+ (* u u) (* v v)))))
+ (gl:normal (flo:3d (/ v len) (- (/ u len)) 0.))))
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) width/2)
+ (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) -width/2)
+ (gl:normal (flo:3d (cos angle) (sin angle) 0.))
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) width/2)
+ (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) -width/2)
+ (let ((u (- (* r1 (cos angl4)) (* r2 (cos angl3))))
+ (v (- (* r1 (sin angl4)) (* r2 (sin angl3)))))
+ (gl:normal (flo:3d v (- u) 0.)))
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2)
+ (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2)
+ (gl:normal (flo:3d (cos angle) (sin angle) 0.)))))
+ (gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) width/2)
+ (gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) -width/2)
+ (gl:end)
+
+ (gl:shade-model 'SMOOTH)
+
+ ;; draw inside radius cylinder
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> i teeth))
+ (let ((angle (* i 2pi/teeth)))
+ (gl:normal (flo:3d (- (cos angle)) (- (sin angle)) 0.))
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2)
+ (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2)))
+ (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)))
+
+(define (draw)
+ (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER)
+ (gl:push-matrix)
+ (gl:rotate view-rotx 1. 0. 0.)
+ (gl:rotate view-roty 0. 1. 0.)
+ (gl:rotate view-rotz 0. 0. 1.)
+
+ (gl:push-matrix)
+ (gl:translate -3. -2. 0.)
+ (gl:rotate angle 0. 0. 1.)
+ (gl:call-list gear1)
+ (gl:pop-matrix)
+
+ (gl:push-matrix)
+ (gl:translate 3.1 -2. 0.)
+ (gl:rotate (- (* -2.0 angle) 9.) 0. 0. 1.)
+ (gl:call-list gear2)
+ (gl:pop-matrix)
+
+ (gl:push-matrix)
+ (gl:translate -3.1 4.2 0.)
+ (gl:rotate (- (* -2.0 angle) 25.) 0. 0. 1.)
+ (gl:call-list gear3)
+ (gl:pop-matrix)
+
+ (gl:pop-matrix))
+
+(define (draw-gears)
+ (if stereo
+ (begin
+ ;; First left eye.
+ (gl:draw-buffer 'BACK-LEFT)
+
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum left right (- asp) asp 5. 60.)
+
+ (gl:matrix-mode 'MODELVIEW)
+
+ (gl:push-matrix)
+ (gl:translate (* .5 eyesep) 0. 0.)
+ (draw)
+ (gl:pop-matrix)
+
+ ;; Then right eye.
+ (gl:draw-buffer 'BACK-RIGHT)
+
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum (- right) (- left) (- asp) asp 5. 60.)
+
+ (gl:matrix-mode 'MODELVIEW)
+
+ (gl:push-matrix)
+ (gl:translate (* -.5 eyesep) 0. 0.)
+ (draw)
+ (gl:pop-matrix))
+ (begin
+ (draw))))
+
+;; Draw single frame, do SwapBuffers, compute FPS
+(define draw-frame
+ (let ((frames 0)
+ (tRot0 #f)
+ (tRate0 #f))
+ (named-lambda (draw-frame dpy win)
+ (%trace ";draw-frame\n")
+ (let ((t (real-time-clock)))
+ (if (not tRot0)
+ (set! tRot0 t))
+ (let ((dt (internal-time/ticks->seconds (- t tRot0))))
+ (set! tRot0 t)
+ (if animate
+ (begin
+ ;; advance rotation for next frame
+ (set! angle (+ angle (* 70.0 dt))) ; 70 degrees per second
+ (if (> angle 3600.0)
+ (set! angle (- angle 3600.0))))))
+ (draw-gears)
+ (C-call "glXSwapBuffers" dpy win)
+ (gl:flush)
+ (set! frames (1+ frames))
+
+ (if (not tRate0)
+ (set! tRate0 t))
+
+ (let ((seconds (internal-time/ticks->seconds (fix:- t tRate0))))
+ (if (>= seconds 5.0)
+ (let ((fps (/ frames seconds)))
+ (for-each display
+ (list frames" frames"
+ " in "(%3.1f seconds)" seconds"
+ " = "(%6.3f fps)" FPS\n"))
+ (set! tRate0 t)
+ (set! frames 0))))))))
+
+(define (%3.1f n)
+ (number->string (/ (round (* 10. n)) 10.)))
+
+(define (%6.3f n)
+ (number->string (/ (round (* 1000. n)) 1000.)))
+
+;; new window size or exposure
+(define (reshape width height)
+ (%trace ";reshape "width" "height"\n")
+ (gl:viewport 0 0 width height)
+ (let ((widthf (->flonum width))
+ (heightf (->flonum height)))
+
+ (if stereo
+ (let ((w (* fix-point (/ 1. 5.))))
+ (set! asp (/ heightf widthf))
+ (set! left (* -5. (/ (- w (* .5 eyesep)) fix-point)))
+ (set! right (* 5. (/ (+ w (* .5 eyesep)) fix-point))))
+ (let ((h (/ heightf widthf)))
+ (gl:matrix-mode 'PROJECTION)
+ (gl:load-identity)
+ (gl:frustum -1. 1. (- h) h 5. 60.)))
+
+ (gl:matrix-mode 'MODELVIEW)
+ (gl:load-identity)
+ (gl:translate 0. 0. -40.)))
+
+(define (init)
+ (%trace ";init\n")
+ (let ((pos (flo:4d 5.0 5.0 10.0 0.0))
+ (red (color 0.8 0.1 0.0 1.0))
+ (green (color 0.0 0.8 0.2 1.0))
+ (blue (color 0.2 0.2 1.0 1.0)))
+ (%trace ";light\n")
+ (gl:light 'LIGHT0 'POSITION pos)
+ (gl:enable 'CULL-FACE)
+ (gl:enable 'LIGHTING)
+ (gl:enable 'LIGHT0)
+ (gl:enable 'DEPTH-TEST)
+
+ ;; make the gears
+ (set! gear1 (gl:gen-lists 1))
+ (%trace ";gear1 => "gear1"\n")
+ (gl:new-list gear1 'COMPILE)
+ (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE red)
+ (draw-gear 1.0 4.0 1.0 20. 0.7)
+ (gl:end-list)
+
+ (set! gear2 (gl:gen-lists 1))
+ (%trace ";gear2 => "gear2"\n")
+ (gl:new-list gear2 'COMPILE)
+ (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE green)
+ (draw-gear 0.5 2.0 2.0 10. 0.7)
+ (gl:end-list)
+
+ (set! gear3 (gl:gen-lists 1))
+ (%trace ";gear3 => "gear3"\n")
+ (gl:new-list gear3 'COMPILE)
+ (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE blue)
+ (draw-gear 1.3 2.0 0.5 10. 0.7)
+ (gl:end-list)
+
+ (gl:enable 'NORMALIZE)))
+
+(define (no-border dpy w)
+ (declare (ignore dpy w))
+ unspecific)
+#|
+ /**
+ * Remove window border/decorations.
+ */
+ static void
+ no_border( Display *dpy, Window w)
+ {
+ static const unsigned MWM_HINTS_DECORATIONS = (1 << 1);
+ static const int PROP_MOTIF_WM_HINTS_ELEMENTS = 5;
+
+ typedef struct
+ {
+ unsigned long flags;
+ unsigned long functions;
+ unsigned long decorations;
+ long inputMode;
+ unsigned long status;
+ } PropMotifWmHints;
+
+ PropMotifWmHints motif_hints;
+ Atom prop, proptype;
+ unsigned long flags = 0;
+
+ /* setup the property */
+ motif_hints.flags = MWM_HINTS_DECORATIONS;
+ motif_hints.decorations = flags;
+
+ /* get the atom for the property */
+ prop = XInternAtom( dpy, "_MOTIF_WM_HINTS", True );
+ if (!prop) {
+ /* something went wrong! */
+ return;
+ }
+
+ /* not sure this is correct, seems to work, XA_WM_HINTS didn't work */
+ proptype = prop;
+
+ XChangeProperty( dpy, w, /* display, window */
+ prop, proptype, /* property, type */
+ 32, /* format: 32-bit datums */
+ PropModeReplace, /* mode */
+ (unsigned char *) &motif_hints, /* data */
+ PROP_MOTIF_WM_HINTS_ELEMENTS /* nelements */
+ );
+ }
+|#
+
+(define (make-window dpy name geometry)
+ (%trace ";make-window "dpy" "name" "geometry"\n")
+ ;; Create an RGB, double-buffered window.
+ ;; Return the window and context handles.
+
+ (let* ((attribs (make-attribs
+ `(
+ ;; Singleton attributes.
+ ,(C-enum "GLX_RGBA")
+ ,(C-enum "GLX_DOUBLEBUFFER")
+ ,@(if stereo (list (C-enum "GLX_STEREO")) '())
+
+ ;; Key/value attributes.
+ ,(C-enum "GLX_RED_SIZE") 1
+ ,(C-enum "GLX_GREEN_SIZE") 1
+ ,(C-enum "GLX_BLUE_SIZE") 1
+ ,(C-enum "GLX_DEPTH_SIZE") 1
+ ,@(if (> samples 0)
+ (list (C-enum "GLX_SAMPLE_BUFFERS") 1
+ (C-enum "GLX_SAMPLES") samples)
+ '())
+ ,(C-enum "None"))))
+ (scrnum (C-call "DefaultScreen" dpy))
+ (root (C-call "RootWindow" dpy scrnum))
+ (visinfo (C-call "glXChooseVisual" (make-alien '|XVisualInfo|)
+ dpy scrnum attribs)))
+ (if (alien-null? visinfo)
+ (error (string-append
+ "couldn't get an RGB, Double-buffered"
+ (if stereo ", Stereo" "")
+ (if (> samples 0) ", Multisample" "")
+ " visual\n")))
+ (%trace ";glXChooseVisual => "visinfo"\n")
+ (free attribs)
+
+ ;; window attributes
+ (let ((attr (malloc (C-sizeof "XSetWindowAttributes")
+ '|XSetWindowAttibutes|)))
+ (C->= attr "XSetWindowAttributes background_pixel" 0)
+ (C->= attr "XSetWindowAttributes border_pixel" 0)
+ (let ((colormap (C-call "XCreateColormap" dpy root
+ (C-> visinfo "XVisualInfo visual")
+ (C-enum "AllocNone"))))
+ (%trace ";XCreateColormap => "colormap"\n")
+ (C->= attr "XSetWindowAttributes colormap" colormap))
+ (C->= attr "XSetWindowAttributes event_mask"
+ (bit-ior (C-enum "StructureNotifyMask")
+ (C-enum "ExposureMask")
+ (C-enum "KeyPressMask")))
+ ;; XXX this is a bad way to get a borderless window!
+ (let* ((mask (bit-ior (C-enum "CWBackPixel")
+ (C-enum "CWBorderPixel")
+ (C-enum "CWColormap")
+ (C-enum "CWEventMask")))
+ (win (C-call "XCreateWindow" dpy root
+ (vector-ref geometry 0) ;x
+ (vector-ref geometry 1) ;y
+ (vector-ref geometry 2) ;width
+ (vector-ref geometry 3) ;height
+ 0 ;pixmap
+ (C-> visinfo "XVisualInfo depth")
+ (C-enum "InputOutput") ;type
+ (C-> visinfo "XVisualInfo visual")
+ mask ;valuemask
+ attr)))
+ (%trace ";XCreateWindow => "win"\n")
+ (if fullscreen
+ (no-border dpy win))
+
+ ;; set hints and properties
+ (let ((hints (malloc (C-sizeof "XSizeHints") '|XSizeHints|)))
+ (C->= hints "XSizeHints x" (vector-ref geometry 0))
+ (C->= hints "XSizeHints y" (vector-ref geometry 1))
+ (C->= hints "XSizeHints width" (vector-ref geometry 2))
+ (C->= hints "XSizeHints height" (vector-ref geometry 3))
+ (C->= hints "XSizeHints flags" (bit-ior (C-enum "USSize")
+ (C-enum "USPosition")))
+ (C-call "XSetNormalHints" dpy win hints)
+ (C-call "XSetStandardProperties"
+ dpy win name name (C-enum "None") 0 0 hints)
+ (%trace ";XSetNormalHints\n")
+ (free hints))
+
+ (%trace ";glXCreateContext\n")
+ (let ((ctx (C-call "glXCreateContext" (make-alien '|GLXContext|)
+ dpy visinfo 0 (C-enum "True"))))
+ (if (alien-null? ctx)
+ (error "glXCreateContext failed"))
+
+ (%trace ";glXCreateContext => "ctx"\n")
+ (C-call "XFree" visinfo)
+
+ (cons win ctx))))))
+
+(define (make-attribs attribs)
+ (let* ((len (length attribs))
+ (alien (malloc (fix:* len (C-sizeof "int")) '|int|)))
+ (do ((attribs attribs (cdr attribs))
+ (i 0 (fix:1+ i)))
+ ((fix:= i len))
+ (let ((attrib (car attribs)))
+ (guarantee-integer attrib 'make-attribs)
+ (c-poke-int alien (fix:* i (C-sizeof "int")) attrib)))
+ alien))
+
+(define (query-vsync dpy win)
+ (declare (ignore dpy win))
+ unspecific)
+#|
+ /**
+ * Determine whether or not a GLX extension is supported.
+ */
+ static int
+ is_glx_extension_supported(Display *dpy, const char *query)
+ {
+ const int scrnum = DefaultScreen(dpy);
+ const char *glx_extensions = NULL;
+ const size_t len = strlen(query);
+ const char *ptr;
+
+ if (glx_extensions == NULL) {
+ glx_extensions = glXQueryExtensionsString(dpy, scrnum);
+ }
+
+ ptr = strstr(glx_extensions, query);
+ return ((ptr != NULL) && ((ptr[len] == ' ') || (ptr[len] == '\0')));
+ }
+
+
+ /**
+ * Attempt to determine whether or not the display is synched to vblank.
+ */
+ static void
+ query_vsync(Display *dpy, GLXDrawable drawable)
+ {
+ int interval = 0;
+
+ #if defined(GLX_EXT_swap_control)
+ if (is_glx_extension_supported(dpy, "GLX_EXT_swap_control")) {
+ unsigned int tmp = -1;
+ glXQueryDrawable(dpy, drawable, GLX_SWAP_INTERVAL_EXT, &tmp);
+ interval = tmp;
+ } else
+ #endif
+ if (is_glx_extension_supported(dpy, "GLX_MESA_swap_control")) {
+ PFNGLXGETSWAPINTERVALMESAPROC pglXGetSwapIntervalMESA =
+ (PFNGLXGETSWAPINTERVALMESAPROC)
+ glXGetProcAddressARB((const GLubyte *) "glXGetSwapIntervalMESA");
+
+ interval = (*pglXGetSwapIntervalMESA)();
+ } else if (is_glx_extension_supported(dpy, "GLX_SGI_swap_control")) {
+ /* The default swap interval with this extension is 1. Assume that it
+ * is set to the default.
+ *
+ * Many Mesa-based drivers default to 0, but all of these drivers also
+ * export GLX_MESA_swap_control. In that case, this branch will never
+ * be taken, and the correct result should be reported.
+ */
+ interval = 1;
+ }
+
+
+ if (interval > 0) {
+ printf("Running synchronized to the vertical refresh. The framerate should be\n");
+ if (interval == 1) {
+ printf("approximately the same as the monitor refresh rate.\n");
+ } else if (interval > 1) {
+ printf("approximately 1/%d the monitor refresh rate.\n",
+ interval);
+ }
+ }
+ }
+|#
+
+(define (handle-event dpy win event)
+ (declare (ignore dpy win))
+ ;; Handle one X event.
+ ;; \return NOP, EXIT or DRAW
+
+ (let ((type (C-> event "XEvent type")))
+ (cond ((int:= type (C-enum "Expose"))
+ (%trace ";handle-event Expose\n")
+ 'DRAW)
+ ((int:= type (C-enum "ConfigureNotify"))
+ (%trace ";handle-event ConfigureNotify\n")
+ (reshape (C-> event "XConfigureEvent width")
+ (C-> event "XConfigureEvent height"))
+ 'DRAW)
+ ((int:= type (C-enum "KeyPress"))
+ (%trace ";handle-event KeyPress\n")
+ (let ((code (C-call "XLookupKeysym" event 0)))
+ (cond ((int:= code (C-enum "XK_Left"))
+ (set! view-roty (+ view-roty 5.))
+ 'DRAW)
+ ((int:= code (C-enum "XK_Right"))
+ (set! view-roty (- view-roty 5.))
+ 'DRAW)
+ ((int:= code (C-enum "XK_Up"))
+ (set! view-rotx (+ view-rotx 5.))
+ 'DRAW)
+ ((int:= code (C-enum "XK_Down"))
+ (set! view-rotx (- view-rotx 5.))
+ 'DRAW)
+ (else
+ (let ((buffer (malloc 10 'char)))
+ (C-call "XLookupString" event buffer 10 0 0)
+ (let ((buffer0 (C-> buffer "char")))
+ (cond ((= buffer0 27)
+ ;; escape
+ 'EXIT)
+ ((or (= buffer0 (char->ascii #\a))
+ (= buffer0 (char->ascii #\A)))
+ (set! animate (not animate))
+ 'DRAW)
+ (else 'DRAW))))))))
+ (else
+ (%trace ";handle-event "type"\n")
+ 'NOP))))
+
+(define (event-loop dpy win)
+ (%trace ";event-loop\n")
+ (let while-loop ()
+ (let ((op
+ (let while-loop ()
+ (if (or (not animate) (> (C-call "XPending" dpy) 0))
+ (let ((event (malloc (C-sizeof "XEvent") '|XEvent|)))
+ (C-call "XNextEvent" dpy event)
+ (let ((op (handle-event dpy win event)))
+ (%trace ";handle-event => "op"\n")
+ (free event)
+ (if (memq op '(EXIT DRAW))
+ op
+ (while-loop))))))))
+ (if (eq? op 'EXIT)
+ 'EXIT
+ (begin
+ (draw-frame dpy win)
+ (while-loop))))))
+
+(define (usage-error . msg)
+ (display "Usage:\n")
+ (display " -display <displayname> set the display to run on\n")
+ (display " -stereo run in stereo mode\n")
+ (display " -samples N run in multisample mode with at least N samples\n")
+ (display " -fullscreen run in fullscreen mode\n")
+ (display " -info display OpenGL renderer info\n")
+ (display " -geometry WxH+X+Y window geometry\n")
+ (apply error msg))
+
+(define (main)
+ (let* ((commandline (command-line))
+ (printInfo (member "-info" commandline)))
+ (set! stereo (member "-stereo" commandline))
+ (set! samples (let ((entry (member "-samples" commandline)))
+ (if (pair? entry)
+ (if (pair? (cdr entry))
+ (let ((num (cadr entry)))
+ (or (number->string num)
+ (usage-error "Samples not a number:" num)))
+ (usage-error "Number of samples not specified."))
+ 0)))
+ (set! fullscreen (member "-fullscreen" commandline))
+ (let* ((geometry
+ (let ((entry (member "-geometry" commandline)))
+ (if (pair? entry)
+ (if (pair? (cdr entry))
+ (let* ((string (cadr entry))
+ (results (malloc (fix:* 4 (C-sizeof "int")) #f))
+ (x (C-array-loc results "int" 0))
+ (y (C-array-loc results "int" 1))
+ (width (C-array-loc results "int" 2))
+ (height (C-array-loc results "int" 3))
+ (result
+ (C-call "XParseGeometry"
+ string x y width height))
+ (v (vector
+ (if (bit? result (C-enum "XValue"))
+ (C-> x "int") 0)
+ (if (bit? result (C-enum "YValue"))
+ (C-> y "int") 0)
+ (if (bit? result (C-enum "WidthValue"))
+ (C-> width "uint") 300)
+ (if (bit? result (C-enum "HeightValue"))
+ (C-> height "uint") 300))))
+ (free results)
+ v)
+ (usage-error "Geometry not specified."))
+ (vector 0 0 300 300))))
+ (dpyName
+ (let ((entry (member "-display" commandline)))
+ (if (pair? entry)
+ (if (pair? (cdr entry))
+ (cadr entry)
+ (error "Display not specified."))
+ 0)))
+ (dpy (C-call "XOpenDisplay" (make-alien '|Display|) dpyName)))
+ (if (alien-null? dpy)
+ (error "couldn't open display:" (if (zero? dpyName) "" dpyName)))
+
+ (if fullscreen
+ (let ((scrnum (C-call "DefaultScreen" dpy)))
+ (vector-set! geometry 0 0)
+ (vector-set! geometry 1 0)
+ (vector-set! geometry 2 (C-call "DisplayWidth" dpy scrnum))
+ (vector-set! geometry 3 (C-call "DisplayHeight" dpy scrnum))))
+
+ (let* ((win.ctx (make-window dpy "glxgears" geometry))
+ (win (car win.ctx))
+ (ctx (cdr win.ctx)))
+ (%trace ";XMapWindow\n")
+ (C-call "XMapWindow" dpy win)
+
+ (with-gl-library
+ (lambda ()
+ (%trace ";glXMakeCurrent\n")
+ (C-call "glXMakeCurrent" dpy win ctx)
+ (query-vsync dpy win)
+
+ (if printInfo
+ (for-each
+ display
+ (list "GL_RENDERER = "(get-string 'RENDERER)"\n"
+ "GL_VERSION = "(get-string 'VERSION)"\n"
+ "GL_VENDOR = "(get-string 'VENDOR)"\n"
+ "GL_EXTENSIONS = "(get-string 'EXTENSIONS)"\n")))
+
+ (init)
+
+ ;; Set initial projection/viewing transformation.
+ ;; We can't be sure we'll get a ConfigureNotify event when the
+ ;; window first appears.
+ (reshape (vector-ref geometry 2) (vector-ref geometry 3))
+
+ (event-loop dpy win)
+
+ (gl:delete-lists gear1 1)
+ (gl:delete-lists gear2 1)
+ (gl:delete-lists gear3 1)
+ (C-call "glXMakeCurrent" dpy (C-enum "None") 0)))
+
+ (C-call "glXDestroyContext" dpy ctx)
+ (C-call "XDestroyWindow" dpy win)
+ (C-call "XCloseDisplay" dpy)))))
+
+(define-integrable 2pi (* 8. (flo:atan2 1. 1.)))
+
+(define (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 (flo:4d r g b a)
+ (let ((v (flo:vector-cons 4)))
+ (flo:vector-set! v 0 r)
+ (flo:vector-set! v 1 g)
+ (flo:vector-set! v 2 b)
+ (flo:vector-set! v 3 a)
+ v))
+
+(define-integrable color flo:4d)
+
+(define-integrable (bit? int mask)
+ (not (int:zero? (bitwise-and int mask))))
+
+(declare (integrate-operator bit-ior))
+(define (bit-ior . ints)
+ (reduce bitwise-ior 0 ints))
+
+(define c-poke-int (make-primitive-procedure 'C-POKE-INT 3))
+
+(define (get-string symbol)
+ (c-peek-cstring
+ (case symbol
+ ((renderer)
+ (C-call "glGetString" (make-alien 'char) (C-enum "GL_RENDERER")))
+ ((version)
+ (C-call "glGetString" (make-alien 'char) (C-enum "GL_VERSION")))
+ ((vendor)
+ (C-call "glGetString" (make-alien 'char) (C-enum "GL_VENDOR")))
+ ((extensions)
+ (C-call "glGetString" (make-alien 'char) (C-enum "GL_EXTENSIONS")))
+ (else
+ (error "Unknown gl String:" symbol)))))
+
+(define (%trace . args)
+ (declare (ignore args))
+ #;(for-each display args)
+ unspecific)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Load the GL option. |#
+
+(define ((option-note-writer option) port)
+ (write-string "Loading " port)
+ (write-string (symbol-name option) port)
+ (write-string " option" port))
+
+(with-notification
+ (option-note-writer 'GL)
+ (lambda ()
+ (load-option 'GTK)
+ (fluid-let ((load/suppress-loading-message? #t))
+ (load-package-set "gl"))
+ (add-subsystem-identification! "GL" '(0 1))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff