path: root/examples/tetra/tetra.scm

;;; 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 easings)
             (chickadee math matrix)
             (chickadee math rect)
             (chickadee math vector)
             (chickadee graphics color)
             (chickadee graphics font)
             (chickadee graphics particles)
             (chickadee graphics texture)
             (chickadee graphics 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 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-bitmap-font "fonts/click.xml"))


;;;
;;; 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 ()
    ((_ () body ...)
     (begin body ...))
    ((_ ((var start end inc) rest ...) body ...)
     (let loop ((i start))
       (when (< i end)
         (let ((var i))
           (for-each-permutation (rest ...) body ...))
         (loop (+ i inc)))))
    ((_ ((var start end) rest ...) body ...)
     (for-each-permutation ((var start end 1) rest ...) body ...))))

(define-syntax map-permutation
  (syntax-rules ()
    ((_ ((var start end inc)) body ...)
     (let loop ((i start))
       (if (< i end)
           (let ((var i))
             (cons (begin body ...)
                   (loop (+ i 1))))
           '())))
    ((_ ((var start end inc) rest ...) body ...)
     (let loop ((i start))
       (if (< i end)
           (let ((var i))
             (append (map-permutation (rest ...) body ...)
                     (loop (+ i 1))))
           '())))
    ((_ ((var start end) rest ...) body ...)
     (map-permutation ((var start end 1) rest ...) body ...))))


;;;
;;; Tiles
;;;

;; A single block on a tetris board.
(define-class <tile> ()
  (type #:accessor type #:init-form #f)
  (area #:getter area #:init-keyword #:area))

(define (for-each-coord proc)
  (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))

(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>))
  (- board-width 1
     (fold (lambda (p memo)
             (match p
               ((x _)
                (max x memo))))
           0
           (shape piece))))

(define-method (move-piece (piece <piece>) new-x new-y init?)
  (let ((old-x (x 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)
    (if init?
        (teleport piece px py)
        (run-script piece
          (move-to piece px py 8)))))

(define-method (move-piece (piece <piece>) new-x new-y)
  (move-piece piece new-x new-y #f))

(define-method (render (piece <piece>) alpha)
  (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
;;;

;; 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)
  (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 (get-tile board x y)))

(define-method (board-set! (board <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))
        (x (x piece))
        (y (y piece)))
    (for-each (match-lambda
                ((sx sy)
                 (let ((bx (+ x sx))
                       (by (+ y sy)))
                   (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 board-width)
        #t)
       ((board-ref board x y)
        (loop (+ x 1)))
       (else
        #f))))
  (let loop ((y 19))
    (if (< y 0)
        '()
        (if (row-full? y)
            (cons y (loop (- y 1)))
            (loop (- y 1))))))

(define-method (remove-filled-rows (board <board>))
  (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)))
            (or (= by -1)
                (and (< by board-height)
                        (board-ref board bx by))))))
       (shape piece)))

(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)
  (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)
  (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 (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! (board tetra) (make <board>))
  (attach-to tetra
             (make <filled-rect>
               #: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 (+ (y p) dy)))
    (define (touch?)
      (any (match-lambda
             ((sx sy)
              (let ((bx (+ new-x sx))
                    (by (+ new-y sy)))
                (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))))

(define-method (rotate-piece (tetra <tetra>))
  (let ((p (piece tetra)))
    (when 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)
  (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)
  (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)
    ('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)))
        (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)))))

;; Seed the random number generator.
(set! *random-state* (random-state-from-platform))
(boot-kernel (make <kernel>
               #:window-config (make <window-config>
                                 #:title "tetra"
                                 #:width window-width
                                 #:height window-height))
             (lambda ()
               (make <tetra>)))