summaryrefslogtreecommitdiff
path: root/examples
diff options
context:
space:
mode:
Diffstat (limited to 'examples')
-rw-r--r--examples/tetra/tetra.scm695
1 files changed, 508 insertions, 187 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>)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-22 12:05:27 +0000