Rewrite GPU state management layer.

7 files changed, 932 insertions, 24 deletions

diff --git a/Makefile.am b/Makefile.am
index 420b46e..a0bf9dd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -67,6 +67,7 @@ SOURCES = 					\
   chickadee/image/jpeg.scm			\
   chickadee/image/png.scm			\
   chickadee/graphics/gl.scm			\
+  chickadee/graphics/gpu.scm			\
   chickadee/graphics/engine.scm			\
   chickadee/graphics/color.scm			\
   chickadee/graphics/blend.scm			\
diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm
index f2fbfe0..d16ab09 100644
--- a/chickadee/graphics/buffer.scm
+++ b/chickadee/graphics/buffer.scm
@@ -138,7 +138,7 @@
   (%make-buffer 0 "null" 0 0 'vertex 'static #f #f))
 
 (define (free-buffer buffer)
-  (gl-delete-buffers 1 (u32vector (buffer-id buffer))))
+  (gl-delete-buffer (buffer-id buffer)))
 
 (define (bind-buffer buffer)
   (gl-bind-buffer (buffer-target-gl buffer)
@@ -154,9 +154,7 @@
   #:bind bind-buffer)
 
 (define (generate-buffer-gl)
-  (let ((bv (u32vector 1)))
-    (gl-gen-buffers 1 (bytevector->pointer bv))
-    (u32vector-ref bv 0)))
+  (gl-generate-buffer))
 
 (define (index-buffer? buffer)
   "Return #t if VIEW is an index buffer view."
@@ -461,15 +459,10 @@ element is used for 2 instances, and so on."
 (define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))
 
 (define (generate-vertex-array)
-  (let ((bv (u32vector 1)))
-    (gl-gen-vertex-arrays 1 (bytevector->pointer bv))
-    (u32vector-ref bv 0)))
+  (gl-generate-vertex-array))
 
 (define (free-vertex-array va)
-  (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va))))
-
-(define (apply-vertex-array va)
-  (gl-bind-vertex-array (vertex-array-id va)))
+  (gl-delete-vertex-array (vertex-array-id va)))
 
 (define (bind-vertex-array va)
   (gl-bind-vertex-array (vertex-array-id va)))
diff --git a/chickadee/graphics/engine.scm b/chickadee/graphics/engine.scm
index 2bc6463..9598e91 100644
--- a/chickadee/graphics/engine.scm
+++ b/chickadee/graphics/engine.scm
@@ -207,14 +207,20 @@
       (gl-get-integer-v (get-p-name max-texture-size)
                         (bytevector->pointer bv))
       (s32vector-ref bv 0)))
