render: Reimplement rendering engine using functional combinators.

Warning: This is a huge commit.

I completely gutted the old scene graph and replaced it with a somewhat
monadic rendering combinator module instead.  The interface remains
purely functional, but replaces the <model> data type with procedures in
the rendering monad instead.  This opens the door for
rendering *anything*, not just meshes.  Now I can implement particle
systems and other non-static things.

9 files changed, 553 insertions, 231 deletions

diff --git a/sly/game.scm b/sly/game.scm
index 7e4a79c..ef92e90 100644
--- a/sly/game.scm
+++ b/sly/game.scm
@@ -35,7 +35,6 @@
   #:use-module (sly math vector)
   #:use-module (sly window)
   #:use-module (sly render)
-  #:use-module (sly render scene)
   #:export (draw-hook
             after-game-loop-error-hook
             run-game-loop
@@ -67,13 +66,13 @@ for the given STACK and error KEY with additional arguments ARGS."
                         (tick-rate 60)
                         (max-ticks-per-frame 4))
   "Run the game loop.  SCENE is a signal which contains the current
-scene to render.  FRAME-RATE specifies the optimal number of frames to
-draw SCENE per second.  TICK-RATE specifies the optimal game logic
-updates per second.  Both FRAME-RATE and TICK-RATE are 60 by default.
-MAX-TICKS-PER-FRAME is the maximum number of times the game loop will
-update game state in a single frame.  When this upper bound is reached
-due to poor performance, the game will start to slow down instead of
-becoming completely unresponsive and possibly crashing."
+scene renderer procedure.  FRAME-RATE specifies the optimal number of
+frames to draw SCENE per second.  TICK-RATE specifies the optimal game
+logic updates per second.  Both FRAME-RATE and TICK-RATE are 60 by
+default.  MAX-TICKS-PER-FRAME is the maximum number of times the game
+loop will update game state in a single frame.  When this upper bound
+is reached due to poor performance, the game will start to slow down
+instead of becoming completely unresponsive and possibly crashing."
   (let ((tick-interval  (interval tick-rate))
         (frame-interval (interval frame-rate))
         (gfx            (make-graphics)))
@@ -84,8 +83,7 @@ becoming completely unresponsive and possibly crashing."
         (gl-viewport 0 0 (vx size) (vy size)))
       (gl-clear (clear-buffer-mask color-buffer depth-buffer))
       (run-hook draw-hook dt alpha)
