1 files changed, 268 insertions, 0 deletions
diff --git a/2d/shader.scm b/2d/shader.scm
new file mode 100644
index 0000000..86fc1e2
--- /dev/null
+++ b/2d/shader.scm
@@ -0,0 +1,268 @@
+(define-module (2d shader)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-4)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 rdelim)
+  #:use-module (figl gl)
+  #:use-module (figl gl low-level)
+  #:use-module (2d helpers)
+  #:use-module (2d vector2)
+  #:use-module (2d color)
+  #:export (make-shader
+            make-vertex-shader
+            make-fragment-shader
+            load-shader
+            load-vertex-shader
+            load-fragment-shader
+            shader?
+            shader-compiled?
+            shader-type
+            shader-id
+            make-shader-program
+            shader-program?
+            shader-program-linked?
+            with-shader-program
+            %uniform-setters
+            register-uniform-setter!
+            uniforms))
+
+(define-syntax-rule (define-logger name length-proc log-proc)
+  (define (name obj)
+    (let ((log-length (u32vector 0)))
+      (length-proc obj (version-2-0 info-log-length)
+                   (bytevector->pointer log-length))
+      (let ((log (make-u8vector (1+ (u32vector-ref log-length 0)))))
+        (log-proc obj (u32vector-ref log-length 0) %null-pointer
+                  (bytevector->pointer log))
+        (format #t "~a\n" (utf8->string log))))))
+
+(define-syntax-rule (define-status name status-proc status-name)
+  (define (name obj)
+    (let ((status (u32vector 0)))
+      (status-proc obj (version-2-0 status-name)
+                   (bytevector->pointer status))
+      (= (u32vector-ref status 0) 1))))
+
+;;;
+;;; Shaders
+;;;
+
+(define-record-type <shader>
+  (%make-shader type id)
+  shader?
+  (type shader-type)
+  (id shader-id))
+
+(define-guardian shader-guardian
+  (lambda (shader)
+    (false-if-exception
+     (glDeleteShader (shader-id shader)))))
+
+;; Reap GL shaders when their wrapper objects are GC'd.
+(define-guardian shader-guardian
+  (lambda (shader)
+    (false-if-exception (glDeleteShader (shader-id shader)))))
+
+(define-status %shader-compiled? glGetShaderiv compile-status)
+
+(define (shader-compiled? shader)
+  (%shader-compiled? (shader-id shader)))
+
+(define-logger %display-compilation-error glGetShaderiv glGetShaderInfoLog)
+
+(define (display-compilation-error shader)
+  (%display-compilation-error (shader-id shader)))
+
+(define (compile-shader shader)
+  "Attempt to compiler SHADER.  Compilation errors are written to
+stdout."
+  (glCompileShader (shader-id shader))
+  (unless (shader-compiled? shader)
+    (display "Failed to compile shader:\n")
+    (display-compilation-error shader)))
+
+(define (set-shader-source shader source)
+  "Use the GLSL source code in the string SOURCE for SHADER."
+  (let ((length (u32vector (string-length source)))
+        (str (u64vector (pointer-address (string->pointer source)))))
+    (glShaderSource (shader-id shader) 1 (bytevector->pointer str)
+                    (bytevector->pointer length))))
+
+(define (gl-shader-type type)
+  "Convert the symbol TYPE to the appropriate OpenGL shader constant."
+  (cond ((eq? type 'vertex)
+         (version-2-0 vertex-shader))
+        ((eq? type 'fragment)
+         (version-2-0 fragment-shader))
+        (else
+         (error "Invalid shader type: " type))))
+
+(define (make-shader type source)
+  "Create a new GLSL shader of the given TYPE (vertex or fragment) and
+compile the GLSL program contained in the string SOURCE."
+  (let* ((id (glCreateShader (gl-shader-type type)))
+         (shader (%make-shader type id)))
+    (shader-guardian shader)
+    (set-shader-source shader source)
+    (compile-shader shader)
+    shader))
+
+(define (make-vertex-shader source)
+  "Create a new GLSL vertex shader and compile the GLSL program
+contained in the string SOURCE."
+  (make-shader 'vertex source))
+
+(define (make-fragment-shader source)
+  "Create a new GLSL fragment shader and compile the GLSL program
+contained in the string SOURCE."
+  (make-shader 'fragment source))
+
+(define (load-shader type filename)
+  "Create a new GLSL shader of the given TYPE (vertex or fragment) and
+compile the GLSL program stored in the file FILENAME."
+  (make-shader type (call-with-input-file filename read-string)))
+
+(define (load-vertex-shader filename)
+  "Create a new GLSL vertex shader and compile the GLSL program stored
+in the file FILENAME."
+  (load-shader 'vertex filename))
+
+(define (load-fragment-shader filename)
+  "Create a new GLSL vertex shader and compile the GLSL program stored
+in the file FILENAME."
+  (load-shader 'fragment filename))
+
+;;;
+;;; Programs
+;;;
+
+(define-record-type <shader-program>
+  (%make-shader-program id)
+  shader-program?
+  (id shader-program-id))
+
+(define-guardian shader-program-guardian
+  (lambda (shader-program)
+    (false-if-exception
+     (glDeleteProgram (shader-program-id shader-program)))))
+
+(define-status %shader-program-linked? glGetProgramiv link-status)
+
+(define (shader-program-linked? shader-program)
+  "Return #t if SHADER-PROGRAM has been successfully linked with
+shaders or #f otherwise."
+  (%shader-program-linked? (shader-program-id shader-program)))
+
+(define-logger %display-linking-error glGetProgramiv glGetProgramInfoLog)
+
+(define (display-linking-error shader-program)
+  (%display-linking-error (shader-program-id shader-program)))
+
+(define (make-shader-program . shaders)
+  "Create a new shader program that has been linked with the given
+SHADERS."
+  (let* ((id (glCreateProgram))
+         (shader-program (%make-shader-program id)))
+    (shader-program-guardian shader-program)
+    (for-each (lambda (shader)
+                (glAttachShader id (shader-id shader)))
+              shaders)
+    (glLinkProgram id)
+    (unless (shader-program-linked? shader-program)
+      (display "Failed to link shader program:\n")
+      (display-linking-error shader-program))
+    ;; Once the program has been linked, the shaders can be detached.
+    (for-each (lambda (shader)
+                (glDetachShader id (shader-id shader)))
+              shaders)
+    shader-program))
+
+(define current-shader-program (make-parameter #f))
+
+(define-syntax-rule (with-shader-program shader-program body ...)
+  "Evaluate BODY with SHADER-PROGRAM bound."
+  (parameterize ((current-shader-program shader-program))
+    (begin
+      (glUseProgram (shader-program-id shader-program))
+      (let ((return-value (begin body ...)))
+        (glUseProgram 0)
+        return-value))))
+
+(define-record-type <uniform-setter>
+  (make-uniform-setter predicate proc)
+  uniform-setter?
+  (predicate uniform-setter-predicate)
+  (proc uniform-setter-proc))
+
+(define %uniform-setters '())
+
+(define (register-uniform-setter! predicate setter)
+  "Add a new type of uniform setter for shader programs where
+PREDICATE tests the type of a given value and SETTER performs the
+necessary OpenGL calls to set the uniform value in the proper
+location."
+  (set! %uniform-setters
+        (cons (make-uniform-setter predicate setter)
+              %uniform-setters)))
+
+;; Built-in uniform setters for booleans, numbers, vector2s, and
+;; colors.
+(register-uniform-setter! boolean?
+                          (lambda (location b)
+                            (glUniform1i location (if b 1 0))))
+
+(register-uniform-setter! number?
+                          (lambda (location n)
+                            (glUniform1f location n)))
+
+(register-uniform-setter! vector2?
+                          (lambda (location v)
+                            ;; Use a vec4 instead of vec2 because it
+                            ;; seems to be a lot easier to deal with
+                            ;; vec4s.
+                            (glUniform4f location (vx v) (vy v) 0 0)))
+
+(register-uniform-setter! color?
+                          (lambda (location c)
+                            (glUniform4f location
+                                         (color-r c)
+                                         (color-g c)
+                                         (color-b c)
+                                         (color-a c))))
+
+(define (uniform-location shader-program name)
+  "Retrieve the location for the uniform NAME within SHADER-PROGRAM."
+  (glGetUniformLocation (shader-program-id shader-program) name))
+
+(define (uniform-set! shader-program name value)
+  "Use the appropriate setter procedure to translate VALUE into OpenGL
+compatible data and assign it to the location of the uniform NAME
+within SHADER-PROGRAM."
+  (let ((setter (find (lambda (setter)
+                        ((uniform-setter-predicate setter) value))
+                      %uniform-setters))
+        (location (uniform-location shader-program name)))
+    (if setter
+        ((uniform-setter-proc setter) location value)
+        (error "Not a valid uniform data type" value))))
+
+;; Bind values to uniform variables within the current shader program
+;; via a let-style syntax.  The types of the given values must be
+;; accounted for in the %uniform-setters list.  This macro simply sets
+;; uniform values and does not restore the previous values after
+;; evaluating the body of the form.
+;;
+;; emacs: (put 'uniforms 'scheme-indent-function 1)
+(define-syntax uniforms
+  (syntax-rules ()
+    ((_ () body ...)
+     (begin body ...))
+    ((_ ((name value) ...) body ...)
+     (begin
+       (uniform-set! (current-shader-program)
+                     (symbol->string 'name)
+                     value)
+       ...
+       body ...))))