Full program for the "A Game of Tetris" blog posts.

tetris-5.rkt

;; A tetris game -- partial implementation, part 5

;; Copyright (c) 2020 Alex Harsányi ([email protected])

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
#lang racket/gui
(require pict racket/draw racket/contract)

(module+ test
  (require rackunit)
  #;(printf "*** Will run tests~%"))


;;.................................................... Block Definitions ....

;; A tetris block is defined as a list of 4 strings, providing a nice visual
;; representation of the block inside the program code.  Each string can
;; contain one of the following characters: "." represents a space (we could
;; have used a space here, but the dot is easier to see and align).  One of
;; the letters IQLJTZS, we will use the letters to give each block a unique
;; color.

(define I-Block
  '(".I.."
    ".I.."
    ".I.."
    ".I.."))

(define Q-Block
  '("...."
    ".QQ."
    ".QQ."
    "...."))   

(define L-Block
  '("LL.."
    ".L.."
    ".L.."
    "...."))   

(define J-Block
  '(".JJ."
    ".J.."
    ".J.."
    "...."))   

(define T-Block
  '(".T.."
    "TTT."
    "...."
    "...."))

(define Z-Block
  '(".Z.."
    "ZZ.."
    "Z..."
    "...."))   

(define S-Block
  '("S..."
    "SS.."
    ".S.."
    "...."))   

;; A list of all the tetris blocks.  This will be used in the game to randomly
;; pick the next block, but also in our testing when we need to check a
;; function against all the tetris blocks.
(define all-blocks (list I-Block Q-Block L-Block J-Block T-Block Z-Block S-Block))