+  (define (max-texture-units)
+    (let ((bv (make-s32vector 1)))
+      (gl-get-integer-v (version-1-3 max-texture-units)
+                        (bytevector->pointer bv))
+      (s32vector-ref bv 0)))
   (define (extract-version attr)
     (car (string-split (pointer->string (gl-get-string attr)) #\space)))
   (define (glsl-version)
     (extract-version (version-2-0 shading-language-version)))
+  (pk 'max-texture-units (max-texture-units))
   (let ((engine (%make-graphics-engine gl-context
                                        (extract-version (string-name version))
                                        (glsl-version)
-                                       (max-texture-size)
+                                       (pk 'max-texture-size (max-texture-size))
                                        (make-identity-matrix4)
                                        (make-guardian)
                                        (make-array-list)
diff --git a/chickadee/graphics/gl.scm b/chickadee/graphics/gl.scm
index 508f244..27872dd 100644
--- a/chickadee/graphics/gl.scm
+++ b/chickadee/graphics/gl.scm
@@ -121,9 +121,7 @@ instanced rendering.")
 ;;; VBOs
 ;;;
 
-(re-export (%glGenBuffers . gl-gen-buffers)
-           (%glDeleteBuffers . gl-delete-buffers)
-           (%glBufferData . gl-buffer-data)
+(re-export (%glBufferData . gl-buffer-data)
            (%glBufferSubData . gl-buffer-sub-data)
            (%glMapBuffer . gl-map-buffer)
            (%glUnmapBuffer . gl-unmap-buffer))
@@ -142,6 +140,15 @@ instanced rendering.")
                                            -> void)
   "Delete vertex array objects.")
 
+(define (gl-generate-vertex-array)
+  (let ((bv (u32vector 0)))
+    (glGenVertexArrays 1 bv)
+    (u32vector-ref bv 0)))
+
+(define (gl-delete-vertex-array n)
+  (let ((bv (u32vector n)))
+    (glDeleteVertexArrays 1 bv)))
+
 (define-gl-procedure (glBindVertexArray (array GLuint)
                                         -> void)
   "Bind vertex array object ARRAY.")
@@ -166,8 +173,8 @@ instanced rendering.")
                                      -> void)
   "Render primitives from array data.")
 
-(export (glGenVertexArrays . gl-gen-vertex-arrays)
-        (glDeleteVertexArrays . gl-delete-vertex-arrays)
+(export gl-generate-vertex-array
+        gl-delete-vertex-array
         (glBindVertexArray . gl-bind-vertex-array)
         (glEnableVertexAttribArray . gl-enable-vertex-attrib-array)
         (glVertexAttribPointer . gl-vertex-attrib-pointer)
@@ -195,6 +202,15 @@ instanced rendering.")
                                            -> void)
   "Delete framebuffer objects.")
 
+(define (gl-generate-framebuffer)
+  (let ((bv (u32vector 0)))
+    (glGenFramebuffers 1 bv)
+    (u32vector-ref bv 0)))
+
+(define (gl-delete-framebuffer n)
+  (let ((bv (u32vector n)))
+    (glDeleteFramebuffers 1 bv)))
+
 (define-gl-procedure (glBindFramebuffer (target GLenum)
                                         (framebuffer GLuint)
                                         -> void)
@@ -224,6 +240,15 @@ object.")
                                             -> void)
   "Delete renderbuffer objects.")
 
+(define (gl-generate-renderbuffer)
+  (let ((bv (u32vector 0)))
+    (glGenRenderbuffers 1 bv)
+    (u32vector-ref bv 0)))
+
+(define (gl-delete-renderbuffer n)
+  (let ((bv (u32vector n)))
+    (glDeleteRenderbuffers 1 bv)))
+
 (define-gl-procedure (glBindRenderbuffer (target GLenum)
                                          (renderbuffer GLuint)
                                          -> void)
@@ -243,13 +268,13 @@ object.")
                                                 -> void)
   "Attach a renderbuffer object to a framebuffer object.")
 
-(export (glGenFramebuffers . gl-gen-framebuffers)
-        (glDeleteFramebuffers . gl-delete-framebuffers)
+(export gl-generate-framebuffer
+        gl-delete-framebuffer
         (glBindFramebuffer . gl-bind-framebuffer)
         (glFramebufferTexture2D . gl-framebuffer-texture-2d)
         (glCheckFramebufferStatus . gl-check-framebuffer-status)
-        (glGenRenderbuffers . gl-gen-renderbuffers)
-        (glDeleteRenderbuffers . gl-delete-renderbuffers)
+        gl-generate-renderbuffer
+        gl-delete-renderbuffer
         (glBindRenderbuffer . gl-bind-renderbuffer)
         (glRenderbufferStorage . gl-renderbuffer-storage)
         (glFramebufferRenderbuffer . gl-framebuffer-renderbuffer))
@@ -350,6 +375,7 @@ object.")
 
 (re-export (%glPolygonMode . gl-polygon-mode)
            (%glCullFace . gl-cull-face)
+           (%glFrontFace . gl-front-face)
            (%glColorMask . gl-color-mask))
 
 
diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm
new file mode 100644
index 0000000..c63cc4d
--- /dev/null
+++ b/chickadee/graphics/gpu.scm
@@ -0,0 +1,879 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; Commentary:
+;;
+;; Abstraction over OpenGL state.
+;;
+;;; Code:
+
+(define-module (chickadee graphics gpu)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics gl)
+  #:use-module (chickadee math rect)
+  #:use-module (gl)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (system foreign)
+  #:export (blend-mode?
+            blend-mode-equation
+            blend-mode-source-function
+            blend-mode-destination-function
+            blend:alpha
+            blend:multiply
+            blend:subtract
+            blend:add
+            blend:lighten
+            blend:darken
+            blend:screen
+            blend:replace
+
+            front-face?
+            front-face-winding
+            front-face:cw
+            front-face:ccw
+
+            cull-face-mode?
+            cull-face-mode-front?
+            cull-face-mode-back?
+            cull-face:none
+            cull-face:back
+            cull-face:front
+            cull-face:front+back
+
+            polygon-mode?
+            polygon-mode-front
+            polygon-mode-back
+            polygon:fill
+            polygon:line
+            polygon:point
+
+            make-color-mask
+            color-mask?
+            color-mask-red?
+            color-mask-green?
+            color-mask-blue?
+            color-mask-alpha?
+            color-mask:all
+            color-mask:none
+            color-mask:red
+            color-mask:green
+            color-mask:blue
+            color-mask:alpha
+
+            make-depth-test
+            depth-test?
+            depth-test-write?
+            depth-test-function
+            depth-test-near
+            depth-test-far
+
+            make-stencil-test
+            stencil-test?
+            stencil-test-mask-front
+            stencil-test-mask-back
+            stencil-test-function-front
+            stencil-test-function-back
+            stencil-test-function-mask-front
+            stencil-test-function-mask-back
+            stencil-test-reference-front
+            stencil-test-reference-back
+            stencil-test-on-fail-front
+            stencil-test-on-fail-back
+            stencil-test-on-depth-fail-front
+            stencil-test-on-depth-fail-back
+            stencil-test-on-pass-front
+            stencil-test-on-pass-back
+
+            make-window-rect
+            window-rect?
+            window-rect-x
+            window-rect-y
+            window-rect-width
+            window-rect-height
+
+            fresh-gpu-framebuffer
+            free-gpu-framebuffer
+            gpu-framebuffer?
+            gpu-framebuffer-id
+            gpu-framebuffer:null
+
+            fresh-gpu-renderbuffer
+            free-gpu-renderbuffer
+            gpu-renderbuffer?
+            gpu-renderbuffer-id
+            gpu-renderbuffer:null
+
+            fresh-gpu-buffer
+            free-gpu-buffer
+            gpu-buffer?
+            gpu-buffer-id
+            gpu-buffer-target
+            gpu-buffer:null
+
+            fresh-gpu-vertex-array
+            free-gpu-vertex-array
+            gpu-vertex-array?
+            gpu-vertex-array-id
+            gpu-vertex-array:null
+
+            fresh-gpu-texture
+            free-gpu-texture
+            gpu-texture?
+            gpu-texture-id
+            gpu-texture-target
+            gpu-texture:null
+
+            fresh-gpu-shader
+            free-gpu-shader
+            gpu-shader?
+            gpu-shader-id
+            gpu-shader:null
+
+            fresh-gpu-program
+            free-gpu-program
+            gpu-program?
+            gpu-program-id
+            gpu-program:null
+
+            make-gpu
+            gpu?
+            gpu-gl-context
+            gpu-gl-version
+            gpu-glsl-version
+            gpu-max-texture-size
+            gpu-max-texture-units
+            gpu-front-face
+            gpu-blend-mode
+            gpu-cull-face-mode
+            gpu-polygon-mode
+            gpu-color-mask
+            gpu-depth-test
+            gpu-stencil-test
+            gpu-scissor-test
+            gpu-multisample?
+            gpu-viewport
+            gpu-clear-color
+            gpu-framebuffer
+            gpu-renderbuffer
+            gpu-buffer
+            gpu-vertex-array
+            gpu-program
+            gpu-texture
+            set-gpu-front-face!
+            set-gpu-blend-mode!
+            set-gpu-cull-face-mode!
+            set-gpu-polygon-mode!
+            set-gpu-color-mask!
+            set-gpu-depth-test!
+            set-gpu-stencil-test!
+            set-gpu-scissor-test!
+            set-gpu-multisample!
+            set-gpu-viewport!
+            set-gpu-clear-color!
+            set-gpu-framebuffer!
+            set-gpu-renderbuffer!
+            set-gpu-buffer!
+            set-gpu-vertex-array!
+            set-gpu-program!
+            set-gpu-texture!
+            gpu-gc
+            gpu-reset!
+
+            current-gpu))
+
+
+;;;
+;;; GPU settings
+;;;
+
+(define-syntax symbol->enum
+  (syntax-rules ()
+    ((_ (x enum)) (error "symbol->enum: no match for" x))
+    ((_ (x enum) (sym name override-enum) . rest)
+     (if (eq? x 'sym) (override-enum name) (symbol->enum (x enum) . rest)))
+    ((_ (x enum) (sym name) . rest)
+     (if (eq? x 'sym) (enum name) (symbol->enum (x enum) . rest)))
+    ((_ (x enum) (sym) . rest)
+     (symbol->enum (x enum) (sym sym) . rest))))
+
+(define-syntax enum->symbol
+  (syntax-rules ()
+    ((_ (n enum)) (error "enum->symbol: no match for" n))
+    ((_ (n enum) (sym name override-enum) . rest)
+     (if (eqv? n (override-enum name)) 'sym (enum->symbol (n enum) . rest)))
+    ((_ (n enum) (sym name) . rest)
+     (if (eqv? n (enum name)) 'sym (enum->symbol (n enum) . rest)))
+    ((_ (n enum) (name) . rest)
+     (enum->symbol (n enum) (name name) . rest))))
+
+(define-syntax-rule (define-enum-converters enum ->enum ->symbol clause ...)
+  (begin
+    (define (->enum sym)
+      (symbol->enum (sym enum) clause ...))
+    (define (->symbol n)
+      (enum->symbol (n enum) clause ...))))
+
+(define-syntax-rule (define-config-type name
+                      constructor
+                      pred
+                      ((raw-field raccessor) ...)
+                      ((enum-field %eaccessor eaccessor ->gl ->scheme) ...))
+  (begin
+    (define-record-type name
+      (%make raw-field ... enum-field ...)
+      pred
+      (raw-field raccessor) ...
+      (enum-field %eaccessor) ...)
+    (define (constructor raw-field ... enum-field ...)
+      (%make raw-field ... (->gl enum-field) ...))
+    (define (eaccessor obj)
+      (->scheme (%eaccessor obj)))
+    ...))
+
+(define-enum-converters blend-equation-mode-ext
+  symbol->blend-equation
+  blend-equation->symbol
+  (add func-add-ext)
+  (subtract func-subtract-ext)
+  (reverse-subtract func-reverse-subtract-ext)
+  (min min-ext)
+  (max max-ext)
+  (alpha-min alpha-min-sgix)
+  (alpha-max alpha-max-sgix))
+
+(define-enum-converters blending-factor-src
+  symbol->blend-factor-source
+  blend-factor-source->symbol
+  (zero)
+  (one)
+  (destination-color dst-color)
+  (one-minus-destination-color one-minus-dst-color)
+  (source-alpha-saturate src-alpha-saturate)
+  (source-alpha src-alpha)
+  (one-minus-source-alpha one-minus-src-alpha)
+  (destination-alpha dst-alpha)
+  (one-minus-destination-alpha one-minus-dst-alpha)
+  (constant-color constant-color-ext)
+  (one-minus-constant-color one-minus-constant-color-ext)
+  (contstant-alpha constant-alpha-ext)
+  (one-minus-constant-alpha one-minus-constant-alpha-ext))
+
+(define-enum-converters blending-factor-dest
+  symbol->blend-factor-destination
+  blend-factor-destination->symbol
+  (zero)
+  (one)
+  (source-color src-color)
+  (one-minus-source-color one-minus-src-color)
+  (source-alpha src-alpha)
+  (one-minus-source-alpha one-minus-src-alpha)
+  (destination-alpha dst-alpha)
+  (one-minus-destination-alpha one-minus-dst-alpha)
+  (constant-color constant-color-ext)
+  (one-minus-constant-color one-minus-constant-color-ext)
+  (contstant-alpha constant-alpha-ext)
+  (one-minus-constant-alpha one-minus-constant-alpha-ext))
+
+(define-config-type <blend-mode>
+  make-blend-mode
+  blend-mode?
+  ()
+  ((equation %blend-mode-equation
+             blend-mode-equation
+             symbol->blend-equation
+             blend-equation->symbol)
+   (source %blend-mode-source-function
+           blend-mode-source-function
+           symbol->blend-factor-source
+           blend-factor-source->symbol)
+   (destination %blend-mode-destination-function
+                blend-mode-destination-function
+                symbol->blend-factor-destination
+                blend-factor-destination->symbol)))
+
+(define (bind-blend-mode blend-mode)
+  (match blend-mode
+    (#f (gl-disable (enable-cap blend)))
+    (($ <blend-mode> equation src dest)
+     (gl-enable (enable-cap blend))
+     (gl-blend-equation equation)
+     (gl-blend-func src dest))))
+
+(define blend:alpha (make-blend-mode 'add 'source-alpha 'one-minus-source-alpha))
+(define blend:multiply (make-blend-mode 'add 'destination-color 'zero))
+(define blend:subtract (make-blend-mode 'reverse-subtract 'one 'zero))
+(define blend:add (make-blend-mode 'add 'one 'one))
+(define blend:lighten (make-blend-mode 'max 'one 'zero))
+(define blend:darken (make-blend-mode 'min 'one 'zero))
+(define blend:screen (make-blend-mode 'add 'one 'one-minus-source-color))
+(define blend:replace (make-blend-mode 'add 'one 'zero))
+
+(define-enum-converters front-face-direction
+  symbol->front-face-direction
+  front-face-direction->symbol
+  (cw)
+  (ccw))
+
+(define-config-type <front-face>
+  make-front-face
+  front-face
+  ()
+  ((winding %front-face-winding
+            front-face-winding
+            symbol->front-face-direction
+            front-face-direction->symbol)))
+
+(define (bind-front-face front-face)
+  (gl-front-face (front-face-winding front-face)))
+
+(define front-face:cw (make-front-face 'cw))
+(define front-face:ccw (make-front-face 'ccw))
+
+(define-config-type <cull-face-mode>
+  make-cull-face-mode
+  cull-face-mode?
+  ((front? cull-face-mode-front?)
+   (back? cull-face-mode-back?))
+  ())
+
+(define (bind-cull-face-mode mode)
+  (match mode
+    (($ <cull-face-mode> #t #t)
+     (gl-enable (enable-cap cull-face))
+     (gl-cull-face (cull-face-mode front-and-back)))
+    (($ <cull-face-mode> #t #f)
+     (gl-enable (enable-cap cull-face))
+     (gl-cull-face (cull-face-mode front)))
+    (($ <cull-face-mode> #f #t)
+     (gl-enable (enable-cap cull-face))
+     (gl-cull-face (cull-face-mode back)))
+    (_
+     (gl-disable (enable-cap cull-face)))))
+
+(define cull-face:none (make-cull-face-mode #f #f))
+(define cull-face:back (make-cull-face-mode #f #t))
+(define cull-face:front (make-cull-face-mode #t #f))
+(define cull-face:front+back (make-cull-face-mode #t #t))
+
+(define-enum-converters polygon-mode
+  symbol->polygon-mode
+  polygon-mode->symbol
+  (fill)
+  (line)
+  (point))
+
+(define-config-type <polygon-mode>
+  make-polygon-mode
+  polygon-mode?
+  ()
+  ((front %polygon-mode-front
+          polygon-mode-front
+          symbol->polygon-mode
+          polygon-mode->symbol)
+   (back %polygon-mode-back
+         polygon-mode-back
+         symbol->polygon-mode
+         polygon-mode->symbol)))
+
+(define (bind-polygon-mode mode)
+  (match mode
+    (($ <polygon-mode> front back)
+     (if (= front back)
+         (gl-polygon-mode (cull-face-mode front-and-back) front)
+         (begin
+           (gl-polygon-mode (cull-face-mode front) front)
+           (gl-polygon-mode (cull-face-mode back) back))))))
+
+(define polygon:fill (make-polygon-mode 'fill 'fill))
+(define polygon:line (make-polygon-mode 'line 'line))
+(define polygon:point (make-polygon-mode 'point 'point))
+
+(define-config-type <color-mask>
+  make-color-mask
+  color-mask?
+  ((red? color-mask-red?)
+   (green? color-mask-green?)
+   (blue? color-mask-blue?)
+   (alpha? color-mask-alpha?))
+  ())
+
+(define (bind-color-mask mask)
+  (gl-color-mask (color-mask-red? mask)
+                 (color-mask-green? mask)
+                 (color-mask-blue? mask)
+                 (color-mask-alpha? mask)))
+
+(define color-mask:all (make-color-mask #t #t #t #t))
+(define color-mask:none (make-color-mask #f #f #f #f))
+(define color-mask:red (make-color-mask #t #f #f #f))
+(define color-mask:green (make-color-mask #f #t #f #f))
+(define color-mask:blue (make-color-mask #f #f #t #f))
+(define color-mask:alpha (make-color-mask #f #f #f #t))
+
+(define-enum-converters depth-function
+  symbol->depth-function
+  depth-function->symbol
+  (always)
+  (never)
+  (= equal)
+  (!= notequal)
+  (< less)
+  (<= lequal)
+  (> greater)
+  (>= gequal))
+
+(define-config-type <depth-test>
+  %make-depth-test
+  depth-test?
+  ((near depth-test-near)
+   (far depth-test-far)
+   (write? depth-test-write?))
+  ((function %depth-test-function
+             depth-test-function
+             symbol->depth-function
+             depth-function->symbol)))
+
+(define* (make-depth-test #:key (near 0.0) (far 1.0) (write? #t) (function '<))
+  (%make-depth-test near far write? function))
+
+(define (bind-depth-test depth-test)
+  (match depth-test
+    (#f (gl-disable (enable-cap depth-test)))
+    (($ <depth-test> write? near far func)
+     (gl-enable (enable-cap depth-test))
+     (gl-depth-func func)
+     (gl-depth-mask write?)
+     (gl-depth-range near far))))
+
+(define-enum-converters stencil-op
+  symbol->stencil-op
+  stencil-op->symbol
+  (zero)
+  (keep)
+  (replace)
+  (invert)
+  (increment incr)
+  (decrement decr)
+  (increment-wrap incr-wrap version-1-4)
+  (decrement-wrap decr-wrap version-1-4))
+
+(define-enum-converters stencil-function
+  symbol->stencil-function
+  stencil-function->symbol
+  (always)
+  (never)
+  (= equal)
+  (!= notequal)
+  (< less)
+  (<= lequal)
+  (> greater)
+  (>= gequal))
+
+(define-config-type <stencil-test>
+  %make-stencil-test
+  stencil-test?
+  ((mask-front stencil-test-mask-front)
+   (mask-back stencil-test-mask-back)
+   (function-mask-front stencil-test-function-mask-front)
+   (function-mask-back stencil-test-function-mask-back)
+   (reference-front stencil-test-reference-front)
+   (reference-back stencil-test-reference-back))
+  ((function-front %stencil-test-function-front
+                   stencil-test-function-front
+                   symbol->stencil-function
+                   stencil-function->symbol)
+   (function-back %stencil-test-function-back
+                  stencil-test-function-back
+                  symbol->stencil-function
+                  stencil-function->symbol)
+   (on-fail-front %stencil-test-on-fail-front
+                  stencil-test-on-fail-front
+                  symbol->stencil-op
+                  stencil-op->symbol)
+   (on-fail-back %stencil-test-on-fail-back
+                 stencil-test-on-fail-back
+                 symbol->stencil-op
+                 stencil-op->symbol)
+   (on-depth-fail-front %stencil-test-on-depth-fail-front
+                        stencil-test-on-depth-fail-front
+                        symbol->stencil-op
+                        stencil-op->symbol)
+   (on-depth-fail-back %stencil-test-on-depth-fail-back
+                       stencil-test-on-depth-fail-back
+                       symbol->stencil-op
+                       stencil-op->symbol)
+   (on-pass-front %stencil-test-on-pass-front
+                  stencil-test-on-pass-front
+                  symbol->stencil-op
+                  stencil-op->symbol)
+   (on-pass-back %stencil-test-on-pass-back
+                 stencil-test-on-pass-back
+                 symbol->stencil-op
+                 stencil-op->symbol)))
+
+(define* (make-stencil-test #:key (mask #xff) (function 'always)
+                            (function-mask #xff) (reference 0)
+                            (on-fail 'keep) (on-depth-fail 'keep) (on-pass 'keep)
+                            (mask-front mask) (mask-back mask)
+                            (function-front function) (function-back function)
+                            (function-mask-front function-mask)
+                            (function-mask-back function-mask)
+                            (reference-front reference)
+                            (reference-back reference)
+                            (on-fail-front on-fail) (on-fail-back on-fail)
+                            (on-depth-fail-front on-depth-fail)
+                            (on-depth-fail-back on-depth-fail)
+                            (on-pass-front on-pass) (on-pass-back on-pass))
+  (%make-stencil-test mask-front mask-back
+                      function-mask-front function-mask-back
+                      reference-front reference-back
+                      function-front function-back
+                      on-fail-front on-fail-back
+                      on-depth-fail-front on-depth-fail-back
+                      on-pass-front on-pass-back))
+
+(define (bind-stencil-test stencil-test)
+  (match stencil-test
+    (#f (gl-disable (enable-cap stencil-test)))
+    (($ <stencil-test> mask-front mask-back
+                       function-mask-front function-mask-back
+                       reference-front reference-back
+                       function-front function-back
+                       on-fail-front on-fail-back
+                       on-depth-fail-front on-depth-fail-back
+                       on-pass-front on-pass-back)
+     (gl-enable (enable-cap stencil-test))
+     ;; Mask
+     (gl-stencil-mask-separate (cull-face-mode front) mask-front)
+     (gl-stencil-mask-separate (cull-face-mode back) mask-back)
+     ;; Function
+     (gl-stencil-func-separate (cull-face-mode front)
+                               function-front reference-front mask-front)
+     (gl-stencil-func-separate (cull-face-mode back)
+                               function-back reference-back mask-back)
+     ;; Operation
+     (gl-stencil-op-separate (cull-face-mode front)
+                             on-fail-front on-depth-fail-front on-pass-front)
+     (gl-stencil-op-separate (cull-face-mode back)
+                             on-fail-back on-depth-fail-back on-pass-back))))
+
+(define (bind-multisample multisample?)
+  (if multisample?
+      (gl-enable (version-1-3 multisample))
+      (gl-disable (version-1-3 multisample))))
+
+(define (bind-clear-color color)
+  (gl-clear-color (color-r color)
+                  (color-g color)
+                  (color-b color)
+                  (color-a color)))
+
+(define-record-type <window-rect>
+  (make-window-rect x y width height)
+  window-rect?
+  (x window-rect-x)
+  (y window-rect-y)
+  (width window-rect-width)
+  (height window-rect-height))
+
+(define (bind-scissor-test rect)
+  (match rect
+    (#f (gl-disable (enable-cap scissor-test)))
+    (($ <window-rect> x y width height)
+     (gl-enable (enable-cap scissor-test))
+     (gl-scissor x y width height))))
+
+(define (bind-viewport rect)
+  (match rect
+    (($ <window-rect> x y width height)
+     (gl-viewport x y width height))))
+
+
+;;;
+;;; GPU objects
+;;;
+
+(define-syntax-rule (define-gpu-type name
+                      (constructor (cparams ...) cargs ...)
+                      (free free-exp)
+                      (bind bind-exp)
+                      (null null-args ...)
+                      pred
+                      (field accessor) ...)
+  (begin
+    (define-record-type name
+      (%make field ... deleted?)
+      pred
+      (field accessor) ...
+      (deleted? %deleted? %set-deleted!))
+    (define (constructor cparams ...)
+      (%make cargs ... #f))
+    (define null (%make null-args ... #f))
+    (define (free obj)
+      (match obj
+        (($ name field ... deleted?)
+         (unless deleted?
+           free-exp
+           (%set-deleted! obj #t)))))
+    (define (bind obj)
+      (match obj
+        (($ name field ... deleted?)
+         (if deleted?
+             (error "GPU object has been deleted" obj)
+             bind-exp))))))
+
+(define-gpu-type <gpu-framebuffer>
+  (make-gpu-framebuffer () (gl-generate-framebuffer))
+  (free-gpu-framebuffer (gl-delete-framebuffer id))
+  (bind-gpu-framebuffer (gl-bind-framebuffer (version-3-0 framebuffer) id))
+  (gpu-framebuffer:null 0)
+  gpu-framebuffer?
+  (id gpu-framebuffer-id))
+
+(define-gpu-type <gpu-renderbuffer>
+  (make-gpu-renderbuffer () (gl-generate-renderbuffer))
+  (free-gpu-renderbuffer (gl-delete-renderbuffer id))
+  (bind-gpu-renderbuffer (gl-bind-renderbuffer (version-3-0 renderbuffer) id))
+  (gpu-renderbuffer:null 0)
+  gpu-renderbuffer?
+  (id gpu-renderbuffer-id))
+
+(define-gpu-type <gpu-buffer>
+  (make-gpu-buffer (target)
+                   (gl-generate-buffer)
+                   (match target
+                     ('index (version-1-5 element-array-buffer))
+                     ('vertex (version-1-5 array-buffer))))
+  (free-gpu-buffer (gl-delete-buffer id))
+  (bind-gpu-buffer (gl-bind-buffer target id))
+  (gpu-buffer:null 0 (version-1-5 array-buffer))
+  gpu-buffer?
+  (id gpu-buffer-id)
+  (target gpu-buffer-target))
+
+(define-gpu-type <gpu-vertex-array>
+  (make-gpu-vertex-array () (gl-generate-vertex-array))
+  (free-gpu-vertex-array (gl-delete-vertex-array id))
+  (bind-gpu-vertex-array (gl-bind-vertex-array id))
+  (gpu-vertex-array:null 0)
+  gpu-vertex-array?
+  (id gpu-vertex-array-id))
+
+(define-gpu-type <gpu-texture>
+  (make-gpu-texture (target)
+                   (gl-generate-texture)
+                   (match target
+                     ('2d (texture-target texture-2d))
+                     ('cube-map (version-1-3 texture-cube-map))))
+  (free-gpu-texture (gl-delete-texture id))
+  (bind-gpu-texture (gl-bind-texture target id))
+  (gpu-texture:null 0 (texture-target texture-2d))
+  gpu-texture?
+  (id gpu-texture-id)
+  (target gpu-texture-target))
+
+(define-gpu-type <gpu-shader>
+  (make-gpu-shader (type)
+                   (gl-create-shader
+                    (match type
+                      ('vertex (version-2-0 vertex-shader))
+                      ('fragment (version-2-0 fragment-shader)))))
+  (free-gpu-shader (gl-delete-shader id))
+  ;; Shaders are not bound but rather attached to a program, which is
+  ;; bound, so this is a stub.
+  (bind-gpu-shader #t)
+  (gpu-shader:null 0)
+  gpu-shader?
+  (id gpu-shader-id))
+
+(define-gpu-type <gpu-program>
+  (make-gpu-program () (gl-create-program))
+  (free-gpu-program (gl-delete-program id))
+  (bind-gpu-program (gl-use-program id))
+  (gpu-program:null 0)
+  gpu-program?
+  (id gpu-program-id))
+
+
+;;;
+;;; State management
+;;;
+
+;; An abstraction over the annoying OpenGL context state.  Minimizes
+;; GPU calls by keeping a local cache.
+(define-record-type <gpu>
+  (%make-gpu gl-context gl-version glsl-version max-texture-size
+             max-texture-units guardian textures)
+  gpu?
+  ;; Metadata:
+  (gl-context gpu-gl-context)
+  (gl-version gpu-gl-version)
+  (glsl-version gpu-glsl-version)
+  (max-texture-size gpu-max-texture-size)
+  (max-texture-units gpu-max-texture-units)
+  ;; GC integration for GPU data.
+  (guardian gpu-guardian)
+  ;; OpenGL state:
+  (front-face gpu-front-face %set-gpu-front-face!)
+  (blend-mode gpu-blend-mode %set-gpu-blend-mode!)
+  (cull-face-mode gpu-cull-face-mode %set-gpu-cull-face-mode!)
+  (polygon-mode gpu-polygon-mode %set-gpu-polygon-mode!)
+  (color-mask gpu-color-mask %set-gpu-color-mask!)
+  (depth-test gpu-depth-test %set-gpu-depth-test!)
+  (stencil-test gpu-stencil-test %set-gpu-stencil-test!)
+  (scissor-test gpu-scissor-test %set-gpu-scissor-test!)
+  (viewport gpu-viewport %set-gpu-viewport!)
+  (clear-color gpu-clear-color %set-gpu-clear-color!)
+  (multisample? gpu-multisample? %set-gpu-multisample!)
+  (framebuffer gpu-framebuffer %set-gpu-framebuffer!)
+  (renderbuffer gpu-renderbuffer %set-gpu-renderbuffer!)
+  (buffer gpu-buffer %set-gpu-buffer!)
+  (vertex-array gpu-vertex-array %set-gpu-vertex-array!)
+  (program gpu-program %set-gpu-program!)
+  ;; Unlike the other state, many textures can be bound to different
+  ;; units, and the maximum number of texture units varies from
+  ;; machine to machine.  So, we use a vector to hold the state of
+  ;; this unknown (until runtime) amount of textures.
+  (textures gpu-textures))
+
+(define (make-gpu gl-context)
+  (define (get-param name)
+    (let ((bv (make-s32vector 1)))
+      (gl-get-integer-v name (bytevector->pointer bv))
+      (s32vector-ref bv 0)))
+  (define (extract-version attr)
+    (match (string-split (pointer->string (gl-get-string attr)) #\space)
+      ((version . _) version)
+      (_ "unknown")))
+  (let* ((gl-version (extract-version (string-name version)))
+         (glsl-version (extract-version (version-2-0 shading-language-version)))
+         (max-texture-size (get-param (get-p-name max-texture-size)))
+         (max-texture-units (get-param (version-1-3 max-texture-units)))
+         (guardian (make-guardian))
+         (textures (make-vector max-texture-units #f)))
+    (%make-gpu gl-context gl-version glsl-version max-texture-size
+               max-texture-units guardian textures)))
+
+(define current-gpu (make-parameter #f))
+
+(define-syntax-rule (define-gpu-setter name %set! ref bind pred)
+  (define (name gpu obj)
+    (unless (pred obj (ref gpu))
+      (bind obj)
+      (%set! gpu obj))))
+
+(define-gpu-setter set-gpu-front-face!
+  %set-gpu-front-face! gpu-front-face bind-front-face eq?)
+(define-gpu-setter set-gpu-blend-mode!
+  %set-gpu-blend-mode! gpu-blend-mode bind-blend-mode eq?)
+(define-gpu-setter set-gpu-cull-face-mode!
+  %set-gpu-cull-face-mode! gpu-cull-face-mode bind-cull-face-mode eq?)
+(define-gpu-setter set-gpu-polygon-mode!
+  %set-gpu-polygon-mode! gpu-polygon-mode bind-polygon-mode eq?)
+(define-gpu-setter set-gpu-color-mask!
+  %set-gpu-color-mask! gpu-color-mask bind-color-mask equal?)
+(define-gpu-setter set-gpu-depth-test!
+  %set-gpu-depth-test! gpu-depth-test bind-depth-test equal?)
+(define-gpu-setter set-gpu-stencil-test!
+  %set-gpu-stencil-test! gpu-stencil-test bind-stencil-test equal?)
+(define-gpu-setter set-gpu-scissor-test!
+  %set-gpu-scissor-test! gpu-scissor-test bind-scissor-test equal?)
+(define-gpu-setter set-gpu-viewport!
+  %set-gpu-viewport! gpu-viewport bind-viewport equal?)
+(define-gpu-setter set-gpu-clear-color!
+  %set-gpu-clear-color! gpu-clear-color bind-clear-color equal?)
+(define-gpu-setter set-gpu-multisample!
+  %set-gpu-multisample! gpu-multisample? bind-multisample eq?)
+(define-gpu-setter set-gpu-framebuffer!
+  %set-gpu-framebuffer! gpu-framebuffer bind-gpu-framebuffer eq?)
+(define-gpu-setter set-gpu-renderbuffer!
+  %set-gpu-renderbuffer! gpu-renderbuffer bind-gpu-renderbuffer eq?)
+(define-gpu-setter set-gpu-buffer!
+  %set-gpu-buffer! gpu-buffer bind-gpu-buffer eq?)
+(define-gpu-setter set-gpu-vertex-array!
+  %set-gpu-vertex-array! gpu-vertex-array bind-gpu-vertex-array eq?)
+(define-gpu-setter set-gpu-program!
+  %set-gpu-program! gpu-program bind-gpu-program eq?)
+
+(define (gpu-texture gpu unit)
+  (vector-ref (gpu-textures gpu) unit))
+
+(define (set-gpu-texture! gpu unit texture)
+  (unless (eq? texture (gpu-texture gpu unit))
+    (set-gl-active-texture (+ (version-1-3 texture0) unit))
+    (bind-gpu-texture texture)
+    (vector-set! (gpu-textures gpu) unit texture)))
+
+(define (gpu-gc gpu)
+  (let ((guardian (gpu-guardian gpu)))
+    (let loop ()
+      (match (guardian)
+        (#f *unspecified*)
+        ((? gpu-framebuffer? fb)
+         (free-gpu-framebuffer fb)
+         (loop))
+        ((? gpu-renderbuffer? rb)
+         (free-gpu-renderbuffer rb)
+         (loop))
+        ((? gpu-buffer? buf)
+         (free-gpu-buffer buf)
+         (loop))
+        ((? gpu-vertex-array? va)
+         (free-gpu-vertex-array va)
+         (loop))
+        ((? gpu-shader? s)
+         (free-gpu-shader s)
+         (loop))
+        ((? gpu-program? p)
+         (free-gpu-program p)
+         (loop))))))
+
+(define (guard! gpu obj)
+  ((gpu-guardian gpu) obj))
+
+(define-syntax-rule (define-fresh name constructor params ...)
+  (define (name gpu params ...)
+    (guard! gpu (constructor params ...))))
+
+(define-fresh fresh-gpu-framebuffer make-gpu-framebuffer)
+(define-fresh fresh-gpu-renderbuffer make-gpu-renderbuffer)
+(define-fresh fresh-gpu-buffer make-gpu-buffer target)
+(define-fresh fresh-gpu-vertex-array make-gpu-vertex-array)
+(define-fresh fresh-gpu-shader make-gpu-shader type)
+(define-fresh fresh-gpu-program make-gpu-program)
+
+(define (gpu-reset! gpu)
+  (set-gpu-front-face! gpu front-face:ccw)
+  (set-gpu-blend-mode! gpu blend:replace)
+  (set-gpu-cull-face-mode! gpu cull-face:back)
+  (set-gpu-polygon-mode! gpu polygon:fill)
+  (set-gpu-color-mask! gpu color-mask:all)
+  (set-gpu-depth-test! gpu #f)
+  (set-gpu-stencil-test! gpu #f)
+  (set-gpu-scissor-test! gpu #f)
+  ;; TODO: Need current window dimensions.
+  ;; (set-gpu-viewport! gpu ...)
+  (set-gpu-multisample! gpu #f)
+  (set-gpu-framebuffer! gpu gpu-framebuffer:null)
+  (set-gpu-renderbuffer! gpu gpu-renderbuffer:null)
+  (set-gpu-buffer! gpu gpu-buffer:null)
+  (set-gpu-vertex-array! gpu gpu-vertex-array:null)
+  (set-gpu-program! gpu gpu-program:null)
+  (let ((textures (gpu-textures gpu)))
+    (let loop ((i 0))
+      (when (< i (vector-length textures))
+        (set-gpu-texture! gpu i gpu-texture:null)
+        (loop (+ i 1))))))
diff --git a/chickadee/math.scm b/chickadee/math.scm
index aa96ba8..cbdf4b9 100644
--- a/chickadee/math.scm
+++ b/chickadee/math.scm
@@ -26,9 +26,9 @@
             radians->degrees)
   #:replace (min max))
 
-(define pi 3.1415926535897932)
-(define pi/2 1.5707963267948966)
-(define tau 6.283185307179586) ;; AKA 2pi
+(define pi (* 4.0 (atan 1.0)))
+(define pi/2 (/ pi 2.0))
+(define tau (* pi 2.0))
 
 (define-inlinable (cotan z)
   "Return the cotangent of Z."
diff --git a/examples/sprite.scm b/examples/sprite.scm
index eb79161..24b7a24 100644
--- a/examples/sprite.scm
+++ b/examples/sprite.scm
@@ -3,9 +3,12 @@
              (chickadee graphics sprite)
              (chickadee graphics texture))
 
+(use-modules (gl enums))
+
 (define sprite #f)
 
 (define (load)
+  (pk (blending-factor-src 2))
   (set! sprite (load-image "images/chickadee.png")))
 
 (define (draw alpha)