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, 77 insertions, 63 deletions

diff --git a/examples/2048/2048.scm b/examples/2048/2048.scm
index 97922de..05eb78b 100755
--- a/examples/2048/2048.scm
+++ b/examples/2048/2048.scm
@@ -33,11 +33,10 @@
              (sly math transform)
              (sly math tween)
              (sly math vector)
+             (sly render)
              (sly render camera)
              (sly render color)
              (sly render font)
-             (sly render model)
-             (sly render scene)
              (sly render sprite)
              (sly render texture)
              (sly input keyboard)
@@ -310,26 +309,29 @@
 (define (tile-text-color n)
   (assoc-ref (assoc-ref tile-properties n) 'text-color))
 
-(define tile-sprite (make-sprite tile-texture #:anchor (vector2 0 0)))
+(define tile-sprite
+  (make-sprite tile-texture #:anchor (vector2 0 0)))
 
 (define tile-label-cache
   (map (lambda (n)
-         (cons n (label font (number->string n) #:anchor 'center)))
+         (cons n (make-label font (number->string n) #:anchor 'center)))
        '(2 4 8 16 32 64 128 256 512 1024 2048)))
 
-(define (make-tile x y n)
-  (let* ((w (texture-width tile-texture))
-         (h (texture-height tile-texture))
-         (label (assoc-ref tile-label-cache n))
-         (label-color (tile-text-color n))
-         (bg-color (tile-bg-color n))
-         (tile (model-group (model-paint bg-color tile-sprite)
-                            (if (zero? n)
-                                null-model
-                                (chain label
-                                  (model-paint label-color)
-                                  (model-move (vector2 (/ w 2) (/ h 2))))))))
-    (model-move (vector2 (* x w) (* y h)) tile)))
+(define (render-tile x y n)
+  (let ((w (texture-width tile-texture))
+        (h (texture-height tile-texture))
+        (label (assoc-ref tile-label-cache n))
+        (label-color (tile-text-color n))
+        (bg-color (tile-bg-color n)))
+    (move (vector2 (* x w) (* y h))
+          (render-begin
+           (with-color bg-color
+             (render-sprite tile-sprite))
+           (if (zero? n)
+               render-nothing
+               (with-color label-color
+                 (move (vector2 (/ w 2) (/ h 2))
+                       (render-sprite label))))))))
 
 (define window-width 640)
 (define window-height 480)
@@ -343,29 +345,33 @@
 (define (enumerate-board board)
   (enumerate (map (cut enumerate <>) board)))
 
+(define (render-board board)
+  (list->renderer
+   (append-map
+    (match-lambda
+     ((y (row ...))
+      (map (match-lambda
+            ((x n)
+             (render-tile x y n)))
+           row)))
+    (enumerate-board board))))
+
 (define-signal tiles
-  (signal-map (lambda (board)
-                (list->model
-                 (append-map
-                  (match-lambda
-                   ((y (row ...))
-                    (map (match-lambda
-                          ((x n)
-                           (make-tile x y n)))
-                         row)))
-                  (enumerate-board board))))
-              board))
+  (signal-map render-board board))
 
 (define play-again-font (load-default-font 16))
 
+(define (render-label font text anchor)
+  (with-color black
+    (render-sprite
+     (make-label font text #:anchor anchor))))
+
 (define-signal status-message
-  (let ((play-again (model-paint black (label play-again-font
-                                              "Press N to play again"
-                                              #:anchor 'top-center)))
-        (game-over (model-paint black (label font "GAME OVER"
-                                             #:anchor 'bottom-center)))
-        (you-win (model-paint black (label font "YOU WIN!"
-                                           #:anchor 'bottom-center))))
+  (let ((play-again (render-label play-again-font
+                                  "Press N to play again"
+                                  'top-center))
+        (game-over  (render-label font "GAME OVER" 'bottom-center))
+        (you-win    (render-label font "YOU WIN!" 'bottom-center)))
     (signal-map
      (lambda (board)
        (let ((message (cond
@@ -373,10 +379,10 @@
                        ((board-win? board) you-win)
                        (else #f))))
          (if message
-             (model-move (vector2 (/ board-width 2)
-                                  (/ board-height 2))
-                         (model-group message play-again))
-             null-model)))
+             (move (vector2 (/ board-width 2)
+                            (/ board-height 2))
+                   (render-begin message play-again))
+             render-nothing)))
      board)))
 
 (define instruction-font (load-default-font 16))
@@ -385,11 +391,12 @@
   "Use the arrow keys to join the numbers and get to the 2048 tile!")
 
 (define-signal instructions
-  (chain (label instruction-font instruction-text
-                #:anchor 'top-center)
-    (model-paint text-color-1)
-    (model-move (vector2 (/ board-width 2)
-                         (- window-height (vy center-pos))))))
+  (with-color text-color-1
+    (move (vector2 (/ board-width 2)
+                   (- window-height (vy center-pos)))
+          (render-sprite
+           (make-label instruction-font instruction-text
+                       #:anchor 'top-center)))))
 
 (define score-header-font (load-default-font 14))
 (define score-font (load-default-font 22))
@@ -401,18 +408,19 @@
                            (tween vlerp ease-linear from to duration)))
          (color-tween (tween color-lerp ease-linear
                              transparent text-color-1 duration))
-         (header (label score-header-font text #:anchor 'top-center)))
+         (header (make-label score-header-font text #:anchor 'top-center)))
     (signal-let* ((score (signal-drop-repeats score))
                   (timer (signal-drop (lambda (t) (> t duration))
                                       0 (signal-since 1 score))))
-      (let ((score (label score-font (number->string score)
-                          #:anchor 'center)))
-        (model-move (vector2 x (- window-height 28))
-                    (model-group
-                     (model-paint text-color-1 header)
-                     (chain score
-                       (model-paint (color-tween timer))
-                       (model-move (position-tween timer)))))))))
+      (let ((score (make-label score-font (number->string score)
+                               #:anchor 'center)))
+        (move (vector2 x (- window-height 28))
+              (render-begin
+               (with-color text-color-1
+                 (render-sprite header))
+               (move (position-tween timer)
+                     (with-color (color-tween timer)
+                      (render-sprite score)))))))))
 
 (define-signal score
   (score-label "SCORE" (signal-map 2048-score 2048-state) (/ board-width 4)))
@@ -421,20 +429,26 @@
   (score-label "BEST" (signal-map 2048-best-score 2048-state)
                (- board-width (/ board-width 4))))
 
-(define-signal 2048-model
-  (signal-map (cut model-move center-pos <>)
-              (signal-map model-group
-                          instructions tiles score best-score status-message)))
+(define-signal 2048-view
+  (signal-let ((instructions instructions)
+               (tiles tiles)
+               (score score)
+               (best-score best-score)
+               (status-message status-message))
+    (move center-pos
+          (render-begin
+           instructions
+           tiles
+           score
+           best-score
+           status-message))))
 
 (define camera
-  (let ((viewport (make-viewport (make-rect 0 0 640 480)
-                                 #:clear-color background)))
-    (orthographic-camera window-width window-height
-                         #:viewport viewport)))
+  (2d-camera #:area (make-rect 0 0 640 480) #:clear-color background))
 
 (define-signal 2048-scene
-  (signal-let ((model 2048-model))
-    (make-scene camera model)))
+  (signal-let ((view 2048-view))
+    (with-camera camera view)))
 
 ;;;
 ;;; Initialization