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 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-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 ...))))

(define rects
  (map-permutation ((x 0 4) (y 0 4))
                   `((,x ,y) . ,(make-rect (* x 32.0) (* y 32.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)
  (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))

(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 (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))

(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-tree (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>)))