Skip to content

Instantly share code, notes, and snippets.

@seipy

seipy/tetris-4.rkt

Forked from alex-hhh/tetris-4.rkt
Created September 14, 2021 13:32
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save seipy/d0b2a7f7d1e9c11257bc84f54e4507aa to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save seipy/d0b2a7f7d1e9c11257bc84f54e4507aa to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. @alex-hhh alex-hhh revised this gist Mar 7, 2020. 1 changed file with 1 addition and 1 deletion.
    2 changes: 1 addition & 1 deletion tetris-4.rkt
    View file
    Original file line number Diff line number Diff line change
    @@ -1,4 +1,4 @@
    ;; A tetris game -- partial implementation, part 3
    ;; A tetris game -- partial implementation, part 4

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

  2. @alex-hhh alex-hhh created this gist Mar 7, 2020.
    708 changes: 708 additions & 0 deletions tetris-4.rkt
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,708 @@
    ;; A tetris game -- partial implementation, part 3

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


    ;;......................................................... 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))
    (spawn-new-block))

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

    ;; 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! filled-lines (remove-full-lines filled-lines)))
    (define candidate (random (length all-blocks)))
    (set! current-block (list-ref all-blocks candidate))
    (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))

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

    (define (start-game)
    (set! filled-lines '())
    (set! current-block #f)
    (spawn-new-block)
    (send canvas focus)
    (send frame show #t)
    (send frame show #t))

    (start-game)