diff options
| -rw-r--r-- | examples/life.scm | 67 | ||||
| -rw-r--r-- | examples/mines/mines.scm | 123 |
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) |