Add tetris example.

1 files changed, 379 insertions, 0 deletions

diff --git a/examples/tetra/tetra.scm b/examples/tetra/tetra.scm
new file mode 100644
index 0000000..be51e63
--- /dev/null
+++ b/examples/tetra/tetra.scm
@@ -0,0 +1,379 @@
+;;; Starling Game Engine
+;;; Copyright © 2019 David Thompson <davet@gnu.org>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Starling.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Tetris clone.
+;;
+;;; Code:
+
+(use-modules (chickadee math matrix)
+             (chickadee math rect)
+             (chickadee math vector)
+             (chickadee render color)
+             (chickadee render texture)
+             (chickadee render sprite)
+             (chickadee scripting)
+             (ice-9 match)
+             (oop goops)
+             (srfi srfi-1)
+             (starling asset)
+             (starling kernel)
+             (starling node)
+             (starling node-2d)
+             (starling scene))
+
+(define (load-block-atlas file-name)
+  (let ((texture (load-image file-name)))
+    (split-texture texture 32 32)))
+
+(define-asset atlas (load-block-atlas "images/blocks.png"))
+
+(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))))
+
+(define rects
+  `(((0 0) . ,(rect 0.0 0.0 32.0 32.0))
+    ((0 1) . ,(rect 0.0 32.0 32.0 32.0))
+    ((0 2) . ,(rect 0.0 64.0 32.0 32.0))
+    ((0 3) . ,(rect 0.0 96.0 32.0 32.0))
+    ((1 0) . ,(rect 32.0 0.0 32.0 32.0))
+    ((1 1) . ,(rect 32.0 32.0 32.0 32.0))
+    ((1 2) . ,(rect 32.0 64.0 32.0 32.0))
+    ((1 3) . ,(rect 32.0 96.0 32.0 32.0))
+    ((2 0) . ,(rect 64.0 0.0 32.0 32.0))
+    ((2 1) . ,(rect 64.0 32.0 32.0 32.0))
+    ((2 2) . ,(rect 64.0 64.0 32.0 32.0))
+    ((2 3) . ,(rect 64.0 96.0 32.0 32.0))
+    ((3 0) . ,(rect 96.0 0.0 32.0 32.0))
+    ((3 1) . ,(rect 96.0 32.0 32.0 32.0))
+    ((3 2) . ,(rect 96.0 64.0 32.0 32.0))
+    ((3 3) . ,(rect 96.0 96.0 32.0 32.0))))
+
+(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)))
+
+(define (for-each-coord proc)
+  (let y-loop ((y 0))
+    (when (< y 20)
+      (let x-loop ((x 0))
+        (when (< x 10)
+          (proc x y)
+          (x-loop (+ x 1))))
+      (y-loop (+ y 1)))))
+
+(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))
+
+(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))
+
+(define-method (max-x (piece <piece>))
+  (- 9
+     (fold (lambda (p memo)
+             (match p
+               ((x _)
+                (max x memo))))
+           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)
+  (let ((old-x (x piece))
+        (old-y (y piece)))
+    (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)))))
+
+(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 (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))))
+
+(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))
+
+(define-class <board> (<node-2d>)
+  (batch #:accessor batch #:init-keyword #:batch)
+  (tiles #:getter tiles #:init-thunk make-tiles))
+
+(define-method (board-ref (board <board>) x y)
+  (type (array-ref (tiles board) x y)))
+
+(define-method (board-set! (board <board>) x y new-type)
+  (set! (type (array-ref (tiles board) x y)) new-type))
+
+(define-method (add-to-board (board <board>) (piece <piece>))
+  (let ((type (type piece))
+        (x (x piece))
+        (y (y piece)))
+    (for-each (match-lambda
+                ((sx sy)
+                 (let ((bx (+ x sx))
+                       (by (+ y sy)))
+                   (when (< by 20)
+                     (board-set! board bx by type)))))
+              (shape piece))))
+
+(define-method (filled-rows (board <board>))
+  (define (row-full? y)
+    (let loop ((x 0))
+      (cond
+       ((= x 10)
+        #t)
+       ((board-ref board x y)
+        (loop (+ x 1)))
+       (else
+        #f))))
+  (let loop ((y 0))
+    (if (= y 20)
+        '()
+        (if (row-full? y)
+            (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))))
+
+(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)))))
+       (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-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>))
+  (piece #:accessor piece #:init-form #f)
+  (timer #:accessor timer #:init-form 0)
+  (down-interval #:accessor down-interval #:init-form 30))
+
+(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)))
+
+(define-method (on-boot (tetra <tetra>))
+  (set! (batch (board tetra)) (batch tetra))
+  (attach-to tetra
+             (make <filled-rect>
+               #:name 'background
+               #:region (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))
+
+(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)))
+    (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)))))
+           (shape p)))
+    (when (and p (not (touch?)))
+      (move-piece p new-x new-y))))
+
+(define-method (rotate-piece (tetra <tetra>))
+  (let ((p (piece tetra)))
+    (when p
+      (rotate-piece p))))
+
+(define-method (reset-game (tetra <tetra>))
+  (set! (state tetra) 'play)
+  (set! (timer tetra) 0)
+  (board-clear! (board tetra))
+  (add-new-piece tetra)
+  (let ((game-over-text (& tetra game-over-text)))
+    (when game-over-text
+      (detach game-over-text))))
+
+(define-method (on-key-press (tetra <tetra>) key scancode modifiers repeat?)
+  (match (state tetra)
+    ('play
+     (match key
+       ('up (rotate-piece tetra))
+       ('down (move-piece tetra 0 -1))
+       ('left (move-piece tetra -1 0))
+       ('right (move-piece tetra 1 0))
+       ('r (reset-game tetra))
+       (_ #f)))
+    ('game-over
+     (match key
+       ('return (reset-game tetra))
+       (_ #f)))))
+
+(define-method (update (tetra <tetra>) dt)
+  (next-method)
+  (when (eq? (state tetra) 'play)
+    (set! (timer tetra) (+ (timer tetra) 1))
+    (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)
+        (set! (timer tetra) 0)))))
+
+(define-method (render* (tetra <tetra>) alpha)
+  (set-sprite-batch-texture! (batch tetra)
+                             (texture-atlas-texture (asset-ref atlas)))
+  (next-method))
+
+(boot-kernel (make <kernel>
+               #:window-config (make <window-config>
+                                 #:title "tetris clone"
+                                 #:width 600
+                                 #:height 800))
+             (lambda ()
+               (make <tetra>)))