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.

1 files changed, 325 insertions, 48 deletions

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!)))))))