initial glut bindings

* figl/glut/low-level.scm: Low-level bindings.

* figl/glut.scm: Initial high-level bindings; only one helper for
  glut-init.

diff --git a/figl/glut.scm b/figl/glut.scm
new file mode 100644 (file)
index 0000000..d72d8f6
--- /dev/null
+++ b/figl/glut.scm
@@ -0,0 +1,61 @@
+;;; figl
+;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
+;;; 
+;;; Figl is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;; 
+;;; Figl 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 Lesser General
+;;; Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; figl is the Foreign Interface to GL.
+;;
+;;; Code:
+
+(define-module (figl glut)
+  #:use-module (figl glut low-level)
+  #:use-module (system foreign)
+  #:use-module (srfi srfi-39) ; parameter objects
+  #:export (glut-init))
+
+;; TODO: Most procedures should prevent themself from being called
+;; before glut-init.
+
+(define glut-init? (make-parameter #f))
+
+;; Note the use of 'saved-c-strings' to keep a reference to all of the
+;; C string buffers that we ever pass to 'glutInit'. This is important
+;; because the glut docs specify that 'glutInit' wants the original
+;; unmodified 'argv' passed to 'main', which means that it can assume
+;; that the strings will never be freed. 'string->pointer' returns a C
+;; string buffer managed by the garbage collector, which means that
+;; the string may be freed unless the GC can see a pointer to the
+;; _beginning_ of the string.
+(define glut-init
+  (let ((saved-c-strings '()))
+    (lambda (args)
+      ;; Avoid calling init twice as GLUT will exit().
+      (unless (glut-init?)
+        (let* ((num-args (length args))
+               (c-strings (map string->pointer args))
+               (argcp (make-c-struct (list int)
+                                     (list num-args)))
+               (argv (make-c-struct (make-list (+ 1 num-args) '*)
+                                    (append c-strings
+                                            (list %null-pointer)))))
+          (set! saved-c-strings (append c-strings saved-c-strings))
+          (glutInit argcp argv)
+          (glut-init? #t)
+          (let ((argc (car (parse-c-struct argcp (list int)))))
+            (map pointer->string
+                 (parse-c-struct argv
+                                 (make-list argc '*)))))))))

diff --git a/figl/glut/low-level.scm b/figl/glut/low-level.scm
new file mode 100644 (file)
index 0000000..786da99
--- /dev/null
+++ b/figl/glut/low-level.scm
@@ -0,0 +1,621 @@
+;;; fgil
+;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
+;;; 
+;;; Figl is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;; 
+;;; Figl 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 Lesser General
+;;; Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; These bindings are direct mappings to the OpenGL Utility Library
+;; (GLUT) Programming Interface, API Version 3.
+;;
+;; Care should be taken to avoid errors as GLUT implementations may
+;; exit() on error condition.  See section 14.3 of the specification.
+;;
+;;; Code:
+
+(define-module (figl glut low-level)
+  #:use-module (figl runtime)
+  #:use-module (figl gl types)
+  #:use-module ((system foreign) #:renamer (symbol-prefix-proc 'ffi:))
+  #:use-module (srfi srfi-26) ; cut
+  #:export (;; 2 Initialization
+            glutInit
+            glutInitWindowPosition
+            glutInitWindowSize
+            glutInitDisplayMode
+
+            ;; 3 Begin Event Processing
+            glutMainLoop
+
+            ;; 4 Window Management
+            glutCreateWindow
+            glutCreateSubWindow
+            glutSetWindow
+            glutGetWindow
+            glutDestroyWindow
+            glutPostRedisplay
+            glutSwapBuffers
+            glutPositionWindow
+            glutReshapeWindow
+            glutFullScreen
+            glutPopWindow
+            glutPushWindow
+            glutShowWindow
+            glutHideWindow
+            glutIconifyWindow
+            glutSetWindowTitle
+            glutSetIconTitle
+            glutSetCursor
+
+            ;; 5 Overlay Management
+            glutEstablishOverlay
+            glutUseLayer
+            glutRemoveOverlay
+            glutPostOverlayRedisplay
+            glutShowOverlay
+            glutHideOverlay
+
+            ;; 6 Menu Management
+            glutCreateMenu
+            glutSetMenu
+            glutGetMenu
+            glutDestroyMenu
+            glutAddMenuEntry
+            glutAddSubMenu
+            glutChangeToMenuEntry
+            glutChangeToSubMenu
+            glutRemoveMenuItem
+            glutAttachMenu
+            glutDetachMenu
+
+            ;; 7 Callback Registration
+            glutDisplayFunc
+            glutOverlayDisplayFunc
+            glutReshapeFunc
+            glutKeyboardFunc
+            glutMouseFunc
+            glutMotionFunc
+            glutPassiveMotionFunc
+            glutVisibilityFunc
+            glutEntryFunc
+            glutSpecialFunc
+            glutSpaceballMotionFunc
+            glutSpaceballRotateFunc
+            glutSpaceballButtonFunc
+            glutButtonBoxFunc
+            glutDialsFunc
+            glutTabletMotionFunc
+            glutTabletButtonFunc
+            glutMenuStatusFunc
+            glutMenuStateFunc
+            glutIdleFunc
+            glutTimerFunc
+
+            ;; 8 Color Index Colormap Management
+            glutSetColor
+            glutGetColor
+            glutCopyColormap
+
+            ;; 9 State Retrieval
+            glutGet
+            glutLayerGet
+            glutDeviceGet
+            glutGetModifiers
+            glutExtensionSupported
+
+            ;; 10 Font Rendering
+            glutBitmapCharacter
+            glutBitmapWidth
+            glutStrokeCharacter
+            glutStrokeWidth
+
+            ;; 11 Geometric Object Rendering
+            glutSolidSphere
+            glutWireSphere
+            glutSolidCube
+            glutWireCube
+            glutSolidCone
+            glutWireCone
+            glutSolidTorus
+            glutWireTorus
+            glutSolidDodecahedron
+            glutWireDodecahedron
+            glutSolidOctahedron
+            glutWireOctahedron
+            glutSolidTetrahedron
+            glutWireTetrahedron
+            glutSolidIcosahedron
+            glutWireIcosahedron
+            glutSolidTeapot
+            glutWireTeapot
+            ))
+
+(define libglut (dynamic-link "libglut"))
+
+(define (glut-resolver name)
+  (dynamic-pointer name libglut))
+
+(current-resolver glut-resolver)
+
+(define-simple-foreign-type int ffi:int)
+(define-simple-foreign-type unsigned-int ffi:unsigned-int)
+
+;; GLUT specifies that all strings are ASCII encoded.
+(define-foreign-type char-* '*
+  (cut ffi:string->pointer <> "ASCII")
+  (cut ffi:pointer->string <> -1 "ASCII"))
+
+(define-simple-foreign-type int-* '*)
+(define-simple-foreign-type char-** '*)
+
+;;;
+;;; 2 Initialization
+;;;
+
+(define-foreign-procedure
+  (glutInit (argcp int-*) (argv char-**) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutInitWindowPosition (x int) (y int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutInitWindowSize (width int) (height int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutInitDisplayMode (mode unsigned-int) -> void)
+  #f)
+
+;;;
+;;; 3 Begin Event Processing
+;;;
+
+(define-foreign-procedure
+  (glutMainLoop -> void)
+  #f)
+
+;;;
+;;; 4 Window Management
+;;;
+
+(define-foreign-procedure
+  (glutCreateWindow (name char-*) -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutCreateSubWindow (win int)
+                       (x int)
+                       (y int)
+                       (width int)
+                       (height int)
+                       ->
+                       int)
+  #f)
+
+(define-foreign-procedure
+  (glutSetWindow (win int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutGetWindow -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutDestroyWindow (win int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutPostRedisplay -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSwapBuffers -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutPositionWindow (x int) (y int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutReshapeWindow (width int) (height int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutFullScreen -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutPopWindow -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutPushWindow -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutShowWindow -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutHideWindow -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutIconifyWindow -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSetWindowTitle (name char-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSetIconTitle (name char-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSetCursor (cursor int) -> void)
+  #f)
+
+\f
+;;;
+;;; 5 Overlay Management
+;;;
+
+(define-foreign-procedure
+  (glutEstablishOverlay -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutUseLayer (layer GLenum) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutRemoveOverlay -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutPostOverlayRedisplay -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutShowOverlay -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutHideOverlay -> void)
+  #f)
+
+\f
+;;;
+;;; 6 Menu Management
+;;;
+
+(define-foreign-procedure
+  (glutCreateMenu (func void-*) -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutSetMenu (menu int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutGetMenu -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutDestroyMenu (menu int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutAddMenuEntry (name char-*) (value int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutAddSubMenu (name char-*) (menu int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutChangeToMenuEntry (entry int)
+                         (name char-*)
+                         (value int)
+                         ->
+                         void)
+  #f)
+
+(define-foreign-procedure
+  (glutChangeToSubMenu (entry int)
+                       (name char-*)
+                       (menu int)
+                       ->
+                       void)
+  #f)
+
+(define-foreign-procedure
+  (glutRemoveMenuItem (entry int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutAttachMenu (button int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutDetachMenu (button int) -> void)
+  #f)
+
+\f
+;;;
+;;; 7 Callback Registration
+;;;
+
+(define-foreign-procedure
+  (glutDisplayFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutOverlayDisplayFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutReshapeFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutKeyboardFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutMouseFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutMotionFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutPassiveMotionFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutVisibilityFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutEntryFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSpecialFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSpaceballMotionFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSpaceballRotateFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSpaceballButtonFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutButtonBoxFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutDialsFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutTabletMotionFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutTabletButtonFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutMenuStatusFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutMenuStateFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutIdleFunc (func void-*) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutTimerFunc (msecs unsigned-int)
+                 (func void-*)
+                 (value int)
+                 ->
+                 void)
+  #f)
+
+\f
+;;;
+;;; 8 Color Index Colormap Management
+;;;
+
+(define-foreign-procedure
+  (glutSetColor (cell int)
+                (red GLfloat)
+                (green GLfloat)
+                (blue GLfloat)
+                ->
+                void)
+  #f)
+
+(define-foreign-procedure
+  (glutGetColor (cell int) (component int) -> GLfloat)
+  #f)
+
+(define-foreign-procedure
+  (glutCopyColormap (win int) -> void)
+  #f)
+
+;;;
+;;; 9 State Retrieval
+;;;
+
+(define-foreign-procedure
+  (glutGet (state GLenum) -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutLayerGet (info GLenum) -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutDeviceGet (info GLenum) -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutGetModifiers -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutExtensionSupported (extension char-*) -> int)
+  #f)
+
+;;;
+;;; 10 Font Rendering
+;;;
+
+(define-foreign-procedure
+  (glutBitmapCharacter (font void-*) (character int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutBitmapWidth (font void-*) (character int) -> int)
+  #f)
+
+(define-foreign-procedure
+  (glutStrokeCharacter (font void-*) (character int) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutStrokeWidth (font void-*) (character int) -> void)
+  #f)
+
+\f
+;;;
+;;; 11 Geometric Object Rendering
+;;;
+
+(define-foreign-procedure
+  (glutSolidSphere (radius GLdouble)
+                   (slices GLint)
+                   (stacks GLint)
+                   ->
+                   void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireSphere (radius GLdouble)
+                  (slices GLint)
+                  (stacks GLint)
+                  ->
+                  void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidCube (size GLdouble) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireCube (size GLdouble) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidCone (base GLdouble)
+                 (height GLdouble)
+                 (slices GLint)
+                 (stacks GLint)
+                 ->
+                 void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireCone (base GLdouble)
+                (height GLdouble)
+                (slices GLint)
+                (stacks GLint)
+                ->
+                void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidTorus (inner-radius GLdouble)
+                  (outer-radius GLdouble)
+                  (sides GLint)
+                  (rings GLint)
+                  ->
+                  void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireTorus (inner-radius GLdouble)
+                 (outer-radius GLdouble)
+                 (sides GLint)
+                 (rings GLint)
+                 ->
+                 void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidDodecahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireDodecahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidOctahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireOctahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidTetrahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireTetrahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidIcosahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireIcosahedron -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutSolidTeapot (size GLdouble) -> void)
+  #f)
+
+(define-foreign-procedure
+  (glutWireTeapot (size GLdouble) -> void)
+  #f)