summaryrefslogtreecommitdiff
path: root/examples/2048/2048.scm
diff options
context:
space:
mode:
Diffstat (limited to 'examples/2048/2048.scm')
-rwxr-xr-xexamples/2048/2048.scm140
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