diff options
Diffstat (limited to 'examples/2048/2048.scm')
| -rwxr-xr-x | examples/2048/2048.scm | 140 |
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 |