From 68c66e4c7942e2c993b6a1b11a7e26011ff486a9 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 28 May 2019 21:15:17 -0400 Subject: Add tetris example. --- examples/tetra/tetra.scm | 379 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 379 insertions(+) create mode 100644 examples/tetra/tetra.scm (limited to 'examples/tetra/tetra.scm') 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 +;;; +;;; 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 . + +;;; 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 () + (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 + #:position (vec2 (* x 32.0) + (* y 32.0))) + x y))) + tiles)) + +(define-class () + (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 )) + (- 9 + (fold (lambda (p memo) + (match p + ((x _) + (max x memo)))) + 0 + (shape piece)))) + +(define-method (piece-above-board? (piece )) + (let ((py (y piece))) + (any (match-lambda + ((_ y) + (>= (+ y py) 20))) + (shape piece)))) + +(define-method (move-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 )) + (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 ) 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 + #: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 () + (batch #:accessor batch #:init-keyword #:batch) + (tiles #:getter tiles #:init-thunk make-tiles)) + +(define-method (board-ref (board ) x y) + (type (array-ref (tiles board) x y))) + +(define-method (board-set! (board ) x y new-type) + (set! (type (array-ref (tiles board) x y)) new-type)) + +(define-method (add-to-board (board ) (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 )) + (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 )) + (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 )) + (for-each-coord + (lambda (x y) + (set! (type (array-ref (tiles board) x y)) #f)))) + +(define-method (touching-next-row? (piece ) (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 ) 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 () + (state #:accessor state #:init-form 'play) + (batch #:getter batch #:init-form (make-sprite-batch #f)) + (board #:accessor board #:init-form (make )) + (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 )) + (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 )) + (set! (batch (board tetra)) (batch tetra)) + (attach-to tetra + (make + #:name 'background + #:region (rect 0.0 0.0 320.0 640.0) + #:color tango-light-sky-blue) + (board tetra) + (make + #:batch (batch tetra) + #:rank 9999)) + (add-new-piece tetra)) + +(define-method (move-piece (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 )) + (let ((p (piece tetra))) + (when p + (rotate-piece p)))) + +(define-method (reset-game (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 ) 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 ) 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