summaryrefslogtreecommitdiff
path: root/examples/tetra
diff options
context:
space:
mode:
Diffstat (limited to 'examples/tetra')
-rw-r--r--examples/tetra/images/blocks.pngbin0 -> 1384 bytes
-rw-r--r--examples/tetra/tetra.scm379
2 files changed, 379 insertions, 0 deletions
diff --git a/examples/tetra/images/blocks.png b/examples/tetra/images/blocks.png
new file mode 100644
index 0000000..4070ecd
--- /dev/null
+++ b/examples/tetra/images/blocks.png
Binary files differ
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>)))