From: Matt Birkholz Date: Thu, 31 Oct 2013 20:02:24 +0000 (-0700) Subject: gl: New wrapper for libGL, libGLU. X-Git-Tag: mit-scheme-pucked-9.2.12~440 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a83fc7e51fc042b0602b923df771bde36805a108;p=mit-scheme.git gl: New wrapper for libGL, libGLU. --- diff --git a/src/gl/Makefile.in b/src/gl/Makefile.in new file mode 100644 index 000000000..c547a6b61 --- /dev/null +++ b/src/gl/Makefile.in @@ -0,0 +1,137 @@ +# 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 $< + +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 $< diff --git a/src/gl/check.scm b/src/gl/check.scm new file mode 100644 index 000000000..c1b8470a9 --- /dev/null +++ b/src/gl/check.scm @@ -0,0 +1,10 @@ +#| -*-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 diff --git a/src/gl/compile.scm b/src/gl/compile.scm new file mode 100644 index 000000000..4179692b0 --- /dev/null +++ b/src/gl/compile.scm @@ -0,0 +1,53 @@ +#| -*-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-timeenvironment '(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 diff --git a/src/gl/configure.ac b/src/gl/configure.ac new file mode 100644 index 000000000..19801f6a8 --- /dev/null +++ b/src/gl/configure.ac @@ -0,0 +1,64 @@ +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 diff --git a/src/gl/gl-adapter.c b/src/gl/gl-adapter.c new file mode 100644 index 000000000..0585393c2 --- /dev/null +++ b/src/gl/gl-adapter.c @@ -0,0 +1,187 @@ +/* -*-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 +#include +#include +#include + +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); +} diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm new file mode 100644 index 000000000..62d5a12b6 --- /dev/null +++ b/src/gl/gl-glx.scm @@ -0,0 +1,386 @@ +#| -*-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))) + +#| Replace gdk_window_new with XCreateWindow, following example of + . + + (define-class ( (constructor () (width height))) + () + + ;; 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 ") + + (define-integrable guarantee-size guarantee-non-negative-fixnum) + + (define-method initialize-instance ((widget ) width height) + (call-next-method widget) + (%trace "; (initialize-instance ) "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 ( (constructor () (width height))) + () + + (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 ) 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 )) + (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 )) + (%trace "; (fix-widget-realize-callback ) "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 diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm new file mode 100644 index 000000000..c38e19c48 --- /dev/null +++ b/src/gl/gl-glxgears.scm @@ -0,0 +1,557 @@ +#| -*-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 ( + (constructor %make-glxgears-demo () (width height))) + () + (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 ) width height) + (call-next-method widget width height) + (make-animation-thread widget)) + +(define-method fix-widget-new-geometry-callback ((widget )) + (%trace "; (fix-widget-new-geometry-callback )\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 diff --git a/src/gl/gl-gtkglext.scm b/src/gl/gl-gtkglext.scm new file mode 100644 index 000000000..d34e1ce15 --- /dev/null +++ b/src/gl/gl-gtkglext.scm @@ -0,0 +1,134 @@ +#| -*-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-window define standard) + (context define standard)) + +(define-method initialize-instance ((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 diff --git a/src/gl/gl-shim.h b/src/gl/gl-shim.h new file mode 100644 index 000000000..5fdadaaeb --- /dev/null +++ b/src/gl/gl-shim.h @@ -0,0 +1,28 @@ +/* -*-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 +#include +/* #include for gluLookAt, which doesn't need a declaration(?) */ diff --git a/src/gl/gl.cdecl b/src/gl/gl.cdecl new file mode 100644 index 000000000..5794d2b17 --- /dev/null +++ b/src/gl/gl.cdecl @@ -0,0 +1,289 @@ +#| -*-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)) + +(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)) + +(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 diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg new file mode 100644 index 000000000..80bf1b3ab --- /dev/null +++ b/src/gl/gl.pkg @@ -0,0 +1,124 @@ +#| -*-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-realize-callback) + (export (gl) + make-glx-device with-glx-device glx:swap-buffers )) + +(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 diff --git a/src/gl/gl.scm b/src/gl/gl.scm new file mode 100644 index 000000000..d5fd4d72a --- /dev/null +++ b/src/gl/gl.scm @@ -0,0 +1,290 @@ +#| -*-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")) + +(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 diff --git a/src/gl/glxgears-compile.scm b/src/gl/glxgears-compile.scm new file mode 100644 index 000000000..9d7cc7f3e --- /dev/null +++ b/src/gl/glxgears-compile.scm @@ -0,0 +1,44 @@ +#| -*-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 diff --git a/src/gl/glxgears-shim.h b/src/gl/glxgears-shim.h new file mode 100644 index 000000000..8a917dfb0 --- /dev/null +++ b/src/gl/glxgears-shim.h @@ -0,0 +1,27 @@ +/* -*-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 +#include diff --git a/src/gl/glxgears.cdecl b/src/gl/glxgears.cdecl new file mode 100644 index 000000000..68d540e7c --- /dev/null +++ b/src/gl/glxgears.cdecl @@ -0,0 +1,217 @@ +#| -*-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)) diff --git a/src/gl/glxgears.pkg b/src/gl/glxgears.pkg new file mode 100644 index 000000000..3bbb654f3 --- /dev/null +++ b/src/gl/glxgears.pkg @@ -0,0 +1,11 @@ +#| -*-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 diff --git a/src/gl/glxgears.scm b/src/gl/glxgears.scm new file mode 100644 index 000000000..3449b0f7b --- /dev/null +++ b/src/gl/glxgears.scm @@ -0,0 +1,771 @@ +#| -*-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 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 diff --git a/src/gl/make.scm b/src/gl/make.scm new file mode 100644 index 000000000..dc5b77474 --- /dev/null +++ b/src/gl/make.scm @@ -0,0 +1,16 @@ +#| -*-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