From 4b1370fc286db564e32a8e2e890061bc3ed413ac Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 10 Feb 2016 22:00:02 -0500
Subject: examples: Update everything to use deferred GL resource loading.

---
 examples/2048/2048.scm | 245 ++++++++++++++++++++++++++++++-------------------
 1 file changed, 152 insertions(+), 93 deletions(-)

(limited to 'examples/2048')

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:
-- 
cgit v1.2.3