diff options
Diffstat (limited to 'examples/tetra')
| -rw-r--r-- | examples/tetra/images/blocks.png | bin | 0 -> 1384 bytes | |||
| -rw-r--r-- | examples/tetra/tetra.scm | 379 |
2 files changed, 379 insertions, 0 deletions
diff --git a/examples/tetra/images/blocks.png b/examples/tetra/images/blocks.png Binary files differnew file mode 100644 index 0000000..4070ecd --- /dev/null +++ b/examples/tetra/images/blocks.png 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>))) |