;; Return true if ROW is a valid block row, which means that it is a 4
;; character string, containing only the valid characters for tetris blocks.
(define (valid-block-row? row)
  (and (string? row)                     ; a row is a string
       (= (string-length row) 4)         ; of 4 characters
       (for/and ([item (in-string row)]) ; containing only valid characters
         (and (member item '(#\. #\I #\Q #\L #\J #\T #\Z #\S)) #t))))

;; Return true if BLOCK is a valid tetris block, meaning that it is a list
;; containing four rows which pass the VALID-BLOCK-ROW? test.
(define (valid-block? block)
  (and (list? block)                      ; a block is a list
       (= (length block) 4)               ; ... of 4 items
       (andmap valid-block-row? block)))  ; ... each element is a valid row

(module+ test
  (check-false (valid-block-row? 1))        ; not a string
  (check-false (valid-block-row? "......")) ; more than 4 characters
  (check-false (valid-block-row? "X..."))   ; containing invalid characters

  ;; First, let's verify that VALID-BLOCK? can actually detect invalid blocks
  (check-false (valid-block? "hello"))  ; not a list
  (check-false (valid-block? (append L-Block T-Block))) ; more than 4 items
  (check-false (valid-block? (list "...." "...." "...." 1))) ; not a list of strings
  (check-false (valid-block? (list "X..." "...." "...." "...."))) ; contains invalid characters

  ;; Verify that all our blocks are correctly defined
  (for ([block (in-list all-blocks)])
    (check-pred valid-block? block)))


;;.................................................... Displaying Blocks ....

(define square-size 15)                 ; size of a block square in pixels

;; Map each letter that can be present in a tetris block to a color, this will
;; be used to color each tetris block with a unique color.  Any colors can be
;; used for this purpose, these ones are from Paul Tol's Vibrant Qualitative
;; color scheme https://personal.sron.nl/~pault/
(define colors
  (hash
   #\I (make-color 0 119 187)
   #\Q (make-color 51 187 238)
   #\L (make-color 0 153 136)
   #\J (make-color 238 119 51)
   #\T (make-color 204 51 17)
   #\Z (make-color 238 51 119)
   #\S (make-color 136 34 85)))

;; Produce a pict from a string containing valid Tetris color codes (see
;; `colors`) table above.  Note that we don't restrict the argument to be a
;; valid block row, as this function will also be used to produce the filled
;; lines from blocks that accumulate at the bottom of the playing field.
;;
;; Sample use: (row->squares ".LL.")
(define/contract (row->squares row)
  (-> string? pict?)
  (define items
    (for/list ([char (in-string row)])
      (define color (hash-ref colors char #f))
      (if color
          (filled-rectangle square-size square-size #:color color)
          (ghost (rectangle square-size square-size)))))
  (apply hc-append items))

;; Produce a PICT corresponding to the tetris BLOCK.
;;
;; Sample use:
;; (block->pict L-Block)
;; (map block->pict all-blocks)
(define/contract (block->pict block)
  (-> valid-block? pict?)
  (apply vc-append (map row->squares block)))

;; Produce a pict which shows the tetris block without any additional margins
;; which would be present in the 4x4 grid of the block.
(define/contract (trim-block-pict block)
  (-> valid-block? pict?)
  (define-values (min-x min-y max-x max-y) (block-bounding-box block))
  (inset/clip
   (block->pict block)
   (- (* square-size min-x)) ;; left
   (- (* square-size min-y)) ;; top
   (- (* square-size (- 3 max-x))) ;; right
   (- (* square-size (- 3 max-y))))) ;; bottom


;;....................................................... Block Rotation ....

;; Rotate a tetris block clockwise by 90 degrees (a quarter of a circle),
;; returning the rotated tetris block.
(define/contract (rotate-clockwise block)
  (-> valid-block? valid-block?)
  (for/list ([a (in-string (first block))]
             [b (in-string (second block))]
             [c (in-string (third block))]
             [d (in-string (fourth block))])
    (string d c b a)))

;; Rotate a tetris BLOCK a number of TIMES (which can be 0) and return a new
;; tetris block.
(define/contract (rotate-clockwise* block times)
  (-> valid-block? exact-nonnegative-integer? valid-block?)
  (if (> times 0)
      (let ([rotated (rotate-clockwise block)])
        (rotate-clockwise* rotated (sub1 times)))
      block))

;; Rotate a tetris block counter-clockwise by 90 degrees (a quarter of a
;; circle), returning the rotated tetris block.  Rather than implementing a
;; block decomposition and building a new block, we simply rotate the block 3
;; times clockwise, which would bring it in the same position as one rotation
;; counter clockwise.
(define/contract (rotate-counter-clockwise block)
  (-> valid-block? valid-block?)
  (rotate-clockwise* block 3))

(module+ test
  (for ([block (in-list all-blocks)])
    ;; Rotating the block clockwise 4 times brings it in the same position as
    ;; where we started from.
    (check-equal? (rotate-clockwise* block 4) block)
    ;; Rotating a block once clockwise once counter-clockwise brings it back
    ;; into the initial position.
    (check-equal? (rotate-clockwise (rotate-counter-clockwise block)) block)))


;;............................................. Playing Field Collisions ....

;; The dimensions of the playing field, in squares
(define-values (field-width field-height) (values 12 24))

(module+ test
  ;; Tests were written for a field if 12x24.  Other field dimensions work for
  ;; the game, but the tests will fail.  This test is here to remind me of
  ;; that fact.
  (check-equal? field-height 24))

;; Determine the bounding box of a tetris block.  A tetris block is always 4x4
;; squares in size, but the actual piece occupies less space than that.  This
;; function determines the minimum and maximum X and Y values inside the block
;; that the tetris piece occupies this function will be used to determine if a
;; piece can be moved left and right and still be inside the playing field.
(define/contract (block-bounding-box block)
  (-> valid-block? (values integer? integer? integer? integer?))
  (define-values (min-x max-x)
    (for/fold ([min-x 3] [max-x 0])
              ([row (in-list block)])
      (define row-min-x (for/first ([(item position) (in-indexed (in-string row))]
                                    #:unless (equal? #\. item))
                          position))
      (define row-max-x (for/last ([(item position) (in-indexed (in-string row))]
                                   #:unless (equal? #\. item))
                          position))
      (values (if row-min-x (min min-x row-min-x) min-x)
              (if row-max-x (max max-x row-max-x) max-x))))

  (define min-y
    (for/first ([(row position) (in-indexed (in-list block))]
                #:unless (equal? row "...."))
      position))
  (define max-y
    (for/last ([(row position) (in-indexed (in-list block))]
               #:unless (equal? row "...."))
      position))
  (values min-x min-y max-x max-y))

(module+ test
  (define (bb-helper block rotations)
    (call-with-values (lambda () (block-bounding-box (rotate-clockwise* block rotations))) list))

  ;; Check that bounding boxes are correctly detected for all blocks and their
  ;; rotations.  Since there are 28 possibilities (7 blocks, 4 rotations
  ;; each), the `all-blocks-and-rotations` function was used to display the
  ;; block visually and determine what the bounding boxes should be.

  (check-equal? (bb-helper I-Block 0) '(1 0 1 3))
  (check-equal? (bb-helper I-Block 1) '(0 1 3 1))
  (check-equal? (bb-helper I-Block 2) '(2 0 2 3))
  (check-equal? (bb-helper I-Block 3) '(0 2 3 2))

  (check-equal? (bb-helper Q-Block 0) '(1 1 2 2))
  (check-equal? (bb-helper Q-Block 1) '(1 1 2 2))
  (check-equal? (bb-helper Q-Block 2) '(1 1 2 2))
  (check-equal? (bb-helper Q-Block 3) '(1 1 2 2))

  (check-equal? (bb-helper L-Block 0) '(0 0 1 2))
  (check-equal? (bb-helper L-Block 1) '(1 0 3 1))
  (check-equal? (bb-helper L-Block 2) '(2 1 3 3))
  (check-equal? (bb-helper L-Block 3) '(0 2 2 3))

  (check-equal? (bb-helper J-Block 0) '(1 0 2 2))
  (check-equal? (bb-helper J-Block 1) '(1 1 3 2))
  (check-equal? (bb-helper J-Block 2) '(1 1 2 3))
  (check-equal? (bb-helper J-Block 3) '(0 1 2 2))

  (check-equal? (bb-helper T-Block 0) '(0 0 2 1))
  (check-equal? (bb-helper T-Block 1) '(2 0 3 2))
  (check-equal? (bb-helper T-Block 2) '(1 2 3 3))
  (check-equal? (bb-helper T-Block 3) '(0 1 1 3))

  (check-equal? (bb-helper Z-Block 0) '(0 0 1 2))
  (check-equal? (bb-helper Z-Block 1) '(1 0 3 1))
  (check-equal? (bb-helper Z-Block 2) '(2 1 3 3))
  (check-equal? (bb-helper Z-Block 3) '(0 2 2 3))

  (check-equal? (bb-helper S-Block 0) '(0 0 1 2))
  (check-equal? (bb-helper S-Block 1) '(1 0 3 1))
  (check-equal? (bb-helper S-Block 2) '(2 1 3 3))
  (check-equal? (bb-helper S-Block 3) '(0 2 2 3)))

;; Return true if the BLOCK at coordinates X, Y is inside the playing field.
;; The coordinates represent the top-left corner of the block, and the block
;; is considered inside if the block itself, not the 4x4 matrix is inside the
;; playing field.
(define (inside-playing-field? block x y)
  (-> valid-block? integer? integer? boolean?)
  (define-values (min-x min-y max-x max-y)
    (block-bounding-box block))
  (and (< (+ x max-x) field-width)
       (>= (+ x min-x) 0)
       (< (+ y max-y) field-height)))

(module+ test
  ;; All blocks at 0 0 should be inside the playing field
  (for ([block (in-list all-blocks)])
    (check-true (inside-playing-field? block 0 0)))
  ;; I block is inside the playing field even though its two right columns are
  ;; outside (since there are no colored squares there)
  (check-true (inside-playing-field? I-Block (- field-width 2) 0))
  (check-false (inside-playing-field? I-Block (- field-width 1) 0))
  ;; I Block is inside the playing field even though its left column is
  ;; outside (since there are no squares there)
  (check-true (inside-playing-field? I-Block -1 0))
  (check-false (inside-playing-field? I-Block -2 0))
  ;; T Block is inside the playing field even though the bottom two rows are
  ;; outside
  (check-true (inside-playing-field? T-Block 0 (- field-height 2)))
  (check-false (inside-playing-field? T-Block 0 (- field-height 1))))

;; if the current block is outside the playing field, bring it back in by
;; moving it left or right -- this is used when rotating a block if that
;; rotation would take a part of the block outside the playing field.
(define/contract (adjust-x-position block x y)
  (-> valid-block? integer? integer? integer?)
  (define-values (min-x min-y max-x max-y)
    (block-bounding-box block))
  (if (< (+ y max-y) field-height)
      (let loop ([x x])
        (if (inside-playing-field? block x y)
            x
            (loop (if (>= x 0) (sub1 x) (add1 x)))))
      x))

(module+ test
  ;; T-Block that is outside to the left, moved back in
  (check-equal? (adjust-x-position T-Block -1 0) 0)
  ;; T-Block that is outside to the right moved back in.
  (check-equal? (adjust-x-position T-Block (- field-width 2) 0) (- field-width 3)))


;;......................................................... Filled Lines ....

;; Return true if LINE is a valid filled line in the game.  A filled line is a
;; string of exactly FIELD-WIDTH characters containing only valid character
;; codes.
(define (valid-filled-line? line)
  (and (string? line)                   ; a string
       (= (string-length line) field-width) ; of the correct length
       (for/and ([item (in-string line)]) ; containing only valid characters
         (and (member item '(#\. #\I #\Q #\L #\J #\T #\Z #\S)) #t))))

(module+ test
  (check-false (valid-filled-line? (list empty-line))) ; not a string
  (check-false (valid-filled-line? "..CCCC.."))        ; wrong length
  (check-false (valid-filled-line? "XY.........."))    ; invalid characters
  (check-true (valid-filled-line? empty-line)))

;; Build a PICT from the filled lines at the bottom of the playing field.
;; LINES is a list of strings, exactly FIELD-WIDTH in length
(define/contract (filled-lines->pict lines)
  (-> (listof valid-filled-line?) pict?)
  (apply vc-append (map row->squares lines)))


;;....................................................... Merging Blocks ....

;; An empty line on the playing field -- normally the filled lines will only
;; occupy the space that they are using, but our merging code allows empty
;; lines in-between filled lines.  Rather than construct the empty line every
;; time, we keep it here.
(define empty-line (make-string field-width #\.))

;; Convert a block row at position X-POSITION into a filled line, this is done
;; by padding the block row to the left and right with empty characters (which
;; are the dot character).
(define/contract (block-row->filled-line row x-position)
  (-> valid-block-row? integer? valid-filled-line?)
  (define limit (+ x-position (string-length row)))
  (define items
    (for/list ([pos (in-range field-width)])
      (if (or (< pos x-position) (>= pos limit))
          #\.
          (string-ref row (- pos x-position)))))
  (apply string items))

(module+ test
  (check-equal? (block-row->filled-line ".QQ." 0) ".QQ.........")
  (check-equal? (block-row->filled-line ".QQ." -1) "QQ..........")
  (check-equal? (block-row->filled-line ".QQ." -2) "Q...........")
  (check-equal? (block-row->filled-line ".QQ." -5) "............")

  (check-equal? (block-row->filled-line ".QQ." 1) "..QQ........")
  (check-equal? (block-row->filled-line ".QQ." 8) ".........QQ.")
  (check-equal? (block-row->filled-line ".QQ." 9) "..........QQ")
  (check-equal? (block-row->filled-line ".QQ." 10) "...........Q")
  (check-equal? (block-row->filled-line ".QQ." 15) "............"))

;; Merge the colored blocks of two lines, LINE1 and LINE2 returning a new
;; line.  The colored blocks in each line cannot collide, i.e. for each
;; colored block, there has to be an empty space, denoted by the . (dot)
;; character, in the corresponding place of the other line.  An error is
;; signaled if there is a collision.
(define/contract (merge-lines line1 line2)
  (-> valid-filled-line? valid-filled-line? valid-filled-line?)
  (define items
    (for/list ([a (in-string line1)]
               [b (in-string line2)])
      (cond ((equal? a #\.) b)
            ((equal? b #\.) a)
            (#t (error (format "Line collision: ~a vs ~a" line1 line2))))))
  (apply string items))

(module+ test
  (check-equal? (merge-lines ".LL........." "..........JJ") ".LL.......JJ")
  ;; Attempting to merge colliding lines should fail -- this indicates an
  ;; error somewhere else in the program
  (check-exn exn:fail?
             (lambda ()
               (merge-lines ".JJ........." "QQ.........."))))

;; Return #t if a row from a block at position X collides with LINE, that is,
;; it has colored squares in the same place as the LINE itself.
;;
;; As implementation, we'll just expand the block row into a full line using
;; BLOCK-ROW->FILLED-LINE, than attempt to merge the lines. If the merge succeeds, the
;; block row does not collide, if the merge raises an exception, we just
;; return #t, as there is a collision
(define/contract (block-row-with-line-collision? block-row x line)
  (-> valid-block-row? integer? valid-filled-line? boolean?)
  (define bline (block-row->filled-line block-row x))
  (with-handlers
    ((exn:fail? (lambda (e) #t)))
    ;; We discard the result from merge-lines, but return false: if the merge
    ;; is successful, the block row does not collide with the line.
    (merge-lines bline line)
    #f))

(module+ test
  (check-true (block-row-with-line-collision? ".LL." 0 "..QQ........"))
  (check-false (block-row-with-line-collision? ".LL." 3 "..QQ........")))

;; Return #t if BLOCK at position X, Y would collide with blocks inside the
;; filled lines
(define/contract (block-collision? block x y filled-lines)
  (-> valid-block? integer? integer? (listof valid-filled-line?) boolean?)
  (let loop ([bdepth y]
             [block block]
             [fdepth (- field-height (length filled-lines))]
             [filled filled-lines])
    (cond ((or (null? block) (null? filled))
           #f)
          ((< bdepth fdepth)
           (loop (add1 bdepth) (cdr block) fdepth filled))
          ((> bdepth fdepth)
           (loop bdepth block (add1 fdepth) (cdr filled)))
          (#t
           (if (block-row-with-line-collision? (car block) x (car filled))
               #t
               (loop (add1 bdepth) (cdr block) (add1 fdepth) (cdr filled)))))))

(module+ test
  (define sample-filled-lines
    '("...........I"
      "LJJJ...J...I"
      "LZZJ.SSJ.T.I"
      "LLZZSSJJTTTI"))

  (define sample-filled-lines3
    '("..........T."
      ".....Z.Z.TTT"
      "....ZZZZLLLL"
      "....Z.Z.LLLL"))

  ;; Cannot collide if there are empty lines
  (check-false (block-collision? T-Block 0 22 '()))
  #;(check-true (block-collision? T-Block 0 22 sample-filled-lines))
  (check-true (block-collision? Q-Block 4 19 sample-filled-lines3)))

;; Add line to result, but only if not empty (we don't want to add empty
;; lines at the top)
(define (maybe-add line result)
  (if (and (equal? line empty-line) (null? result))
      result
      (cons line result)))

;; Merge the tetris BLOCK at coordinates X,Y (representing the top-left corner
;; of the block) onto the FILLED-LINES at the bottom of the playing field.
;; Returns a new set of filled lines, representing the new configuration of
;; the playing field bottom.
(define (merge-block block x y filled-lines)
  (let loop ([bdepth y]
             [block block]
             [fdepth (- field-height (length filled-lines))]
             [filled filled-lines]
             [result '()])
    (cond ((and (< bdepth fdepth) (not (null? block)))
           ;; Block row is above filled lines, create new filled lines at the
           ;; top.
           (let ([line (block-row->filled-line (car block) x)])
             (loop (add1 bdepth) (cdr block)
                   fdepth filled
                   (maybe-add line result))))
          ((> bdepth fdepth)
           ;; Filled lines are above the block row, just add them to the
           ;; result, no merging is needed
           (loop y block
                 (add1 fdepth) (cdr filled)
                 (cons (car filled) result)))
          ((>= fdepth field-height)
           ;; Filled lines depth is now greater than the field depth -- we're
           ;; done.
           (reverse result))
          ((null? block)
           ;; We're done with the block rows, just add the remaining filled
           ;; lines
           (loop (add1 bdepth) block
                 (add1 fdepth) (cdr filled)
                 (cons (car filled) result)))
          (#t
           ;; The block row is at the same level as a filled line.  Merge
           ;; them, to create a new line
           (let* ([bline (block-row->filled-line (car block) x)]
                  [line (merge-lines (car filled) bline)])
             (loop (add1 bdepth) (cdr block) (add1 fdepth) (cdr filled)
                   (maybe-add line result)))))))

(module+ test
  ;; merging onto an empty field
  (check-equal? (merge-block T-Block 0 22 '()) '(".T.........." "TTT........."))
  (check-equal? (merge-block L-Block 0 21 '()) '("LL.........." ".L.........." ".L.........."))
  (check-equal? (merge-block Q-Block 0 21 '()) '(".QQ........." ".QQ........."))

  ;; Block is floating above the bottom (not our problem)
  (check-equal? (merge-block Q-Block 0 20 '()) '(".QQ........." ".QQ........." "............"))

  ;; Block is partially buried
  (check-equal? (merge-block Q-Block 0 22 '()) '(".QQ........."))

  ;; Some general test cases, these were generated by visually inspecting the
  ;; result for correctness with `filled-lines->pict`
  (check-equal? (merge-block L-Block 4 19 sample-filled-lines)
                '("....LL......" ".....L.....I" "LJJJ.L.J...I" "LZZJ.SSJ.T.I" "LLZZSSJJTTTI"))
  (check-equal? (merge-block T-Block 4 20 sample-filled-lines)
                '(".....T.....I" "LJJJTTTJ...I" "LZZJ.SSJ.T.I" "LLZZSSJJTTTI"))
  ;; This should fail, as we are attempting to merge a block over other blocks
  (check-exn exn:fail?
              (lambda ()
                (merge-block T-Block 4 21 sample-filled-lines))))



;;................................................ Collapsing Full Lines ....

;; A filled line is full if it has all squares filled in and no empty spaces
;; (which are marked by the . (dot) character.
(define/contract (full-line? line)
  (-> valid-filled-line? boolean?)
  (for/and ([char (in-string line)])
    (not (equal? #\. char))))

(module+ test
  (check-true (full-line? "QQLLZZSSTTQQ"))
  (check-false (full-line? "QQL.ZZSSTTQQ"))
  (check-false (full-line? empty-line)))

;; Remove the completed lines from FILLED-LINES, returning a new set of filled
;; lines.
(define (remove-full-lines filled-lines)
  (-> (listof valid-filled-line?) (listof valid-filled-line?))
  (for/list ([line (in-list filled-lines)] #:unless (full-line? line))
    line))

(module+ test
  (check-equal? (remove-full-lines '()) '())
  (check-equal? (remove-full-lines sample-filled-lines)
                '("...........I"
                  "LJJJ...J...I"
                  "LZZJ.SSJ.T.I"))
  ;; Once we remove the full lines, calling the function again will not do
  ;; anything, since the lines are already removed.
  (check-equal? (remove-full-lines sample-filled-lines)
                (remove-full-lines (remove-full-lines sample-filled-lines))))


;;........................................................... game state ....

;; The current block and its x, y position on the playing field
(define-values (current-block block-x block-y) (values #f 0 0))
;; The next block which will be used once the current one is placed at the
;; bottom
(define the-next-block #f)
;; Counts the number of times each block showed up in the game
(define the-block-statistics (make-hash))

;; The filled lines at the bottom of the playing field
(define filled-lines '())

(define current-score 0)
(define current-level 0)

;; Make a pict showing each block and the number of times it showed up in
;; STATS (this is usually called with THE-BLOCK-STATISTICS as the argument)
(define (make-statistics-pict stats)
  (define total (for/sum ([value (in-hash-values stats)]) value))
  (define picts
    (flatten
     (for/list ([block (in-list all-blocks)])
       (define count (hash-ref stats block 0))
       (define percent (* 100 (if (> total 0) (/ count total) 0)))
       (list
        (scale (trim-block-pict block) 0.80)
        (text (format "~a  (~a %)" count (exact-round percent)) 'default 16)))))
  (table 2 picts lc-superimpose cc-superimpose 5 3))

;; A pict to overlay over the playing field when the game is finished.
(define game-over-pict
  (let* ([label (text "Game Over" (cons 'bold 'default) 24)]
         [background (filled-rounded-rectangle
                      (+ 25 (pict-width label))
                      (+ 25 (pict-height label)))])
    (cc-superimpose
     (cellophane (colorize background '(221 221 221)) 0.9)
     (colorize label '(165 0 38)))))


;;......................................................... main program ....

;; A frame which intercepts keyboard input using the `on-subwindow-char`
;; method and passes it to `on-tetris-event` -- this is used to read keyboard
;; input from the user and move/rotate the current piece.
(define tetris-frame%
  (class frame%
    (init) (super-new)
    (define/override (on-subwindow-char receiver event)
      (on-tetris-event event)
      (super on-subwindow-char receiver event))))

;; The dimensions of the playing field, in squares
(define-values (window-width window-height)
  (values (* field-width square-size) (* field-height square-size)))

;; The toplevel window for the game
(define toplevel
  (new tetris-frame% [label "Tetris"] [width window-width] [height window-height]))

;; Panel which holds all the controls and sub-panels in the game
(define game-panel (new horizontal-panel% [parent toplevel] [spacing 20] [border 20]))

;; Display the playing field.  Currently, the current block is shown at its
;; X,Y location.
(define (on-tetris-paint canvas dc)
  (send dc clear)
  (send dc set-smoothing 'smoothed)

  (unless (null? filled-lines)
    (define depth (* (- field-height (length filled-lines)) square-size))
    (draw-pict (filled-lines->pict filled-lines) dc 0 depth))

  (when current-block                   ; will be #f at the end of the game
    (define x (* block-x square-size))
    (define y (* block-y square-size))
    (draw-pict (block->pict current-block) dc x y))

  (unless current-block
    ;; Display a "Game Over" overlay
    (let-values ([(width height) (send dc get-size)])
      (let ([x (/ (- width (pict-width game-over-pict)) 2)]
            [y (/ (- height (pict-height game-over-pict)) 2)])
        (draw-pict game-over-pict dc x y)))))

;; Update the score to NEW-SCORE, but only if it changes.  If FORCE? is #t the
;; score is always updated
(define (on-update-score new-score #:force? (force? #f))
  (when (or force? (> new-score current-score))
    (set! current-score new-score)
    (send score set-label (format "Score: ~a" current-score))
    (define new-level (exact-truncate (/ current-score 3)))
    (when (or force? (> new-level current-level))
      (set! current-level new-level)
      (send level set-label (format "Level: ~a" (add1 current-level)))
      (send timer stop)                 ; stop previous timer
      (define new-interval (max 100 (- 500 (* 10 current-level))))
      (set! timer (new timer% [notify-callback on-tetris-tick] [interval new-interval])))))

;; A canvas which holds the drawing area for the game -- the on-tetris-paint
;; defined above is used to fill the canvas, and will be invoked when the
;; canvas is refreshed.
(define play-field (new canvas% [parent game-panel]
                        [min-width window-width]
                        [min-height window-height]
                        [stretchable-width #f]
                        [stretchable-height #f]
                        [paint-callback on-tetris-paint]))

;; Panel to hold the start game button, score, level and next block
(define controls
  (new vertical-panel% [parent game-panel] [alignment '(left top)] [spacing 20]))

;; Font to use for the controls -- it is bigger than the default font for the
;; controls.
(define game-font
  (send the-font-list find-or-create-font 14 'decorative 'normal 'normal))

;; Button to start a new game.  Its callback simply calls `start-game`
(define start-new-game
  (new button% [label "Start New Game"] [parent controls]
       [font game-font]
       [callback (lambda (button event) (start-game))]))

;; Message to hold the current game score
(define score
  (new message% [label "Score: 000000"] [font game-font] [parent controls]))

;; Message to hold the current game level
(define level
  (new message% [label "Level: 000000"] [font game-font] [parent controls]))

;; Panel to hold the canvas which displays the next block -- it is used to
;; show a label and a border around the canvas.
(define next-block-panel (new group-box-panel%
                              [label "Next Block"]
                              [font game-font]
                              [border 10]
                              [parent controls]
                              [stretchable-width #f]
                              [stretchable-height #f]))

;; Paint function for the next block canvas -- draws the picture for
;; `the-next-block` after it was trimmed to size using `trim-block-pict`.
(define (on-next-block-paint canvas dc)
  (send dc clear)
  (send dc set-smoothing 'smoothed)
  (when the-next-block
    (define pict (trim-block-pict the-next-block))
    (let-values ([(dc-width dc-height) (send dc get-size)])
      (draw-pict pict
                 dc
                 (/ (- dc-width (pict-width pict)) 2)
                 (/ (- dc-height (pict-height pict)) 2)))))

;; A canvas to display the next block in the game
(define next-block
  (let ((sample-pict (block->pict I-Block)))
    (new canvas% [parent next-block-panel]
         [min-width (pict-width sample-pict)]
         [min-height (pict-height sample-pict)]
         [stretchable-width #f]
         [stretchable-height #f]
         [paint-callback on-next-block-paint])))

;; Panel holding the canvas which displays block statistics -- it is used to
;; show a label and a border around the canvas.
(define block-statistics-panel (new group-box-panel%
                              [label "Block Statistics"]
                              [font game-font]
                              [border 10]
                              [parent game-panel]
                              [stretchable-width #f]
                              [stretchable-height #f]))

;; Paint function for the block statistics canvas -- uses
;; `make-statistics-pict` and draws that pict
(define (on-block-statistics-paint canvas dc)
  (send dc clear)
  (send dc set-smoothing 'smoothed)
  (define pict (make-statistics-pict the-block-statistics))
  (let-values ([(dc-width dc-height) (send dc get-size)])
      (draw-pict pict
                 dc
                 (/ (- dc-width (pict-width pict)) 2)
                 (/ (- dc-height (pict-height pict)) 2))))

;; Canvas to show the statistics (how many times each block showed up in the
;; game)
(define block-statistics
  (let ((sample-pict (make-statistics-pict (make-hash))))
    (new canvas% [parent block-statistics-panel]
         ;; The height of the statistics pict will not change, but the width
         ;; will, as the numbers grow, leave some room in the canvas!
         [min-width (exact-round (+ 50 (pict-width sample-pict)))]
         [min-height (exact-round (+ 10 (pict-height sample-pict)))]
         [stretchable-width #t]
         [stretchable-height #t]
         [paint-callback on-block-statistics-paint])))

;; Called at regular intervals to make pieces fall.  The function just
;; increments the blocks Y position, and if the new Y position causes the
;; block to collide, it merges the block into the filled lines
(define (on-tetris-tick)
  (when current-block                   ; will be #f at the end of the game
    (define inside? (inside-playing-field? current-block block-x (add1 block-y)))
    (define collision? (block-collision? current-block block-x (add1 block-y) filled-lines))

    (if (and inside? (not collision?))
        (set! block-y (add1 block-y))
        (spawn-new-block))

    (send play-field refresh)))

;; Timer invokes `on-tetris-tick` periodically.  Changing the interval makes
;; the pieces fall slower or faster.  A new timer is created as the level
;; increases.  This is done in `spawn-new-block`
(define timer (new timer% [notify-callback on-tetris-tick] [interval 500]))

;; Randomly select a block from the list of available blocks and return it.
(define (pick-new-block)
  (let ([candidate (random (length all-blocks))])
    (list-ref all-blocks candidate)))

;; Merge the current block to the filled lines, create a new block and place
;; it a the top of the field.  Also updates score, statistics and the game
;; level.
(define (spawn-new-block)
  (when current-block
    (set! filled-lines (merge-block current-block block-x block-y filled-lines))
    (on-update-score (+ current-score (count full-line? filled-lines)))
    (set! filled-lines (remove-full-lines filled-lines)))

  ;; If there is a next bloc, use that and spawn a new next block, otherwise
  ;; randomly select a current block (next-block will be #f at the start of
  ;; the game)
  (set! current-block (if the-next-block the-next-block (pick-new-block)))
  (set! the-next-block (pick-new-block))
  (send next-block refresh)

  ;; Update statistics
  (hash-update! the-block-statistics current-block add1 0)
  (send block-statistics refresh)

  (set! block-y 0)
  (set! block-x (exact-truncate (- (/ field-width 2) 2)))

  ;; Playing field is full.  Game Over.
  (when (block-collision? current-block block-x block-y filled-lines)
    (set! current-block #f)))

;; Handle a keyboard event from the user.  Left-Right keys move a piece left
;; or right, while the up and down keys rotate the piece clockwise or
;; counter-clockwise
(define (on-tetris-event event)
  (when current-block
    (case (send event get-key-code)
      ((left) (on-left-right-move sub1))
      ((right) (on-left-right-move add1))
      ((up) (on-rotation rotate-clockwise))
      ((down) (on-rotation rotate-counter-clockwise)))
    (send play-field refresh)))

(define (on-rotation rotate-function)
  (define candidate (rotate-function current-block))
  (define-values (min-x min-y max-x max-y) (block-bounding-box candidate))

  (cond
    ; rotating the block would make it collide, don't change it
    ((block-collision? candidate block-x block-y filled-lines)
     (void))
    ;; rotating the block would make it go below the field bottom, don't
    ;; change it.
    ((>= (+ block-y max-y) field-height)
     (void))
    (#t
     (define x (adjust-x-position candidate block-x block-y))
     ;; Bringing the block inside the playing field might make it collide, so
     ;; we need to check again for collisions.
     (unless (block-collision? candidate x block-y filled-lines)
       (set! current-block candidate)
       (set! block-x x)))))

(define (on-left-right-move direction)
  (when (and (inside-playing-field? current-block (direction block-x) block-y)
             (not (block-collision? current-block (direction block-x) block-y filled-lines)))
    (set! block-x (direction block-x))))

;; Reset the game state and start a game (if an existing game is already
;; running, it is restarted)
(define (start-game)
  (set! filled-lines '())
  (set! current-block #f)
  (set! the-next-block #f)
  (set! the-block-statistics (make-hash))
  (on-update-score 0 #:force? #t)
  (spawn-new-block)
  (send play-field focus)
  (send toplevel show #t)
  (send toplevel show #t))

(start-game)