Update examples to use sprite batch.

2 files changed, 90 insertions, 100 deletions

diff --git a/examples/life.scm b/examples/life.scm
index 2d4e30a..763e5d4 100644
--- a/examples/life.scm
+++ b/examples/life.scm
@@ -33,6 +33,9 @@
              (sly render)
              (sly render camera)
              (sly render sprite)
+             (sly render sprite-batch)
+             (sly render texture)
+             (sly render tileset)
              (sly render color)
              (sly input mouse))
 
@@ -48,15 +51,13 @@
                (vlist-drop vlist (+ 1 index)))))
 
 ;; Pulled out of mines.scm
-
-(define (enumerate-map proc lst)
-  (define (iter k lst)
+(define (enumerate-each proc lst)
+  (let loop ((k 0) (lst lst))
     (match lst
-      (() '())
-      ((x . rest)
-       (cons (proc x k) (iter (1+ k) rest)))))
-
-  (iter 0 lst))
+      (() *unspecified*)
+      ((head . tail)
+       (proc head k)
+       (loop (1+ k) tail)))))
 
 ;;;
 ;;; Sly stuff starts here
@@ -67,17 +68,17 @@
 (define tile-size 32)
 (define window-res (vector2 448 480))
 
+(define tileset
+  (load-tileset "mines/images/tiles.png" 32 32))
+
 (define alive-texture
-  (load-texture "mines/images/tile-down.png"))
+  (tileset-ref tileset 12))
 
 (define empty-texture
-  (load-texture "mines/images/tile-up.png"))
+  (tileset-ref tileset 13))
 
