From 6bc296631b7cc6988112489030ad7a8c18648e88 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sat, 26 Sep 2020 16:48:57 -0400
Subject: Commit this old stuff that was hanging around.

---
 examples/tetra/tetra.scm | 695 ++++++++++++++++++++++++++++++++++-------------
 guix.scm                 |   8 +-
 starling/node-2d.scm     |   2 +-
 3 files changed, 513 insertions(+), 192 deletions(-)

diff --git a/examples/tetra/tetra.scm b/examples/tetra/tetra.scm
index 2093c2f..5bb2ac5 100644
--- a/examples/tetra/tetra.scm
+++ b/examples/tetra/tetra.scm
@@ -20,36 +20,76 @@
 ;;
 ;;; Code:
 
-(use-modules (chickadee math matrix)
+(use-modules (chickadee math easings)
+             (chickadee math matrix)
              (chickadee math rect)
              (chickadee math vector)
              (chickadee render color)
+             (chickadee render font)
+             (chickadee render particles)
              (chickadee render texture)
              (chickadee render sprite)
              (chickadee scripting)
              (ice-9 match)
              (oop goops)
              (srfi srfi-1)
+             (srfi srfi-43)
              (starling asset)
              (starling kernel)
              (starling node)
              (starling node-2d)
              (starling scene))
 
+
+;;;
+;;; Constants
+;;;
+
+(define window-width 600)
+(define window-height 800)
+(define board-width 10)
+(define board-height 20)
+(define tile-width 32)
+(define tile-height 32)
+
+
+;;;
+;;; Assets
+;;;
+
 (define (load-block-atlas file-name)
   (let ((texture (load-image file-name)))
-    (split-texture texture 32 32)))
+    (split-texture texture tile-width tile-height)))
 
 (define-asset atlas (load-block-atlas "images/blocks.png"))
+(define-asset star (load-image "images/star.png"))
+(define-asset click-font (load-font "fonts/click.xml"))
 
-(define shapes
-  '((i (0 0) (0 1) (0 2) (0 3))
-    (o (0 0) (0 1) (1 0) (1 1))
-    (t (0 0) (0 1) (0 2) (1 1))
-    (j (1 0) (1 1) (1 2) (0 0))
-    (l (0 0) (0 1) (0 2) (1 0))
-    (s (1 0) (1 1) (0 2) (0 1))
-    (z (0 0) (0 1) (1 2) (1 1))))
+
+;;;
+;;; Convenience Procedures/Macros
+;;;
+
+(define (transparent color)
+  "Make a fully transparent version of COLOR."
+  (make-color (color-r color)
+              (color-g color)
+              (color-b color)
+              0.0))
+
+(define (centered width)
+  "Return the X coordinate needed to center an object occupying WIDTH
+pixels in the right-hand side UI area."
+  ;; We're not centering it with the full screen, just the portion of
+  ;; the screen available to the right of the game board.
+  (let ((board-width-pixels (+ (* board-width tile-width) (* 16.0 2.0))))
+    (+ board-width-pixels
+       (/ (- window-width board-width-pixels width) 2.0))))
+
+(define (centered-text text)
+  "Return the X coordinate needed to center the string TEXT in the UI
+area next to the board."
+  (centered (* (font-line-width (asset-ref click-font) text) 2.0)))
 
 (define-syntax for-each-permutation
   (syntax-rules ()
@@ -83,47 +123,102 @@
     ((_ ((var start end) rest ...) body ...)
      (map-permutation ((var start end 1) rest ...) body ...))))
 
