summaryrefslogtreecommitdiff
path: root/examples/2048
diff options
context:
space:
mode:
Diffstat (limited to 'examples/2048')
-rwxr-xr-xexamples/2048/2048.scm245
1 files changed, 152 insertions, 93 deletions
diff --git a/examples/2048/2048.scm b/examples/2048/2048.scm
index e9eb16d..8d2ecf9 100755
--- a/examples/2048/2048.scm
+++ b/examples/2048/2048.scm
@@ -254,25 +254,26 @@
(define-signal board
(signal-map 2048-board 2048-state))
-(define-signal score-saver
- (signal-tap (lambda (state)
- (when (board-lose? (2048-board state))
- (save-best-score state)))
- 2048-state))
+(add-signal-hook! 2048-state
+ (lambda (state)
+ (when (board-lose? (2048-board state))
+ (save-best-score state))))
+
+(define-signal same-score?
+ (signal-let ((current 2048-state)
+ (prev (signal-delay 1 2048-state)))
+ (= (2048-score prev)
+ (2048-score current))))
;;;
;;; Rendering
;;;
-(init-window)
-(enable-fonts)
+(define (maybe-play-sample sample)
+ (and sample (play-sample sample)))
(define background (rgb #xfaf8ef))
-(define tile-texture (load-texture "tile.png"))
-
-(define font (load-default-font 32))
-
(define text-color-1 (rgb #x776e65))
(define text-color-2 (rgb #xf9f6f2))
@@ -308,15 +309,12 @@
(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-label-cache
+(define (make-tile-label-cache font)
(map (lambda (n)
(cons n (make-label font (number->string n) #:anchor 'center)))
'(2 4 8 16 32 64 128 256 512 1024 2048)))
-(define (render-tile x y n)
+(define (render-tile tile-texture tile-sprite tile-label-cache x y n)
(let ((w (texture-width tile-texture))
(h (texture-height tile-texture))
(label (assoc-ref tile-label-cache n))
@@ -334,130 +332,191 @@
(define window-width 640)
(define window-height 480)
-(define board-width
- (* board-size (texture-width tile-texture)))
-(define board-height
- (* board-size (texture-height tile-texture)))
-(define center-pos
- (vector2 (/ (- window-width board-width) 2) 8))
(define (enumerate-board board)
(enumerate (map (cut enumerate <>) board)))
-(define (render-board board)
+(define (render-board board tile-texture tile-sprite tile-label-cache)
(list->renderer
(append-map
(match-lambda
((y (row ...))
(map (match-lambda
((x n)
- (render-tile x y n)))
+ (render-tile tile-texture tile-sprite tile-label-cache x y n)))
row)))
(enumerate-board board))))
-(define-signal tiles
- (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 (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
- ((board-lose? board) game-over)
- ((board-win? board) you-win)
- (else #f))))
- (if message
- (move (vector2 (/ board-width 2)
- (/ board-height 2))
- (render-begin message play-again))
- render-nothing)))
- board)))
-
-(define instruction-font (load-default-font 16))
-
(define instruction-text
"Use the arrow keys to join the numbers and get to the 2048 tile!")
-(define-signal instructions
- (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))
-
(define (score-label text score x)
(let* ((duration 15)
(position-tween (let* ((to (vector2 0 -32))
(from (v- to (vector2 0 -8))))
(tween vlerp ease-linear from to duration)))
(color-tween (tween color-lerp ease-linear
- transparent text-color-1 duration))
- (header (make-label score-header-font text #:anchor 'top-center)))
- (signal-let* ((score (signal-drop-repeats score))
+ transparent text-color-1 duration)))
+ (signal-let* ((score-font score-font)
+ (x x)
+ (header (render-label-maybe score-header-font
+ text
+ 'top-center))
+ (score (signal-drop-repeats score))
(timer (signal-drop (lambda (t) (> t duration))
0 (signal-since 1 score))))
- (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)))))))))
+ (if (and score-font header x)
+ (let ((score (make-label score-font (number->string score)
+ #:anchor 'center)))
+ (move (vector2 x (- window-height 28))
+ (render-begin
+ (with-color text-color-1 header)
+ (move (position-tween timer)
+ (with-color (color-tween timer)
+ (render-sprite score))))))
+ render-nothing))))
+
+(define camera
+ (2d-camera #:area (make-rect 0 0 640 480) #:clear-color background))
+
+(define* (render-label-maybe font message anchor)
+ (signal-map-maybe (lambda (font)
+ (render-label font message anchor))
+ font))
+
+(define-signal tile-texture
+ (on-start (load-texture "tile.png")))
+
+(define-signal board-width
+ (signal-map-maybe (lambda (tile-texture)
+ (* board-size (texture-width tile-texture)))
+ tile-texture))
+
+(define-signal board-height
+ (signal-map-maybe (lambda (tile-texture)
+ (* board-size (texture-height tile-texture)))
+ tile-texture))
+
+(define-signal center-pos
+ (signal-map-maybe (lambda (board-width)
+ (vector2 (/ (- window-width board-width) 2) 8))
+ board-width))
+
+(define-signal score-unchanged-sound
+ (on-start (load-sample "../sounds/hit.wav")))
+
+(define-signal score-changed-sound
+ (on-start (load-sample "../sounds/jump.wav")))
+
+(define-signal sound-effect
+ (signal-map-maybe (cut if <> <> <>)
+ same-score?
+ score-unchanged-sound
+ score-changed-sound))
+
+(define-signal font
+ (on-start (load-default-font 32)))
+
+(define-signal tile-sprite
+ (signal-map-maybe (cut make-sprite <> #:anchor (vector2 0 0))
+ tile-texture))
+
+(define-signal tile-label-cache
+ (signal-map-maybe make-tile-label-cache font))
+
+(define-signal tiles
+ (signal-map-maybe render-board
+ board
+ tile-texture
+ tile-sprite
+ tile-label-cache))
+
+(define-signal instruction-font
+ (on-start (load-default-font 16)))
+
+(define-signal play-again-font
+ (on-start (load-default-font 16)))
+
+(define-signal score-header-font
+ (on-start (load-default-font 14)))
+
+(define-signal score-font
+ (on-start (load-default-font 22)))
+
+(define-signal status-message
+ (signal-let ((board board)
+ (play-again (render-label-maybe play-again-font
+ "Press N to play again"
+ 'top-center))
+ (game-over (render-label-maybe font "GAME OVER" 'bottom-center))
+ (you-win (render-label-maybe font "YOU WIN!" 'bottom-center))
+ (board-width board-width)
+ (board-height board-height))
+ (let ((message (cond
+ ((board-lose? board) game-over)
+ ((board-win? board) you-win)
+ (else #f))))
+ (if message
+ (move (vector2 (/ board-width 2)
+ (/ board-height 2))
+ (render-begin message play-again))
+ render-nothing))))
(define-signal score
- (score-label "SCORE" (signal-map 2048-score 2048-state) (/ board-width 4)))
+ (score-label "SCORE"
+ (signal-map 2048-score 2048-state)
+ (signal-map-maybe (cut / <> 4) board-width)))
(define-signal best-score
- (score-label "BEST" (signal-map 2048-best-score 2048-state)
- (- board-width (/ board-width 4))))
+ (score-label "BEST"
+ (signal-map 2048-best-score 2048-state)
+ (signal-map-maybe (lambda (width)
+ (- width (/ width 4)))
+ board-width)))
-(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-signal instructions
+ (signal-map-maybe (lambda (board-width center-pos instruction-font)
+ (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)))))
+ board-width
+ center-pos
+ instruction-font))
-(define camera
- (2d-camera #:area (make-rect 0 0 640 480) #:clear-color background))
+(define-signal 2048-view
+ (signal-map-maybe (lambda (center . renderers)
+ (move center (list->renderer renderers)))
+ center-pos
+ instructions
+ tiles
+ score
+ best-score
+ status-message))
(define-signal 2048-scene
(signal-let ((view 2048-view))
- (with-camera camera view)))
+ (with-camera camera (or view render-nothing))))
;;;
;;; Initialization
;;;
-(start-sly-repl)
+;; (start-sly-repl)
+(add-signal-hook! sound-effect maybe-play-sample)
(add-hook! window-close-hook stop-game-loop)
(with-window (make-window #:title "2048")
+ (enable-fonts)
+ (enable-audio)
(run-game-loop 2048-scene))
;;; Local Variables: