render: context: Rewrite transform stack.

* sly/render/context.scm (with-temp-transform): Delete.
  (render-context-transform, render-context-transform*!,
  render-context-transform-identity!, render-context-push-transform!,
  render-context-pop-transform!, copy-transform!): New procedures.
  (with-transform-excursion): New syntax.
  (render-context-reset!): Set top of matrix stack to identity matrix.

2 files changed, 53 insertions, 25 deletions

diff --git a/sly/render/context.scm b/sly/render/context.scm
index 1e23f17..e3ccd21 100644
--- a/sly/render/context.scm
+++ b/sly/render/context.scm
@@ -36,12 +36,15 @@
   #:use-module (sly render mesh)
   #:export (make-render-context
             render-context?
-            with-render-context with-temp-transform
+            with-render-context
             render-context-blend-mode set-render-context-blend-mode!
             render-context-depth-test? set-render-context-depth-test?!
             render-context-texture set-render-context-texture!
             render-context-shader set-render-context-shader!
-            render-context-mesh set-render-context-mesh!))
+            render-context-mesh set-render-context-mesh!
+            render-context-transform render-context-transform*!
+            render-context-transform-identity!
+            with-transform-excursion))
 
 (define-record-type <gl-parameter>
   (%make-gl-parameter default bind value)
@@ -97,7 +100,8 @@
   (gl-parameter-reset! (render-context-depth-test? context))
   (gl-parameter-reset! (render-context-texture context))
   (gl-parameter-reset! (render-context-shader context))
-  (gl-parameter-reset! (render-context-mesh context)))
+  (gl-parameter-reset! (render-context-mesh context))
+  (render-context-transform-identity! context))
 
 (define-syntax-rule (with-render-context context body ...)
   (begin (render-context-reset! context)
@@ -123,9 +127,32 @@
 (define-context-setter set-render-context-mesh!
   render-context-mesh)
 
-;; emacs: (put 'with-temp-transform 'scheme-indent-function 2)
-(define-syntax-rule (with-temp-transform context name body ...)
-  (let* ((stack (render-context-transform-stack context))
-         (name (q-pop! stack)))
-    (begin body ...)
-    (q-push! stack name)))
+(define (render-context-transform context)
+  (q-front (render-context-transform-stack context)))
+
+(define (render-context-push-transform! context t)
+  (q-push! (render-context-transform-stack context) t))
+
+(define render-context-pop-transform!
+  (compose q-pop! render-context-transform-stack))
+
+(define (copy-transform! src dest)
+  (array-copy! (transform-matrix src) (transform-matrix dest)))
+
+;; emacs: (put 'with-transform-excursion 'scheme-indent-function 1)
+(define-syntax-rule (with-transform-excursion context body ...)
+  (let ((t (render-context-pop-transform! context)))
+    (dynamic-wind
+      (lambda ()
+        (copy-transform! t (render-context-transform context)))
+      (lambda () body ...)
+      (lambda ()
+        (render-context-push-transform! context t)))))
+
+(define (render-context-transform*! context t)
+  (let ((dest (render-context-transform context)))
+    (with-transform-excursion context
+      (transform*! dest (render-context-transform context) t))))
+
+(define (render-context-transform-identity! context)
+  (copy-transform! identity-transform (render-context-transform context)))
diff --git a/sly/render/model.scm b/sly/render/model.scm
index 01c1223..fdda5ed 100644
--- a/sly/render/model.scm
+++ b/sly/render/model.scm
@@ -121,39 +121,40 @@ changing the fields specified in KWARGS."
       "Render MODEL by applying its transform (multiplied by VIEW), texture,
 shader, vertex array, uniforms, blend mode, etc. to the render
 CONTEXT."
-      (define (iter model world-transform view context)
+      (define (iter model view context)
         (match model
-          (($ <model> mesh transform texture shader color blend-mode
+          (($ <model> mesh local-transform texture shader color blend-mode
                       depth-test? children)
-           (with-temp-transform context new-transform
-             (transform*! new-transform transform world-transform)
-             (with-temp-transform context mvp
-              (transform*! mvp new-transform view)
+           (with-transform-excursion context
+             (render-context-transform*! context local-transform)
+             (with-transform-excursion context
+              (render-context-transform*! context view)
               (set-render-context-depth-test?! context depth-test?)
               (set-render-context-blend-mode! context blend-mode)
               (set-render-context-shader! context shader)
               (set-render-context-mesh! context mesh)
               (set-render-context-texture! context texture)
               ;; TODO: Support user-defined uniforms.
-              (uniform-set! shader "mvp" mvp)
+              (uniform-set! shader "mvp" (render-context-transform context))
               (uniform-set! shader "color" color)
               (glDrawElements (begin-mode triangles)
                               (mesh-length mesh)
                               (data-type unsigned-int)
                               %null-pointer))
              (for-each (lambda (child)
-                         (iter child new-transform view context))
+                         (iter child view context))
                        children)))))
 
       (with-render-context context
-        (with-temp-transform context view
-          (transform*! view
-                       (camera-location camera)
-                       (camera-projection camera))
-          (with-temp-transform context base-transform
-            (set-transform-identity! base-transform)
-            (apply-viewport (camera-viewport camera))
-            (iter model base-transform view context)))))))
+        (with-transform-excursion context
+          (let ((view (render-context-transform context)))
+            (transform*! view
+                         (camera-location camera)
+                         (camera-projection camera))
+            (with-transform-excursion context
+              (render-context-transform-identity! context)
+              (apply-viewport (camera-viewport camera))
+              (iter model view context))))))))
 
 ;;;
 ;;; Utility Procedures