-(define rects
-  (map-permutation ((x 0 4) (y 0 4))
-                   `((,x ,y) . ,(make-rect (* x 32.0) (* y 32.0) 32.0 32.0))))
+
+;;;
+;;; Tiles
+;;;
 
+;; A single block on a tetris board.
 (define-class <tile> ()
   (type #:accessor type #:init-form #f)
-  (position #:accessor position #:init-keyword #:position))
-
-(define (type->atlas-index type)
-  (match type
-    ('yellow 0)
-    ('blue 1)
-    ('green 2)
-    ('purple 3)
-    ('red 4)
-    ('gray 5)
-    (_ #f)))
+  (area #:getter area #:init-keyword #:area))
 
 (define (for-each-coord proc)
-  (for-each-permutation ((x 0 10) (y 0 20)) (proc x y)))
-
-(define (make-tiles)
-  (let ((tiles (make-array #f 10 20)))
-    (for-each-coord
-     (lambda (x y)
-       (array-set! tiles
-                   (make <tile>
-                     #:position (vec2 (* x 32.0)
-                                      (* y 32.0)))
-                   x y)))
-    tiles))
+  (for-each-permutation ((x 0 board-width) (y 0 board-height)) (proc x y)))
+
+
+;;;
+;;; Pieces
+;;;
 
+;; Moveable tetromino.
 (define-class <piece> (<node-2d>)
   (x #:accessor x #:init-keyword #:x #:init-form 0)
   (y #:accessor y #:init-keyword #:y #:init-form 0)
   (type #:accessor type #:init-keyword #:type)
-  (shape #:accessor shape #:init-keyword #:shape)
-  (batch #:accessor batch #:init-keyword #:batch))
+  (shape #:accessor shape #:init-keyword #:shape))
+
+(define shapes
+  '((i (0 1) (1 1) (2 1) (3 1))
+    (j (0 0) (1 0) (2 0) (0 1))
+    (l (0 0) (1 0) (2 0) (2 1))
+    (o (0 0) (0 1) (1 0) (1 1))
+    (s (0 0) (1 0) (1 1) (2 1))
+    (t (0 0) (1 0) (2 0) (1 1))
+    (z (0 1) (1 1) (1 0) (2 0))))
+
+(define colors
+  '((i . yellow)
+    (j . blue)
+    (l . red)
+    (o . purple)
+    (s . green)
+    (t . gray)
+    (z . red)))
+
+(define (type->atlas-index type)
+  (match type
+    ('yellow 0)
+    ('blue 0)
+    ('green 0)
+    ('purple 0)
+    ('red 0)
+    ('gray 0)
+    (_ #f)))
+
+;; A convenient cache of all the possible sprite locations with a
+;; tetrnomino to avoid recalculating them all the time.
+(define rects
+  (map-permutation ((x 0 4) (y 0 4))
+                   `((,x ,y) . ,(make-rect (* x tile-width)
+                                           (* y tile-height)
+                                           tile-width
+                                           tile-height))))
+
+(define-method (piece-width (piece <piece>))
+  (let loop ((shape (shape piece))
+             (minx #f)
+             (maxx #f))
+    (match shape
+      (() (+ (- maxx minx) 1))
+      (((x _) . rest)
+       (loop rest
+             (if minx (min minx x) x)
+             (if maxx (max maxx x) x))))))
+
+(define-method (piece-height (piece <piece>))
+  (let loop ((shape (shape piece))
+             (miny #f)
+             (maxy #f))
+    (match shape
+      (() (+ (- maxy miny) 1))
+      (((_ y) . rest)
+       (loop rest
+             (if miny (min miny y) y)
+             (if maxy (max maxy y) y))))))
+
+(define-method (piece-y-offset (piece <piece>))
+  (fold (lambda (p memo)
+          (match p
+            ((_ y)
+             (if memo
+                 (min y memo)
+                 y))))
+        #f
+        (shape piece)))
 
 (define-method (max-x (piece <piece>))
-  (- 9
+  (- board-width 1
      (fold (lambda (p memo)
              (match p
                ((x _)
@@ -131,80 +226,132 @@
            0
            (shape piece))))
 
-(define-method (piece-above-board? (piece <piece>))
-  (let ((py (y piece)))
-    (any (match-lambda
-           ((_ y)
-            (>= (+ y py) 20)))
-         (shape piece))))
-
-(define-method (move-piece (piece <piece>) new-x new-y)
+(define-method (move-piece (piece <piece>) new-x new-y init?)
   (let ((old-x (x piece))
-        (old-y (y piece)))
+        (old-y (y piece))
+        (px (* new-x tile-width))
+        (py (* new-y tile-height)))
     (set! (x piece) new-x)
     (set! (y piece) new-y)
-    (with-agenda (agenda piece)
-                 (script
-                  (move-to piece (* old-x 32.0) (* old-y 32.0))
-                  (move-to piece (* new-x 32.0) (* new-y 32.0) 8)))))
+    (if init?
+        (teleport piece px py)
+        (run-script piece
+          (move-to piece px py 8)))))
 
-(define-method (rotate-piece (piece <piece>))
-  (let* ((max-y (fold (lambda (pos memo)
-                        (match pos
-                          ((x y)
-                           (max y memo))))
-                      0
-                      (shape piece)))
-         (new-shape (map (match-lambda
-                           ((x y)
-                            (list (- max-y y) x)))
-                         (shape piece)))
-         (px (x piece))
-         (py (y piece)))
-    (when (every (match-lambda
-                   ((x y)
-                    (let ((sx (+ x px))
-                          (sy (+ y py)))
-                      (and (>= sx 0)
-                           (< sx 10)
-                           (>= sy 0)))))
-                 new-shape)
-      (set! (shape piece) new-shape))))
+(define-method (move-piece (piece <piece>) new-x new-y)
+  (move-piece piece new-x new-y #f))
 
 (define-method (render (piece <piece>) alpha)
-  (let ((batch (batch piece)))
-    (for-each (match-lambda
-                (pos
-                 (sprite-batch-add* batch
-                                    (assoc-ref rects pos)
-                                    (world-matrix piece)
-                                    #:texture-region
-                                    (texture-atlas-ref (asset-ref atlas)
-                                                       (type->atlas-index
-                                                        (type piece))))))
-              (shape piece))))
+  (for-each (match-lambda
+              (pos
+               (draw-sprite* (texture-atlas-ref (asset-ref atlas)
+                                                (type->atlas-index
+                                                 (type piece)))
+                             (assoc-ref rects pos)
+                             (world-matrix piece))))
+            (shape piece)))
+
+(define (make-random-piece)
+  (let ((type (list-ref '(i o t j l s z) (random 7))))
+    (make <piece>
+      #:type (assq-ref colors type)
+      #:shape (assq-ref shapes type)
+      #:rank 999)))
+
+
+;;;
+;;; Rows
+;;;
 
-(define (make-random-piece batch)
-  (let* ((shape (assq-ref shapes (list-ref '(i o t j l s z) (random 7))))
-         (piece (make <piece>
-                  #:type (list-ref '(yellow blue red purple green gray)
-                                   (random 6))
-                  #:shape shape
-                  #:batch batch
-                  #:x 4
-                  #:y 20)))
-    (move-to piece (* 4.0 32.0) (* 20.0 32.0))
-    piece))
+;; A horizontal line of tiles on the tetris board.
+(define-class <row> (<node-2d>)
+  (y #:accessor y #:init-keyword #:y)
+  (tiles #:accessor tiles #:init-keyword #:tiles))
 
+(define-method (on-boot (row <row>))
+  (teleport row 0.0 (* (y row) tile-height)))
+
+(define-method (render (row <row>) alpha)
+  (let ((tiles (tiles row))
+        (batch (batch (parent row)))
+        (atlas (asset-ref atlas)))
+    (let loop ((x 0))
+      (when (< x board-width)
+        (let* ((tile (vector-ref tiles x))
+               (i (type->atlas-index (type tile))))
+          (when i
+            (sprite-batch-add* batch
+                               (area tile)
+                               (world-matrix row)
+                               #:texture-region (texture-atlas-ref atlas i))))
+        (loop (+ x 1))))))
+
+(define-method (on-clear (row <row>) particles)
+  (run-script row
+    (scale-to row 0.0 0.0 10)
+    (detach row))
+  ;; Emit some particles! woooooo
+  (let* ((pos (position row))
+         (x (vec2-y pos))
+         (y (vec2-y pos)))
+    (vector-for-each (lambda (i tile)
+                       (let* ((area (make-rect (* i tile-width)
+                                               y
+                                               tile-width
+                                               tile-height))
+                              (emitter (make-particle-emitter area 2 10)))
+                         (add-particle-emitter particles emitter)))
+                     (tiles row))))
+
+(define (make-row y)
+  (define (make-tile x)
+    (make <tile>
+      #:area (make-rect (* x tile-width)
+                        0.0
+                        tile-width
+                        tile-height)))
+  (let ((row (make-vector board-width)))
+    (vector-for-each (lambda (x e)
+                       (vector-set! row x (make-tile x)))
+                     row)
+    (make <row> #:y y #:tiles row)))
+
+
+;;;
+;;; Boards
+;;;
+
+;; A collection of rows forming the complete tetris game board.
 (define-class <board> (<node-2d>)
   (batch #:accessor batch #:init-keyword #:batch)
-  (tiles #:getter tiles #:init-thunk make-tiles))
+  (rows #:accessor rows #:init-form (make-vector board-height #f)))
+
+(define-method (on-boot (board <board>))
+  (set! (batch board) (make-sprite-batch #f))
+  (attach-to board
+             (make <filled-rect>
+               #:name 'background
+               #:region (make-rect 0.0 0.0 320.0 640.0)
+               #:color tango-aluminium-6)
+             (make <sprite-batch>
+               #:name 'batch
+               #:batch (batch board))
+             (make <particles>
+               #:name 'particles
+               #:particles (make-particles 2000
+                                           #:texture (asset-ref star)
+                                           #:start-color tango-butter
+                                           #:end-color (transparent tango-butter)
+                                           #:lifetime 10))))
+
+(define-method (get-tile (board <board>) x y)
+  (vector-ref (tiles (vector-ref (rows board) y)) x))
 
 (define-method (board-ref (board <board>) x y)
-  (type (array-ref (tiles board) x y)))
+  (type (get-tile board x y)))
 
 (define-method (board-set! (board <board>) x y new-type)
-  (set! (type (array-ref (tiles board) x y)) new-type))
+  (set! (type (get-tile board x y)) new-type))
 
 (define-method (add-to-board (board <board>) (piece <piece>))
   (let ((type (type piece))
@@ -214,112 +361,273 @@
                 ((sx sy)
                  (let ((bx (+ x sx))
                        (by (+ y sy)))
-                   (when (< by 20)
+                   (when (< by board-height)
                      (board-set! board bx by type)))))
               (shape piece))))
 
+(define-method (overlaps-board? (piece <piece>) (board <board>))
+  (let ((px (x piece))
+         (py (y piece)))
+    (any (match-lambda
+           ((x y)
+            (board-ref board (+ x px) (+ y py))))
+         (shape piece))))
+
+(define-method (out-of-bounds? (piece <piece>))
+  (let ((px (x piece))
+        (py (y piece)))
+    (any (match-lambda
+           ((x y)
+            (let ((sx (+ x px))
+                  (sy (+ y py)))
+              (or (< sx 0)
+                  (>= sx board-width)
+                  (< sy 0)
+                  (>= sy board-height)))))
+         (shape piece))))
+
+(define-method (rotate-piece (piece <piece>) (board <board>))
+  (let* ((max-y (fold (lambda (pos memo)
+                        (match pos
+                          ((x y)
+                           (max y memo))))
+                      0
+                      (shape piece)))
+         (old-shape (shape piece))
+         (new-shape (map (match-lambda
+                           ((x y)
+                            (list (- max-y y) x)))
+                         old-shape)))
+    (set! (shape piece) new-shape)
+    (when (or (out-of-bounds? piece)
+              (overlaps-board? piece board))
+      (set! (shape piece) old-shape))))
+
 (define-method (filled-rows (board <board>))
   (define (row-full? y)
     (let loop ((x 0))
       (cond
-       ((= x 10)
+       ((= x board-width)
         #t)
        ((board-ref board x y)
         (loop (+ x 1)))
        (else
         #f))))
-  (let loop ((y 0))
-    (if (= y 20)
+  (let loop ((y 19))
+    (if (< y 0)
         '()
         (if (row-full? y)
-            (cons y (loop (+ y 1)))
-            (loop (+ y 1))))))
+            (cons y (loop (- y 1)))
+            (loop (- y 1))))))
 
 (define-method (remove-filled-rows (board <board>))
-  (let loop ((rows (filled-rows board)))
-    (match rows
-      (() #t)
-      ((y . rest)
-       (let y-loop ((y (+ y 1)))
-         (when (< y 20)
-           (let x-loop ((x 0))
-             (when (< x 10)
-               (board-set! board x (- y 1) (board-ref board x y))
-               (x-loop (+ x 1))))
-           (y-loop (+ y 1))))
-       (loop rest)))))
-
-(define-method (board-clear! (board <board>))
-  (for-each-coord
-   (lambda (x y)
-     (set! (type (array-ref (tiles board) x y)) #f))))
+  (let* ((rows (rows board))
+         (rows-to-remove (filled-rows board))
+         (anim-duration 10))
+    (let loop ((dead-rows rows-to-remove)
+               (count 0))
+      (match dead-rows
+        (() (length rows-to-remove))
+        ((dead-y . rest)
+         ;; Remove the cleared row.
+         (let ((dead-row (vector-ref rows dead-y))
+               (particles (particles (& board particles))))
+           (on-clear dead-row particles))
+         ;; Move everything above the cleared row down.
+         (let y-loop ((old-y (+ dead-y 1)))
+           (when (< old-y board-height)
+             (let ((row (vector-ref rows old-y))
+                   (new-y (- old-y 1)))
+               (vector-set! rows new-y row)
+               (set! (y row) new-y)
+               ;; Smoothly animate the drop down.
+               (run-script row
+                 (unless (zero? count)
+                   (sleep (* count anim-duration)))
+                 (move-to row 0.0 (* new-y tile-height) anim-duration
+                          (if (zero? count) smoothstep linear))))
+             (y-loop (+ old-y 1))))
+         ;; Add a new blank row to the top.
+         (let ((new-row (make-row (- board-height 1))))
+           (attach-to board new-row)
+           (vector-set! rows (- board-height 1) new-row))
+         (loop rest (+ count 1)))))))
+
+(define-method (clear-board (board <board>))
+  (let ((rows (rows board)))
+    (when rows
+      (let loop ((y 0))
+        (when (< y board-height)
+          (let ((old-row (vector-ref rows y)))
+            (and old-row (detach old-row)))
+          (let ((new-row (make-row y)))
+            (vector-set! rows y new-row)
+            (attach-to board new-row))
+          (loop (+ y 1)))))))
 
 (define-method (touching-next-row? (piece <piece>) (board <board>))
   (any (match-lambda
          ((sx sy)
           (let ((bx (+ (x piece) sx))
                 (by (- (+ (y piece) sy) 1)))
-            (and (< by 20)
-                 (board-ref board bx by)))))
+            (or (= by -1)
+                (and (< by board-height)
+                        (board-ref board bx by))))))
        (shape piece)))
 
-(define-method (render (board <board>) alpha)
-  (let ((tiles (tiles board))
-        (batch (batch board))
-        (atlas (asset-ref atlas)))
-    (for-each-coord
-     (lambda (x y)
-       (let* ((tile (array-ref tiles x y))
-              (i (type->atlas-index (type tile))))
-         (when i
-           (sprite-batch-add! batch (position tile)
-                              #:texture-region (texture-atlas-ref atlas i))))))))
+(define-method (render-tree (board <board>) alpha)
+  (set-sprite-batch-texture! (batch board)
+                             (texture-atlas-texture (asset-ref atlas)))
+  (next-method))
+
+
+;;;
+;;; Tetra
+;;;
+
+;; The main game scene.
 
 (define-class <tetra> (<scene-2d>)
   (state #:accessor state #:init-form 'play)
-  (batch #:getter batch #:init-form (make-sprite-batch #f))
-  (board #:accessor board #:init-form (make <board>))
+  (board #:accessor board)
   (piece #:accessor piece #:init-form #f)
+  (next-piece #:accessor next-piece #:init-form #f)
   (timer #:accessor timer #:init-form 0)
-  (down-interval #:accessor down-interval #:init-form 30))
+  (down-interval #:accessor down-interval #:init-form 30)
+  (score #:accessor score #:init-form -1))
+
+(define-method (game-over (tetra <tetra>))
+  (set! (state tetra) 'game-over)
+  (let* ((message "GAME OVER")
+         (instructions "press ENTER to play again")
+         (font (asset-ref click-font))
+         (message-width (* (font-line-width font message) 2.0))
+         (instructions-width (* (font-line-width font instructions) 2.0))
+         (line-height (* (font-line-height font) 2.0))
+         (padding 16.0)
+         (border 2.0)
+         (container-width (+ (max message-width instructions-width) (* padding 2.0)))
+         (container-height (+ (* line-height 2) (* padding 3.0)))
+         (container (make <node-2d>
+                      #:name 'game-over-container
+                      #:rank 9999
+                      #:position (vec2 (- (+ (/ (* board-width tile-width) 2.0) 16.0)
+                                          (/ container-width 2.0))
+                                       (/ (- window-height container-height) 2.0)))))
+    (attach-to container
+               (make <filled-rect>
+                 #:name 'background
+                 #:region (make-rect 0.0 0.0 container-width container-height)
+                 #:color tango-aluminium-3)
+               (make <filled-rect>
+                 #:name 'background
+                 #:region (make-rect border
+                                     border
+                                     (- container-width (* border 2.0))
+                                     (- container-height (* border 2.0)))
+                 #:color tango-aluminium-6)
+               (make <label>
+                 #:name 'message
+                 #:text message
+                 #:font click-font
+                 #:scale (vec2 2.0 2.0)
+                 #:position (vec2 (/ (- container-width message-width) 2.0)
+                                  (+ line-height (* padding 2.0))))
+               (make <label>
+                 #:name 'instructions
+                 #:text instructions
+                 #:font click-font
+                 #:scale (vec2 2.0 2.0)
+                 #:position (vec2 (/ (- container-width instructions-width) 2.0)
+                                  padding)))
+    (attach-to tetra container)))
+
+(define-method (add-next-piece (tetra <tetra>))
+  (let* ((new-piece (make-random-piece))
+         (w (* (piece-width new-piece) tile-width))
+         (h (* (piece-height new-piece) tile-height))
+         (y-offset (+ (/ (- (* tile-height 3.0) h) 2.0)
+                      (* (piece-y-offset new-piece) tile-height)))
+         (x (centered w))
+         (y (- 630.0 16.0 h y-offset)))
+    (teleport new-piece x y)
+    (set! (next-piece tetra) new-piece)
+    (attach-to tetra new-piece)))
 
 (define-method (add-new-piece (tetra <tetra>))
-  (let ((new-piece (make-random-piece (batch tetra))))
-    (when (piece tetra)
-      (detach (piece tetra)))
-    (set! (piece tetra) new-piece)
-    (set! (timer tetra) 0)
-    (attach-to tetra new-piece)))
+  (let ((new-piece (next-piece tetra)))
+    (detach new-piece)
+    (attach-to (& tetra board-container) new-piece)
+    (move-piece new-piece 4 18 #t)
+    (if (overlaps-board? new-piece (board tetra))
+        (begin
+          (detach new-piece)
+          (game-over tetra))
+        (begin
+          (when (piece tetra)
+            (detach (piece tetra)))
+          (set! (piece tetra) new-piece)
+          (set! (timer tetra) 0)
+          (add-next-piece tetra)))))
 
 (define-method (on-boot (tetra <tetra>))
-  (set! (batch (board tetra)) (batch tetra))
+  (set! (board tetra) (make <board>))
   (attach-to tetra
              (make <filled-rect>
-               #:name 'background
-               #:region (make-rect 0.0 0.0 320.0 640.0)
-               #:color tango-light-sky-blue)
-             (board tetra)
-             (make <sprite-batch>
-               #:batch (batch tetra)
-               #:rank 9999))
-  (add-new-piece tetra))
+               #:region (make-rect 0.0 0.0 window-width window-height)
+               #:color tango-aluminium-5)
+             (let ((text "NEXT"))
+               (make <label>
+                 #:name 'next-label
+                 #:text text
+                 #:font click-font
+                 #:position (vec2 (centered-text text) 630.0)
+                 #:scale (vec2 2.0 2.0)))
+             (make <filled-rect>
+               #:name 'next-background
+               #:color tango-aluminium-6
+               #:region (let* ((w (* tile-width 5.0))
+                               (h (* tile-height 3.0))
+                               (x (centered w))
+                               (y (- 630.0 h 16.0)))
+                          (make-rect x y w h)))
+             (let ((text "HI CHRIS"))
+               (make <label>
+                 #:name 'score-label
+                 #:text text
+                 #:font click-font
+                 #:position (vec2 (centered-text text) 420.0)
+                 #:scale (vec2 2.0 2.0)))
+             (make <label>
+               #:name 'score-counter
+               #:font click-font
+               #:scale (vec2 2.0 2.0))
+             (make <node-2d>
+               #:name 'board-container
+               #:position (vec2 16.0
+                                (/ (- window-height
+                                      (* board-height tile-height))
+                                   2.0))))
+  (attach-to (& tetra board-container)
+             (board tetra))
+  (reset-game tetra))
 
 (define-method (move-piece (tetra <tetra>) dx dy)
   (let* ((p (piece tetra))
          (b (board tetra))
          (new-x (min (max (+ (x p) dx) 0)
                      (max-x p)))
-         (new-y (max (+ (y p) dy) 0)))
+         (new-y (+ (y p) dy)))
     (define (touch?)
       (any (match-lambda
              ((sx sy)
               (let ((bx (+ new-x sx))
                     (by (+ new-y sy)))
-                (and (>= bx 0)
-                     (< bx 10)
-                     (>= by 0)
-                     (< by 20)
-                     (board-ref b bx by)))))
+                (or (< bx 0)
+                    (>= bx board-width)
+                    (< by 0)
+                    (>= by board-height)
+                    (board-ref b bx by)))))
            (shape p)))
     (when (and p (not (touch?)))
       (move-piece p new-x new-y))))
@@ -327,16 +635,32 @@
 (define-method (rotate-piece (tetra <tetra>))
   (let ((p (piece tetra)))
     (when p
-      (rotate-piece p))))
+      (rotate-piece p (board tetra)))))
+
+(define-method (change-score (tetra <tetra>) new-score)
+  (unless (= new-score (score tetra))
+    (let ((score-text (number->string new-score))
+          (label (& tetra score-counter)))
+      (set! (score tetra) new-score)
+      (set! (text label) score-text)
+      (teleport label (centered-text score-text) 380.0))))
 
 (define-method (reset-game (tetra <tetra>))
   (set! (state tetra) 'play)
   (set! (timer tetra) 0)
-  (board-clear! (board tetra))
+  (when (piece tetra)
+    (detach (piece tetra)))
+  (when (next-piece tetra)
+    (detach (next-piece tetra)))
+  (set! (piece tetra) #f)
+  (set! (next-piece tetra) #f)
+  (clear-board (board tetra))
+  (add-next-piece tetra)
   (add-new-piece tetra)
-  (let ((game-over-text (& tetra game-over-text)))
-    (when game-over-text
-      (detach game-over-text))))
+  (change-score tetra 0)
+  (let ((game-over-container (& tetra game-over-container)))
+    (when game-over-container
+      (detach game-over-container))))
 
 (define-method (on-key-press (tetra <tetra>) key scancode modifiers repeat?)
   (match (state tetra)
@@ -360,32 +684,29 @@
     (when (= (timer tetra) (down-interval tetra))
       (let ((p (piece tetra))
             (b (board tetra)))
-        (when (or (zero? (y p))
-                  (touching-next-row? p b))
-          (if (piece-above-board? p)
-              (begin
-                (set! (state tetra) 'game-over)
-                (attach-to tetra
-                           (make <label>
-                             #:name 'game-over-text
-                             #:text "*** GAME OVER ***\n\n\nPress ENTER to play again"
-                             #:position (vec2 340.0 620.0))))
-              (begin
-                (add-to-board b p)
-                (remove-filled-rows b)
-                (add-new-piece tetra))))
-        (move-piece tetra 0 -1)
+        (if (touching-next-row? p b)
+            (begin
+              (add-to-board b p)
+              (change-score tetra (+ (score tetra)
+                                     ;; Calculate score based on how
+                                     ;; many rows were cleared by
+                                     ;; placing the tetromino.
+                                     (match (remove-filled-rows b)
+                                       (0 0)
+                                       (1 40)
+                                       (2 100)
+                                       (3 300)
+                                       (4 1200))))
+              (add-new-piece tetra))
+            (move-piece tetra 0 -1))
         (set! (timer tetra) 0)))))
 
-(define-method (render-tree (tetra <tetra>) alpha)
-  (set-sprite-batch-texture! (batch tetra)
-                             (texture-atlas-texture (asset-ref atlas)))
-  (next-method))
-
+;; Seed the random number generator.
+(set! *random-state* (random-state-from-platform))
 (boot-kernel (make <kernel>
                #:window-config (make <window-config>
-                                 #:title "tetris clone"
-                                 #:width 600
-                                 #:height 800))
+                                 #:title "tetra"
+                                 #:width window-width
+                                 #:height window-height))
              (lambda ()
                (make <tetra>)))
diff --git a/guix.scm b/guix.scm
index d9e0b33..c1048a7 100644
--- a/guix.scm
+++ b/guix.scm
@@ -84,7 +84,7 @@
                (invoke "autoreconf" "-vfi")))))))))
 
 (define guile-sdl2
-  (let ((commit "d0f9c26dce6e23533c23e401f604d712b43d4420"))
+  (let ((commit "1c6a6250d2c1e6bfaca15058225f66ce9187ecaf"))
     (package
       (name "guile-sdl2")
       (version (string-append "0.3.1-1." (string-take commit 7)))
@@ -95,7 +95,7 @@
                       (commit commit)))
                 (sha256
                  (base32
-                  "183r50bsf317f4iclsdw4ag83s915nymvadh3izw04iv7fm8xbwj"))))
+                  "00lx6hw6jip0xdn7iapccswdh8wb2d69rikapj4laqlrybhjhp29"))))
       (build-system gnu-build-system)
       (arguments
        '(#:configure-flags
@@ -137,7 +137,7 @@ SDL2 C shared library via the foreign function interface.")
       (license lgpl3+))))
 
 (define chickadee
-  (let ((commit "3503ad80dc8f1233a4502540d22196f59b6b93ec"))
+  (let ((commit "ecc4cc242580610f21f5a4d44a3bf44a09dca81e"))
     (package
      (name "chickadee")
      (version "0.4.0")
@@ -148,7 +148,7 @@ SDL2 C shared library via the foreign function interface.")
                     (commit commit)))
               (sha256
                (base32
-                "003rp2qm6d2xvb78np68g774kwq5w7sdn4kk6ax5drhaai27aljk"))))
+                "03z07iqj4fvbf1fmxpfnxahxyn2jq2grxajnfnjjhl0ya8h6jdc7"))))
      (build-system gnu-build-system)
      (arguments
       '(#:make-flags '("GUILE_AUTO_COMPILE=0")
diff --git a/starling/node-2d.scm b/starling/node-2d.scm
index 35739ed..39a1bc2 100644
--- a/starling/node-2d.scm
+++ b/starling/node-2d.scm
@@ -502,7 +502,7 @@
 ;;;
 
 (define-class <sprite> (<base-sprite>)
-  (texture #:accessor texture #:init-keyword #:texture)
+  (texture #:getter texture #:init-keyword #:texture)
   (texcoords #:init-keyword #:texcoords #:init-form #f)
   (source-rect #:init-keyword #:source-rect #:init-form #f))
 
-- 
cgit v1.2.3