Skip to content

Instantly share code, notes, and snippets.

@alex-hhh alex-hhh/tetris-3.rkt
Last active Apr 3, 2020

What would you like to do?
Tetris Game -- Third Version
;; A tetris game -- partial implementation, part 3
;; Copyright (c) 2020 Alex Harsányi (
;; 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.
#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
(define Q-Block
(define L-Block
(define J-Block
(define T-Block
(define Z-Block
(define S-Block
;; 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 20) ; 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
(define colors
#\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)
(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)))
;;....................................................... 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)))
;; 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))
(define row-max-x (for/last ([(item position) (in-indexed (in-string row))]
#:unless (equal? #\. item))
(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 "...."))
(define max-y
(for/last ([(row position) (in-indexed (in-list block))]
#:unless (equal? row "...."))
(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)
(loop (if (>= x 0) (sub1 x) (add1 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))
((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)
(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))
((< bdepth fdepth)
(loop (add1 bdepth) (cdr block) fdepth filled))
((> bdepth fdepth)
(loop bdepth block (add1 fdepth) (cdr filled)))
(if (block-row-with-line-collision? (car block) x (car filled))
(loop (add1 bdepth) (cdr block) (add1 fdepth) (cdr filled)))))))
(module+ test
(define sample-filled-lines
(define sample-filled-lines3
;; 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))
(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)))
;; 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)
;; 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))))
;;......................................................... 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)
(define handled? (super on-subwindow-char receiver event))
(if handled?
#t ; one of the system events
(on-tetris-event 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 frame
(new tetris-frame% [label "Tetris"] [width window-width] [height window-height]))
;; The current block and its x, y position on the playing field
(define-values (current-block block-x block-y) (values #f 0 0))
(define filled-lines '())
;; Display the playing field. Currently, the current block is shown at its
;; X,Y location.
(define (on-tetris-paint canvas dc)
(send dc clear)
(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)))
;; 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 canvas (new canvas% [parent frame]
[min-width window-width]
[min-height window-height]
[stretchable-width #f]
[stretchable-height #f]
[paint-callback on-tetris-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))
(send canvas refresh)))
;; Timer invokes `on-tetris-tick` periodically. Changing the interval makes
;; the pieces fall slower or faster.
(define timer (new timer% [notify-callback on-tetris-tick] [interval 500]))
(define block-count -1)
;; Create a new block and place it a the top of the field. For now, this
;; function just rotates through all blocks, but in the real game, blocks will
;; be randomly selected.
(define (spawn-new-block)
(when current-block
(set! filled-lines (merge-block current-block block-x block-y filled-lines)))
(set! block-count (add1 block-count))
(set! current-block (list-ref
(modulo block-count (length all-blocks))))
(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 canvas 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))
; rotating the block would make it collide, don't change it
((block-collision? candidate block-x block-y filled-lines)
;; rotating the block would make it go below the field bottom, don't
;; change it.
((>= (+ block-y max-y) field-height)
(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))))
(define (start-game)
(set! filled-lines '())
(set! current-block #f)
(send canvas focus)
(send frame show #t)
(send frame show #t))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.