-(define sprite-cell-alive
-  (make-sprite alive-texture #:anchor 'bottom-left))
-
-(define sprite-cell-empty
-  (make-sprite empty-texture #:anchor 'bottom-left))
+(define batch
+  (make-sprite-batch (expt 14 2)))
 
 ;;;
 ;;; State
@@ -289,27 +290,29 @@ If there is no neighbor on an edge, the board wraps around"
     (/ (* board-size tile-size) 2)
     (/ (* board-size tile-size) 2))))
 
+(define sprite-rect
+  (make-rect 0 0 32 32))
+
 ;; Model of the tile grid
 (define-signal tiles-view
   (signal-let ((board board)
                (board-size board-size))
-    (list->renderer
-     (enumerate-map
-      (lambda (row row-count)
-        (list->renderer
-         (enumerate-map
-          (lambda (tile-alive col-count)
-            (move (tile-pos row-count col-count
-                            board-size tile-size)
-                  (render-sprite
-                   (if tile-alive
-                       sprite-cell-alive
-                       sprite-cell-empty))))
-          (vlist->list row))))
-      ;; FIXME:
-      ;; This slows things down more than it should have to
-      ;; we should map natively on the vlist
-      (vlist->list board)))))
+    (lambda (gfx)
+      (with-sprite-batch batch gfx
+        (enumerate-each
+         (lambda (row y)
+           (enumerate-each
+            (lambda (alive? x)
+              (let ((rect (rect-move sprite-rect
+                                     (tile-pos y x board-size tile-size))))
+                (sprite-batch-add! batch
+                                   gfx
+                                   (if alive?
+                                       alive-texture
+                                       empty-texture)
+                                   rect)))
+            (vlist->list row)))
+         (vlist->list board))))))
 
 (define-signal camera
   (signal-let ((running? simulation-running?))
diff --git a/examples/mines/mines.scm b/examples/mines/mines.scm
index fd7256f..502d780 100644
--- a/examples/mines/mines.scm
+++ b/examples/mines/mines.scm
@@ -39,7 +39,9 @@
              (sly render color)
              (sly render font)
              (sly render sprite)
+             (sly render sprite-batch)
              (sly render texture)
+             (sly render tileset)
              (sly input keyboard)
              (sly input mouse))
 
@@ -52,14 +54,13 @@
 (define (list-replace lst k value)
   (append (take lst k) (cons value (drop lst (1+ k)))))
 
-(define (enumerate-map proc lst)
-  (define (iter k lst)
+(define (enumerate-each proc lst)
+  (let loop ((k 0) (lst lst))
     (match lst
-      (() '())
-      ((x . rest)
-       (cons (proc x k) (iter (1+ k) rest)))))
-
-  (iter 0 lst))
+      (() *unspecified*)
+      ((head . tail)
+       (proc head k)
+       (loop (1+ k) tail)))))
 
 (define (compact lst)
   (filter identity lst))
@@ -293,53 +294,40 @@
 
 (define font (load-default-font))
 
-(define sprites
+;; Minefield is 8x8, and there are 2 layers of tile graphics.
+(define batch (make-sprite-batch (* 8 8 2)))
+
+(define tileset (load-tileset "images/tiles.png" 32 32))
+
+(define tiles
   (map (match-lambda
-        ((key . config)
-         (let ((sprite (load-sprite (string-append "images/"
-                                                   (assoc-ref config 'name)
-                                                   ".png")
-                                    #:anchor (assoc-ref config 'anchor))))
-           (cons key sprite))))
-       '((1 .        ((name . "1-mine")
-                      (anchor . center)))
-         (2 .        ((name . "2-mines")
-                      (anchor . center)))
-         (3 .        ((name . "3-mines")
-                      (anchor . center)))
-         (4 .        ((name . "4-mines")
-                      (anchor . center)))
-         (5 .        ((name . "5-mines")
-                      (anchor . center)))
-         (6 .        ((name . "6-mines")
-                      (anchor . center)))
-         (7 .        ((name . "7-mines")
-                      (anchor . center)))
-         (8 .        ((name . "8-mines")
-                      (anchor . center)))
-         (mine .     ((name . "mine")
-                      (anchor . center)))
-         (exploded . ((name . "exploded")
-                      (anchor . center)))
-         (flag .     ((name . "flag")
-                      (anchor . center)))
-         (maybe .    ((name . "maybe")
-                      (anchor . center)))
-         (tile-up .  ((name . "tile-up")
-                      (anchor . bottom-left)))
-         (tile-down .((name . "tile-down")
-                      (anchor . bottom-left))))))
-
-(define (sprite-ref key)
-  (assoc-ref sprites key))
-
-(define (tile-base-sprite tile)
-  (sprite-ref
+         ((key . tile-index)
+          (cons key (tileset-ref tileset tile-index))))
+       '((1 . 10)
+         (2 . 11)
+         (3 . 4)
+         (4 . 5)
+         (5 . 6)
+         (6 . 7)
+         (7 . 0)
+         (8 . 1)
+         (mine . 14)
+         (exploded . 15)
+         (flag . 8)
+         (maybe . 9)
+         (tile-up . 13)
+         (tile-down . 12))))
+
+(define (tile-ref key)
+  (assoc-ref tiles key))
+
+(define (tile-base tile)
+  (tile-ref
    (if (tile-shown? tile)
        'tile-down
        'tile-up)))
 
-(define (tile-overlay-sprite tile)
+(define (tile-overlay tile)
   (and=> (cond
           ((tile-shown-mine? tile) 'exploded)
           ((tile-flagged-mine? tile) 'flag)
@@ -348,29 +336,28 @@
                 (tile-neighboring-mines? tile))
            (tile-mine-count tile))
           (else #f))
-         sprite-ref))
+         tile-ref))
 
-(define render-tile
-  (let ((offset (vector2 (/ tile-size 2) (/ tile-size 2))))
-    (lambda (tile)
-      (render-begin
-       (render-sprite (tile-base-sprite tile))
-       (let ((overlay (tile-overlay-sprite tile)))
-         (if overlay
-             (move offset (render-sprite overlay))
-             render-nothing))))))
+(define tile-rect (make-rect 0 0 32 32))
 
 (define-signal board-view
   (signal-let ((board board))
-    (define (render-column tile x)
-      (move (vector2 (* x tile-size) 0)
-            (render-tile tile)))
-
-    (define (render-row row y)
-      (move (vector2 0 (* y tile-size))
-            (list->renderer (enumerate-map render-column row))))
-
-    (list->renderer (enumerate-map render-row board))))
+    (lambda (gfx)
+      (with-sprite-batch batch gfx
+        (enumerate-each
+         (lambda (row y)
+           (enumerate-each
+            (lambda (tile x)
+              (let ((rect (rect-move tile-rect
+                                     (* x tile-size)
+                                     (* y tile-size)))
+                    (base-tex (tile-base tile))
+                    (overlay-tex (tile-overlay tile)))
+                (sprite-batch-add! batch gfx base-tex rect)
+                (when overlay-tex
+                  (sprite-batch-add! batch gfx overlay-tex rect))))
+            row))
+         board)))))
 
 (define (render-message message)
   (move (vector2 (/ (vx resolution) 2)