-      (with-graphics gfx
-                     (draw-scene (signal-ref scene) gfx))
+      (with-graphics gfx ((signal-ref scene) gfx))
       (SDL:gl-swap-buffers))
 
     (define (update lag)
diff --git a/sly/render.scm b/sly/render.scm
index 6ff7bb9..215629f 100644
--- a/sly/render.scm
+++ b/sly/render.scm
@@ -22,6 +22,7 @@
 ;;; Code:
 
 (define-module (sly render)
+  #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 q)
@@ -31,13 +32,14 @@
   #:use-module (gl enums)
   #:use-module (gl low-level)
   #:use-module (sly wrappers gl)
-  #:use-module (sly math transform)
+  #:use-module ((sly math transform) #:prefix t:)
+  #:use-module (sly render color)
   #:use-module (sly render shader)
   #:use-module (sly render texture)
   #:use-module (sly render utils)
   #:use-module (sly render mesh)
   #:use-module (sly render framebuffer)
-  #:use-module (sly render camera)
+  #:use-module (sly render viewport)
   #:export (make-graphics
             graphics?
             graphics-blend-mode
@@ -57,23 +59,65 @@
             graphics-model-view-transform
             graphics-model-view-mul!
             graphics-model-view-identity!
-            with-model-view-excursion
+            graphics-model-view-excursion
             graphics-projection-transform
             graphics-projection-mul!
             graphics-projection-identity!
-            with-projection-excursion
+            graphics-projection-excursion
             with-graphics
-            with-graphics-excursion))
+            with-graphics-excursion
+
+            render-lift
+            render-lift1
+            render-nothing
+            list->renderer
+            render-begin
+            blend-mode-excursion
+            depth-test-excursion
+            texture-excursion
+            shader-excursion
+            mesh-excursion
+            framebuffer-excursion
+            viewport-excursion
+            projection-excursion
+            model-view-excursion
+            set-blend-mode
+            set-depth-test
+            set-texture
+            set-shader
+            set-mesh
+            set-framebuffer
+            set-viewport
+            projection-mul
+            projection-identity
+            model-view-mul
+            model-view-identity
+            with-blend-mode
+            with-depth-test
+            with-texture
+            with-shader
+            with-mesh
+            with-framebuffer
+            with-viewport
+            with-projection-mul
+            with-model-view-mul
+            move
+            scale
+            rotate-z
+            clear-screen
+            uniform-let
+            with-color
+            render-mesh))
 
 ;;;
 ;;; Transformation matrix stack.
 ;;;
 
 (define (make-null-transform)
-  (make-transform 0 0 0 0
-                  0 0 0 0
-                  0 0 0 0
-                  0 0 0 0))
+  (t:make-transform 0 0 0 0
+                    0 0 0 0
+                    0 0 0 0
+                    0 0 0 0))
 
 (define (make-transform-stack size)
   (let ((stack (make-q)))
@@ -81,8 +125,8 @@
     stack))
 
 (define (copy-transform! src dest)
-  (bytevector-copy! (transform-matrix src) 0
-                    (transform-matrix dest) 0
+  (bytevector-copy! (t:transform-matrix src) 0
+                    (t:transform-matrix dest) 0
                     64))
 
 (define (call-with-transform-excursion stack thunk)
@@ -99,18 +143,18 @@
   (let ((dest (q-front stack)))
     (call-with-transform-excursion stack
       (lambda ()
-        (transform*! dest (q-front stack) t)))))
+        (t:transform*! dest (q-front stack) t)))))
 
 (define (stack-transform-identity! stack)
-  (copy-transform! identity-transform (q-front stack)))
+  (copy-transform! t:identity-transform (q-front stack)))
 
 ;;;
 ;;; Graphics context.
 ;;;
 
 (define-record-type <graphics>
-  (%make-graphics blend-mode depth-test? texture shader
-                  mesh framebuffer viewport projection model-view)
+  (%make-graphics blend-mode depth-test? texture shader mesh framebuffer
+                  viewport projection model-view uniforms)
   graphics?
   (blend-mode graphics-blend-mode %set-graphics-blend-mode!)
   (depth-test? graphics-depth-test? %set-graphics-depth-test!)
@@ -120,13 +164,47 @@
   (framebuffer graphics-framebuffer %set-graphics-framebuffer!)
   (viewport graphics-viewport %set-graphics-viewport!)
   (projection graphics-projection)
-  (model-view graphics-model-view))
+  (model-view graphics-model-view)
+  (uniforms graphics-uniforms set-graphics-uniforms!))
+
+(define (graphics-uniform-ref gfx uniform)
+  (hashq-ref (graphics-uniforms gfx) uniform))
+
+(define (graphics-uniform-set! gfx uniform value)
+  (uniform-set! (graphics-shader gfx) uniform value)
+  (hashq-set! (graphics-uniforms gfx) uniform value))
+
+(define (graphics-uniform-excursion gfx uniforms proc)
+  (define (set-uniforms uniforms)
+    (for-each (match-lambda
+               ((name value)
+                (graphics-uniform-set! gfx name value)))
+              uniforms))
+
+  (let* ((old (map (match-lambda
+                    ((name _)
+                     (list name (graphics-uniform-ref gfx name))))
+                   uniforms)))
+    (set-uniforms uniforms)
+    (proc gfx)
+    (set-uniforms old)))
+
+(define (switch-shader gfx shader)
+  (%set-graphics-shader! gfx shader)
+  (hash-clear! (graphics-uniforms gfx))
+  (for-each (lambda (uniform)
+              (graphics-uniform-set! gfx
+                                     (uniform-name uniform)
+                                     (uniform-default uniform)))
+            (shader-program-uniforms shader)))
 
 (define (make-context-switcher getter setter switch)
   (lambda* (gfx x #:optional force)
     (when (or force (not (equal? (getter gfx) x)))
-      (setter gfx x)
-      (switch x))))
+      ;; It's important that we change OpenGL context first, because
+      ;; the setter procedure may do things that depend on it.
+      (switch x)
+      (setter gfx x))))
 
 (define set-graphics-blend-mode!
   (make-context-switcher graphics-blend-mode
@@ -145,7 +223,7 @@
 
 (define set-graphics-shader!
   (make-context-switcher graphics-shader
-                         %set-graphics-shader!
+                         switch-shader
                          apply-shader-program))
 
 (define set-graphics-mesh!
@@ -163,21 +241,30 @@
                          %set-graphics-viewport!
                          apply-viewport))
 
+(define (draw-graphics-mesh! graphics)
+  (let ((mesh (graphics-mesh graphics)))
+    (glDrawElements (begin-mode triangles)
+                    (mesh-length mesh)
+                    (data-type unsigned-int)
+                    %null-pointer)))
+
 (define* (make-graphics #:optional (transform-stack-size 32))
   (%make-graphics #f #f #f #f #f #f #f
                   (make-transform-stack transform-stack-size)
-                  (make-transform-stack transform-stack-size)))
+                  (make-transform-stack transform-stack-size)
+                  (make-hash-table)))
 
 (define (graphics-reset! gfx)
-  (set-graphics-blend-mode!  gfx #f #t)
-  (set-graphics-depth-test!  gfx #f #t)
-  (set-graphics-texture!     gfx null-texture #t)
-  (set-graphics-shader!      gfx null-shader-program #t)
-  (set-graphics-mesh!        gfx null-mesh #t)
-  (set-graphics-framebuffer! gfx null-framebuffer #t)
-  (set-graphics-viewport!    gfx null-viewport #t)
-  (stack-transform-identity! (graphics-projection gfx))
-  (stack-transform-identity! (graphics-model-view gfx)))
+  (let ((shader (load-default-shader)))
+    (set-graphics-blend-mode!  gfx default-blend-mode #t)
+    (set-graphics-depth-test!  gfx #f #t)
+    (set-graphics-texture!     gfx null-texture #t)
+    (set-graphics-shader!      gfx shader #t)
+    (set-graphics-mesh!        gfx null-mesh #t)
+    (set-graphics-framebuffer! gfx null-framebuffer #t)
+    (set-graphics-viewport!    gfx null-viewport #t)
+    (stack-transform-identity! (graphics-projection gfx))
+    (stack-transform-identity! (graphics-model-view gfx))))
 
 (define-syntax-rule (with-graphics gfx body ...)
   (begin
@@ -194,10 +281,9 @@
 (define (graphics-model-view-identity! gfx)
   (stack-transform-identity! (graphics-model-view gfx)))
 
-;; emacs: (put 'with-model-view-excursion 'scheme-indent-function 1)
-(define-syntax-rule (with-model-view-excursion gfx body ...)
+(define (graphics-model-view-excursion gfx proc)
   (call-with-transform-excursion (graphics-model-view gfx)
-    (lambda () body ...)))
+    (lambda () (proc gfx))))
 
 (define (graphics-projection-transform gfx)
   (q-front (graphics-projection gfx)))
@@ -208,20 +294,211 @@
 (define (graphics-projection-identity! gfx)
   (stack-transform-identity! (graphics-projection gfx)))
 
-;; emacs: (put 'with-projection-excursion 'scheme-indent-function 1)
-(define-syntax-rule (with-projection-excursion gfx body ...)
+(define (graphics-projection-excursion gfx proc)
   (call-with-transform-excursion (graphics-projection gfx)
-    (lambda () body ...)))
-
-(define-syntax-rule (with-graphics-excursion gfx body ...)
-  (match gfx
-    (($ <graphics> blend-mode depth-test? texture shader mesh
-        viewport framebuffer _ _)
-     body ...
-     (set-graphics-blend-mode!  gfx blend-mode)
-     (set-graphics-depth-test!  gfx depth-test?)
-     (set-graphics-texture!     gfx texture)
-     (set-graphics-shader!      gfx shader)
-     (set-graphics-mesh!        gfx mesh)
-     (set-graphics-framebuffer! gfx framebuffer)
-     (set-graphics-viewport!    gfx viewport))))
+    (lambda () (proc gfx))))
+
+(define (make-excursion getter setter)
+  (lambda (gfx proc)
+    (let ((old (getter gfx)))
+      (dynamic-wind
+        (const #t)
+        (lambda () (proc gfx))
+        (lambda ()
+          (setter gfx old))))))
+
+(define graphics-blend-mode-excursion
+  (make-excursion graphics-blend-mode set-graphics-blend-mode!))
+
+(define graphics-depth-test-excursion
+  (make-excursion graphics-depth-test? set-graphics-depth-test!))
+
+(define graphics-texture-excursion
+  (make-excursion graphics-texture set-graphics-texture!))
+
+(define graphics-shader-excursion
+  (make-excursion graphics-shader set-graphics-shader!))
+
+(define graphics-mesh-excursion
+  (make-excursion graphics-mesh set-graphics-mesh!))
+
+(define graphics-framebuffer-excursion
+  (make-excursion graphics-framebuffer set-graphics-framebuffer!))
+
+(define graphics-viewport-excursion
+  (make-excursion graphics-viewport set-graphics-viewport!))
+
+;;;
+;;; Render Combinators
+;;;
+
+(define (render-lift proc)
+  "Lift PROC, a procedure whose first argument is the graphics
+context, into the rendering monad."
+  (lambda args
+    (lambda (gfx)
+      (apply proc gfx args))))
+
+(define (render-lift1 proc)
+  "Lift PROC, a procedure that accepts two arguments whose first
+argument is a graphics context, into the rendering monad."
+  (lambda (arg)
+    (lambda (gfx)
+      (proc gfx arg))))
+
+(define (render-nothing gfx)
+  "Render nothing at all."
+  *unspecified*)
+
+(define (list->renderer renderers)
+  "Create a new renderer that applies RENDERERS in order."
+  (lambda (gfx)
+    (for-each (lambda (render) (render gfx)) renderers)))
+
+(define (render-begin . renderers)
+  "Create a new renderer that applies RENDERERS in order."
+  (list->renderer renderers))
+
+(define blend-mode-excursion
+  (render-lift1 graphics-blend-mode-excursion))
+
+(define depth-test-excursion
+  (render-lift1 graphics-depth-test-excursion))
+
+(define texture-excursion
+  (render-lift1 graphics-texture-excursion))
+
+(define shader-excursion
+  (render-lift1 graphics-shader-excursion))
+
+(define mesh-excursion
+  (render-lift1 graphics-mesh-excursion))
+
+(define framebuffer-excursion
+  (render-lift1 graphics-framebuffer-excursion))
+
+(define viewport-excursion
+  (render-lift1 graphics-viewport-excursion))
+
+(define projection-excursion
+  (render-lift1 graphics-projection-excursion))
+
+(define model-view-excursion
+  (render-lift1 graphics-model-view-excursion))
+
+(define set-blend-mode
+  (render-lift1 set-graphics-blend-mode!))
+
+(define set-depth-test
+  (render-lift1 set-graphics-depth-test!))
+
+(define set-texture
+  (render-lift1 set-graphics-texture!))
+
+(define set-shader
+  (render-lift1 set-graphics-shader!))
+
+(define set-mesh
+  (render-lift1 set-graphics-shader!))
+
+(define set-framebuffer
+  (render-lift1 set-graphics-framebuffer!))
+
+(define set-viewport
+  (render-lift1 set-graphics-viewport!))
+
+(define projection-mul
+  (render-lift1 graphics-projection-mul!))
+
+(define projection-identity
+  (render-lift1 graphics-projection-identity!))
+
+(define model-view-mul
+  (render-lift1 graphics-model-view-mul!))
+
+(define model-view-identity
+  (render-lift1 graphics-model-view-identity!))
+
+(define (with-blend-mode blend-mode renderer)
+  (blend-mode-excursion
+   (render-begin (set-blend-mode blend-mode) renderer)))
+
+(define (with-depth-test depth-test renderer)
+  (depth-test-excursion
+   (render-begin (set-depth-test depth-test) renderer)))
+
+(define (with-texture texture renderer)
+  (texture-excursion
+   (render-begin (set-texture texture) renderer)))
+
+(define (with-shader shader renderer)
+  (shader-excursion
+   (render-begin (set-shader shader) renderer)))
+
+(define (with-mesh mesh renderer)
+  (mesh-excursion
+   (render-begin (set-mesh mesh) renderer)))
+
+(define (with-framebuffer framebuffer renderer)
+  (framebuffer-excursion
+   (render-begin (set-framebuffer framebuffer) renderer)))
+
+(define (with-viewport viewport renderer)
+  (viewport-excursion
+   (render-begin (set-viewport viewport) renderer)))
+
+(define (with-projection-mul transform renderer)
+  (projection-excursion
+   (render-begin (projection-mul transform) renderer)))
+
+(define (with-model-view-mul transform renderer)
+  (model-view-excursion
+   (render-begin (model-view-mul transform) renderer)))
+
+(define (move v renderer)
+  "Create a new renderer that moves the scene by the vector V and
+applies RENDERER."
+  (with-model-view-mul (t:translate v) renderer))
+
+(define (scale s renderer)
+  "Create a new renderer that scales the scene by S and applies
+RENDERER."
+  (with-model-view-mul (t:scale s) renderer))
+
+(define (rotate-z theta renderer)
+  "Create a new renderer that rotates the scene by THETA about the Z
+axis and applies RENDERER."
+  (with-model-view-mul (t:rotate-z theta) renderer))
+
+(define (clear-screen gfx)
+  "Clear the current viewport bound to GFX."
+  (clear-viewport (graphics-viewport gfx)))
+
+(define-syntax-rule (uniform-let ((uniform value) ...) renderer ...)
+  "Bind each UNIFORM to its respective VALUE in the curently bound
+shader program, then apply each RENDERER."
+  (lambda (gfx)
+    (graphics-uniform-excursion gfx `((uniform ,value) ...)
+      (lambda (gfx)
+        (renderer gfx) ...))))
+
+(define (with-color color renderer)
+  "Create a new renderer that sets the 'color' uniform variable to
+COLOR and applies RENDERER."
+  (uniform-let ((color color))
+    renderer))
+
+(define (render-mesh mesh)
+  "Create a new renderer that render MESH to the framebuffer."
+  (lambda (gfx)
+    (graphics-model-view-excursion gfx
+      (lambda (gfx)
+        (graphics-model-view-mul! gfx (graphics-projection-transform gfx))
+        (graphics-mesh-excursion gfx
+          (lambda (gfx)
+            (set-graphics-mesh! gfx mesh)
+            (graphics-uniform-excursion gfx
+                `((mvp ,(graphics-model-view-transform gfx))
+                  (texture? ,(not (texture-null?
+                                   (graphics-texture gfx)))))
+              draw-graphics-mesh!)))))))
diff --git a/sly/render/camera.scm b/sly/render/camera.scm
index 9de7ae6..d943896 100644
--- a/sly/render/camera.scm
+++ b/sly/render/camera.scm
@@ -1,5 +1,5 @@
 ;;; Sly
-;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
+;;; Copyright (C) 2014, 2015 David Thompson <davet@gnu.org>
 ;;;
 ;;; Sly is free software: you can redistribute it and/or modify it
 ;;; under the terms of the GNU General Public License as published by
@@ -17,7 +17,7 @@
 
 ;;; Commentary:
 ;;
-;; Cameras and viewports.
+;; Cameras.
 ;;
 ;;; Code:
 
@@ -29,94 +29,53 @@
   #:use-module (gl enums)
   #:use-module (sly wrappers gl)
   #:use-module (sly utils)
+  #:use-module (sly render)
   #:use-module (sly render color)
+  #:use-module (sly render viewport)
   #:use-module (sly math rect)
   #:use-module (sly math transform)
-  #:export (make-viewport
-            viewport?
-            viewport-area
-            viewport-clear-color
-            viewport-clear-flags
-            null-viewport
-            %standard-clear-flags
-            apply-viewport
-            clear-viewport
-            make-camera camera?
-            camera-location camera-projection camera-viewport
-            orthographic-camera))
-
-;;;
-;;; Viewport
-;;;
-
-(define-record-type <viewport>
-  (%make-viewport area clear-color clear-flags)
-  viewport?
-  (area viewport-area)
-  (clear-color viewport-clear-color)
-  (clear-flags viewport-clear-flags))
-
-(define %standard-clear-flags '(color-buffer depth-buffer))
-
-(define* (make-viewport area #:optional #:key (clear-color black)
-                        (clear-flags %standard-clear-flags))
-  "Create a viewport that covers the rectangle AREA of the window.
-Fill the viewport with CLEAR-COLOR when clearing the screen.  Clear
-the buffers denoted by the list of symbols in CLEAR-FLAGS.  Possible
-values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer',
-'accum-buffer', and 'stencil-buffer'."
-  (%make-viewport area clear-color clear-flags))
-
-(define null-viewport (make-viewport (make-rect 0 0 0 0)))
-
-(define clear-buffer-mask
-  (memoize
-   (lambda (flags)
-     (apply logior
-            ;; Map symbols to OpenGL constants.
-            (map (match-lambda
-                  ('depth-buffer 256)
-                  ('accum-buffer 512)
-                  ('stencil-buffer 1024)
-                  ('color-buffer 16384))
-                 flags)))))
-
-(define (apply-viewport viewport)
-  "Set the OpenGL state for VIEWPORT.  Clip rendering to the viewport
-area, set the clear color, and clear necessary buffers."
-  (gl-enable (enable-cap scissor-test))
-  (match (viewport-area viewport)
-    (($ <rect> x y width height)
-     (gl-viewport x y width height)
-     (gl-scissor x y width height)))
-  (match (viewport-clear-color viewport)
-    (($ <color> r g b a)
-     (gl-clear-color r g b a))))
-
-(define (clear-viewport viewport)
-  "Clear the relevant OpenGL buffers VIEWPORT."
-  (gl-clear (clear-buffer-mask (viewport-clear-flags viewport))))
-
-;;;
-;;; Camera
-;;;
+  #:use-module (sly math vector)
+  #:export (make-camera
+            camera?
+            camera-projection
+            camera-location
+            camera-viewport
+            with-camera
+            2d-camera))
 
 (define-record-type <camera>
-  (make-camera location projection viewport)
+  (make-camera projection location viewport)
   camera?
-  (location camera-location)
   (projection camera-projection)
+  (location camera-location)
   (viewport camera-viewport))
 
-(define* (orthographic-camera width height
-                              #:optional #:key
-                              (z-near 0) (z-far 1)
-                              (viewport (make-viewport
-                                         (make-rect 0 0 width height))))
-  "Create a camera object that uses an orthographic (2D) projection of
-size WIDTH x HEIGHT.  Optionally, z-axis clipping planes Z-NEAR and
-Z-FAR can be specified, but default to 0 and 1, respectively.  By
-default, the camera's VIEWPORT is WIDTH x HEIGHT, which is convenient if
-the dimensions are measured in pixels."
-  (let ((projection (orthographic-projection 0 width height 0 z-near z-far)))
-    (make-camera identity-transform projection viewport)))
+(define (with-camera camera renderer)
+  (projection-excursion
+   (render-begin
+    projection-identity
+    (projection-mul (camera-projection camera))
+    (move (camera-location camera)
+          (with-viewport (camera-viewport camera)
+            (render-begin
+             clear-screen
+             renderer))))))
+
+(define* (2d-camera #:key (z-near 0) (z-far 1) (area (make-rect 0 0 640 480))
+                    (clear-color black) (clear-flags %standard-clear-flags)
+                    (location (vector2 0 0)))
+  "Create a camera that uses an orthographic (2D) projection that
+spans AREA in the framebuffer. By default, this area is (0, 0)
+-> (640, 480) pixels.  Z-axis clipping planes Z-NEAR and Z-FAR may be
+specified but default to 0 and 1, respectively.  CLEAR-COLOR specifies
+the background color used when clearing the screen.  Black is used by
+default.  CLEAR-FLAGS specifies the buffers that are cleared when the
+camera is applied.  The color and depth buffers are cleared by
+default.  LOCATION specifies the position of the camera in the scene.
+The origin is used as the default location."
+  (let ((viewport (make-viewport area #:clear-color clear-color
+                                 #:clear-flags clear-flags))
+        (projection (orthographic-projection 0 (rect-width area)
+                                             (rect-height area) 0
+                                             z-near z-far)))
+    (make-camera projection location viewport)))
diff --git a/sly/render/font.scm b/sly/render/font.scm
index dff74a2..dace505 100644
--- a/sly/render/font.scm
+++ b/sly/render/font.scm
@@ -33,7 +33,6 @@
   #:use-module (sly wrappers gl)
   #:use-module (sly render color)
   #:use-module (sly config)
-  #:use-module (sly render mesh)
   #:use-module (sly render sprite)
   #:use-module (sly render texture)
   #:export (enable-fonts
@@ -41,7 +40,7 @@
             load-default-font
             font?
             font-point-size
-            make-label label))
+            make-label))
 
 ;;;
 ;;; Font
@@ -95,9 +94,8 @@ HEIGHT, 32 bit color bytevector."
     ;; Need to flip pixels so that origin is on the bottom-left.
     (bytevector->texture pixels width height 'linear 'linear)))
 
-(define* (make-label font text #:optional #:key
-                     (anchor 'top-left))
+(define* (make-label font text #:key (anchor 'top-left))
+  "Create a sprite that displays TEXT rendered using FONT.  ANCHOR
+defines the sprite's origin, which is 'top-left' by default."
   (let ((texture (render-text font text)))
     (make-sprite texture #:anchor anchor)))
-
-(define label make-label)
diff --git a/sly/render/shader.scm b/sly/render/shader.scm
index 392ebc5..cb3828d 100644
--- a/sly/render/shader.scm
+++ b/sly/render/shader.scm
@@ -44,13 +44,14 @@
             shader-type
             shader-id
             make-shader-program
+            shader-program?
             load-shader-program
             vertex-position-location
             vertex-texture-location
             shader-program-uniform-location
             shader-program-attribute-location
             shader-program-id
-            shader-program?
+            shader-program-uniforms
             shader-program-linked?
             null-shader-program
             apply-shader-program
@@ -58,6 +59,10 @@
             load-default-shader
             %uniform-setters
             register-uniform-setter!
+            uniform?
+            uniform-name
+            uniform-gl-name
+            uniform-default
             uniform-set!
             uniforms))
 
@@ -182,10 +187,12 @@ in the file FILENAME."
 ;;;
 
 (define-record-type <uniform>
-  (make-uniform name location)
+  (make-uniform name gl-name location default)
   uniform?
   (name uniform-name)
-  (location uniform-location))
+  (gl-name uniform-gl-name)
+  (location uniform-location)
+  (default uniform-default))
 
 (define-record-type <attribute>
   (make-attribute name location)
@@ -203,14 +210,13 @@ in the file FILENAME."
 (define vertex-position-location 0)
 (define vertex-texture-location 1)
 
-(define (shader-program-uniform-location shader-program uniform-name)
-  (let ((uniform (find (match-lambda
-                        (($ <uniform> name _)
-                         (string=? uniform-name name)))
+(define (shader-program-uniform-location shader-program name)
+  (let ((uniform (find (lambda (uniform)
+                         (eq? (uniform-name uniform) name))
                        (shader-program-uniforms shader-program))))
     (if uniform
         (uniform-location uniform)
-        (error "Uniform not found: " uniform-name))))
+        (error "Uniform not found: " name))))
 
 (define (shader-program-attribute-location shader-program attribute-name)
   (let ((attribute (find (match-lambda
@@ -238,11 +244,13 @@ VERTEX-SHADER and FRAGMENT-SHADER."
            vertex-shader fragment-shader))
   (let ((id (glCreateProgram))
         (shaders (list vertex-shader fragment-shader)))
-    (define (string->uniform uniform-name)
-      (let ((location (glGetUniformLocation id uniform-name)))
-        (if (= location -1)
-            (error "Uniform not found: " uniform-name)
-            (make-uniform uniform-name location))))
+    (define build-uniform
+      (match-lambda
+       ((name gl-name default)
+        (let ((location (glGetUniformLocation id gl-name)))
+          (if (= location -1)
+              (error "Uniform not found: " gl-name)
+              (make-uniform name gl-name location default))))))
 
     (define (string->attribute attribute-name)
       (let ((location (glGetAttribLocation id attribute-name)))
@@ -266,7 +274,7 @@ VERTEX-SHADER and FRAGMENT-SHADER."
         (for-each (lambda (shader)
                     (glDetachShader id (shader-id shader)))
                   shaders)
-        (let* ((uniforms (map string->uniform uniforms))
+        (let* ((uniforms (map build-uniform uniforms))
                (attributes (map string->attribute attributes))
                (shader-program (%make-shader-program id uniforms attributes)))
           (shader-program-guardian shader-program)
@@ -297,17 +305,6 @@ VERTEX-SHADER and FRAGMENT-SHADER."
         (glUseProgram 0)
         return-value))))
 
-(define load-default-shader
-  (memoize
-   (lambda ()
-     (load-shader-program
-      (string-append %pkgdatadir
-                     "/shaders/default-vertex.glsl")
-      (string-append %pkgdatadir
-                     "/shaders/default-fragment.glsl")
-      '("mvp" "color" "use_texture")
-      '("position" "tex")))))
-
 ;;;
 ;;; Uniforms
 ;;;
@@ -377,19 +374,19 @@ within SHADER-PROGRAM."
         ((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) 'name value)
-       ...
-       body ...))))
+;;;
+;;; Built-in Shaders
+;;;
+
+(define load-default-shader
+  (memoize
+   (lambda ()
+     (load-shader-program
+      (string-append %pkgdatadir
+                     "/shaders/default-vertex.glsl")
+      (string-append %pkgdatadir
+                     "/shaders/default-fragment.glsl")
+      `((mvp "mvp" ,identity-transform)
+        (color "color" ,white)
+        (texture? "use_texture" #f))
+      '("position" "tex")))))
diff --git a/sly/render/sprite.scm b/sly/render/sprite.scm
index d0ba059..c0ad5bb 100644
--- a/sly/render/sprite.scm
+++ b/sly/render/sprite.scm
@@ -24,29 +24,35 @@
 
 (define-module (sly render sprite)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-9)
   #:use-module (gl)
-  #:use-module (gl contrib packed-struct)
-  #:use-module ((sdl sdl) #:prefix SDL:)
-  #:use-module (sly render color)
-  #:use-module (sly config)
   #:use-module (sly agenda)
   #:use-module (sly utils)
-  #:use-module (sly math)
+  #:use-module (sly render)
+  #:use-module (sly render color)
   #:use-module (sly render mesh)
-  #:use-module (sly render model)
   #:use-module (sly render texture)
+  #:use-module (sly render utils)
   #:use-module (sly math vector)
-  #:export (make-sprite sprite load-sprite))
+  #:export (make-sprite
+            load-sprite
+            sprite?
+            sprite-texture
+            sprite-mesh
+            render-sprite))
 
-;;;
-;;; Sprites
-;;;
+(define-record-type <sprite>
+  (%make-sprite texture mesh)
+  sprite?
+  (texture sprite-texture)
+  (mesh sprite-mesh))
 
-(define* (make-sprite texture #:optional #:key
-                      (anchor 'center))
-  "Return a 2D rectangular mesh that displays the image TEXTURE.  The
-size of the mesh is the size of TEXTURE, in pixels."
+(define* (make-sprite texture #:key (anchor 'center))
+  "Create a sprite that displays the image in TEXTURE.  The size of
+the mesh is the size of TEXTURE in pixels.  ANCHOR defines the origin
+of the sprite.  By default, the anchor is 'center', which puts the
+origin in the middle of the sprite.  See 'anchor-texture' for more
+anchoring options."
   (let* ((anchor (anchor-texture texture anchor))
          (x1 (- (floor (vx anchor))))
          (y1 (- (floor (vy anchor))))
@@ -67,12 +73,16 @@ size of the mesh is the size of TEXTURE, in pixels."
                             (vector2 s2 t1)
                             (vector2 s2 t2)
                             (vector2 s1 t2)))))
-    (make-model #:texture texture
-                #:mesh mesh
-                #:depth-test? #f)))
+    (%make-sprite texture mesh)))
 
-(define sprite make-sprite)
+(define* (load-sprite file #:key (anchor 'center))
+  "Create a sprite from the texture in FILE whose origin is defined by
+ANCHOR.  The default anchor is 'center'."
+  (make-sprite (load-texture file) #:anchor anchor))
 
-(define* (load-sprite file-name #:key (anchor 'center))
-  "Return a sprite mesh for the texture loaded from FILE-NAME."
-  (make-sprite (load-texture file-name) #:anchor anchor))
+(define* (render-sprite sprite)
+  "Create a renderer that draws a 2D rectangular mesh that displays
+the image TEXTURE.  The size of the mesh is the size of TEXTURE in
+pixels."
+  (with-texture (sprite-texture sprite)
+    (render-mesh (sprite-mesh sprite))))
diff --git a/sly/render/texture.scm b/sly/render/texture.scm
index df786b6..ef8c3ea 100644
--- a/sly/render/texture.scm
+++ b/sly/render/texture.scm
@@ -53,8 +53,7 @@
             texture-vertex
             pack-texture-vertices
             draw-texture-vertices
-            apply-texture
-            with-texture))
+            apply-texture))
 
 ;;;
 ;;; Textures
@@ -229,13 +228,6 @@ vector to be returned."
   (glBindTexture (texture-target texture-2d)
                  (texture-id texture)))
 
-(define-syntax-rule (with-texture texture body ...)
-  (begin
-    (apply-texture texture)
-    body
-    ...
-    (glBindTexture (texture-target texture-2d) 0)))
-
 (define (draw-texture-vertices texture vertices size)
   (let ((pointer-type (tex-coord-pointer-type float)))
     (gl-enable-client-state (enable-cap vertex-array))
diff --git a/sly/render/tile-map.scm b/sly/render/tile-map.scm
index 8e8cd0f..594aa14 100644
--- a/sly/render/tile-map.scm
+++ b/sly/render/tile-map.scm
@@ -26,20 +26,18 @@
   #:use-module (ice-9 vlist)
   #:use-module (sly utils)
   #:use-module (sly math vector)
+  #:use-module (sly render)
   #:use-module (sly render mesh)
-  #:use-module (sly render model)
   #:use-module (sly render shader)
   #:use-module (sly render texture)
   #:use-module (sly render tileset)
   #:export (compile-tile-layer))
 
-(define* (compile-tile-layer tiles tile-width tile-height
-                             #:key (shader (load-default-shader)))
+(define* (compile-tile-layer tiles tile-width tile-height)
   "Compile the two-dimensional vlist TILES into a list of models for
 efficient rendering.  The resulting map spaces each tile by TILE-WIDTH
-and TILE-HEIGHT.  The compiled models all use the given SHADER when
-rendered.  TILES is assumed to be rectangular, with each row having
-equal elements."
+and TILE-HEIGHT.  TILES is assumed to be rectangular, with each row
+having equal elements."
   (define (make-tile-vertices x y tile)
     (let* ((x1 (* x tile-width))
            (y1 (* y tile-height))
@@ -121,9 +119,10 @@ equal elements."
 
   (map (match-lambda
         ((texture (indices positions textures))
-         (make-model #:mesh (build-mesh (list->vector (offset-indices indices))
-                                        (list->vector positions)
-                                        (list->vector textures))
-                     #:texture texture
-                     #:shader shader)))
+         (render-begin
+          (with-texture texture
+            (render-mesh
+             (build-mesh (list->vector (offset-indices indices))
+                         (list->vector positions)
+                         (list->vector textures)))))))
        vertices))
diff --git a/sly/render/viewport.scm b/sly/render/viewport.scm
new file mode 100644
index 0000000..054646e
--- /dev/null
+++ b/sly/render/viewport.scm
@@ -0,0 +1,92 @@
+;;; Sly
+;;; Copyright (C) 2014, 2015 David Thompson <davet@gnu.org>
+;;;
+;;; Sly 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Sly 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 this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Viewports.
+;;
+;;; Code:
+
+(define-module (sly render viewport)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (gl)
+  #:use-module (gl low-level)
+  #:use-module (sly wrappers gl)
+  #:use-module (sly math rect)
+  #:use-module (sly utils)
+  #:use-module (sly render color)
+  #:export (make-viewport
+            viewport?
+            viewport-area
+            viewport-clear-color
+            viewport-clear-flags
+            null-viewport
+            %standard-clear-flags
+            apply-viewport
+            clear-viewport))
+;;;
+;;; Viewport
+;;;
+
+(define-record-type <viewport>
+  (%make-viewport area clear-color clear-flags)
+  viewport?
+  (area viewport-area)
+  (clear-color viewport-clear-color)
+  (clear-flags viewport-clear-flags))
+
+(define %standard-clear-flags '(color-buffer depth-buffer))
+
+(define* (make-viewport area #:optional #:key (clear-color black)
+                        (clear-flags %standard-clear-flags))
+  "Create a viewport that covers the rectangle AREA of the window.
+Fill the viewport with CLEAR-COLOR when clearing the screen.  Clear
+the buffers denoted by the list of symbols in CLEAR-FLAGS.  Possible
+values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer',
+'accum-buffer', and 'stencil-buffer'."
+  (%make-viewport area clear-color clear-flags))
+
+(define null-viewport (make-viewport (make-rect 0 0 0 0)))
+
+(define clear-buffer-mask
+  (memoize
+   (lambda (flags)
+     (apply logior
+            ;; Map symbols to OpenGL constants.
+            (map (match-lambda
+                  ('depth-buffer 256)
+                  ('accum-buffer 512)
+                  ('stencil-buffer 1024)
+                  ('color-buffer 16384))
+                 flags)))))
+
+(define (apply-viewport viewport)
+  "Set the OpenGL state for VIEWPORT.  Clip rendering to the viewport
+area, set the clear color, and clear necessary buffers."
+  (gl-enable (enable-cap scissor-test))
+  (match (viewport-area viewport)
+    (($ <rect> x y width height)
+     (gl-viewport x y width height)
+     (gl-scissor x y width height)))
+  (match (viewport-clear-color viewport)
+    (($ <color> r g b a)
+     (gl-clear-color r g b a))))
+
+(define (clear-viewport viewport)
+  "Clear the relevant OpenGL buffers VIEWPORT."
+  (gl-clear (clear-buffer-mask (viewport-clear-flags viewport))))