From 1020c733a6d668eaa7fc6cc353c9c58513bf883a Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 29 Oct 2019 17:15:03 -0400
Subject: render: shader: Fix sampler2D uniform value application.

---
 chickadee/render.scm        | 14 ++++++-------
 chickadee/render/shader.scm | 49 ++++++++++++++++++++++++++++++++++-----------
 2 files changed, 44 insertions(+), 19 deletions(-)

diff --git a/chickadee/render.scm b/chickadee/render.scm
index edf21f7..8b5ba6c 100644
--- a/chickadee/render.scm
+++ b/chickadee/render.scm
@@ -155,13 +155,13 @@
         (loop (1+ i))))
     (uniform-apply shader uniforms)
     ;; Sampler2D values aren't explicitly passed as uniform values via
-    ;; gpu-apply, so we have to set their values correctly behind the
-    ;; scenes.
-    (uniform-namespace-for-each
-     (lambda (name uniform)
-       (when (and (uniform? uniform) (eq? 'sampler-2d (uniform-type uniform)))
-         (shader-uniform-set! shader (uniform-name uniform) (uniform-value uniform))))
-     (shader-uniforms shader))))
+    ;; gpu-apply, so we have to bind them to the proper texture units
+    ;; behind the scenes.
+    (shader-uniform-for-each
+     (lambda (uniform)
+       (when (eq? (uniform-type uniform) sampler-2d)
+         (set-uniform-value! shader uniform (uniform-value uniform))))
+     shader)))
 
 (define-syntax-rule (gpu-apply* shader vertex-array count . uniforms)
   (begin
diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index 050a81c..28b9b12 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -59,6 +59,8 @@
             shader-uniforms
             shader-attributes
             shader-uniform-set!
+            shader-uniform-for-each
+            set-uniform-value!
             uniform?
             uniform-name
             uniform-type
@@ -730,24 +732,47 @@ shader program."
   (let ((uniform (uniform-namespace-ref (shader-uniforms shader) name)))
     (or uniform (error "no such uniform" name))))
 
+(define (set-uniform-value! shader uniform value)
+  ;; TODO: Figure out a way to avoid unnecessary uniform
+  ;; updates.  Maybe UBOs would help address this?
+  (let ((type (uniform-type uniform)))
+    (shader-primitive-type-serialize type (shader-scratch shader) value)
+    (shader-primitive-type-apply-uniform type (uniform-location uniform) 1
+                                         (shader-scratch-pointer shader))
+    (%set-uniform-value! uniform value)))
+
+(define (shader-uniform-for-each proc shader)
+  (define (traverse thing)
+    (cond
+     ((uniform? thing)
+      (proc thing))
+     ((uniform-namespace? thing)
+      (uniform-namespace-for-each
+       (lambda (key uniform)
+         (traverse uniform))
+       thing))
+     ((uniform-array? thing)
+      (let ((size (uniform-array-size thing)))
+        (let loop ((i 0))
+          (when (< i size)
+            (traverse (uniform-array-namespace-ref thing i))
+            (loop (+ i 1))))))))
+  (traverse (shader-uniforms shader)))
+
+;; TODO: This walks the entire tree every time, but it should instead
+;; stop traversing once it finds the correct leaf node.
 (define (shader-uniform-set! shader uniform-name x)
   (define (traverse uniform value)
     (cond
      ;; A leaf node of the uniform tree representing a single uniform
      ;; location as determined by OpenGL.
      ((uniform? uniform)
-      (let ((type (uniform-type uniform)))
-        ;; A vector of a primitive type must be the exact size that
-        ;; the shader expects.
-        (when (and (> (uniform-size uniform) 1)
-                   (not (= (uniform-size uniform) (vector-length x))))
-          (error "vector size mismatch for uniform" uniform-name))
-        ;; TODO: Figure out a way to avoid unnecessary uniform
-        ;; updates.  Maybe UBOs would help address this?
-        (shader-primitive-type-serialize type (shader-scratch shader) value)
-        (shader-primitive-type-apply-uniform type (uniform-location uniform) 1
-                                             (shader-scratch-pointer shader))
-        (%set-uniform-value! uniform value)))
+      ;; A vector of a primitive type must be the exact size that
+      ;; the shader expects.
+      (when (and (> (uniform-size uniform) 1)
+                 (not (= (uniform-size uniform) (vector-length x))))
+        (error "vector size mismatch for uniform" uniform-name))
+      (set-uniform-value! shader uniform value))
      ;; A nested namespace indicates that this must be a struct.
      ((uniform-namespace? uniform)
       (if (shader-struct? value)
-- 
cgit v1.2.3