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