Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Tetris Game -- First Interactive Application
;; A tetris game -- partial implementation, part 1
;; Copyright (c) 2020 Alex Harsányi (AlexHarsanyi@gmail.com)
;; 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)))
;;......................................................... 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 (field-width field-height) (values 12 24))
(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 L-Block 0 0))
;; Display the playing field. Currently, the current block is shown at its
;; X,Y location.
(define (on-tetris-paint canvas dc)
(send dc clear)
(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 Y position is larger than the
;; field height, it creates a new block.
(define (on-tetris-tick)
(if (< block-y field-height)
(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]))
(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)
(set! block-count (add1 block-count))
(set! current-block (list-ref
all-blocks
(modulo block-count (length all-blocks))))
(set! block-y 0)
(set! block-x (exact-truncate (- (/ field-width 2) 2))))
;; 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)
(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)
(set! current-block (rotate-function current-block)))
(define (on-left-right-move direction)
(set! block-x (direction block-x)))
(define (start-game)
(spawn-new-block)
(send canvas focus)
(send frame show #t)
(send frame show #t))
(start-game)
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.