[plt-scheme] tetris

This reminds me of the project "Schemetris" I wrote
with one classmate as a final project for a Computer
Science class back at Yale in 1994.  That one was
written in MIT Scheme, though, and at least some of
the libraries were pre-provided.

I slept only 3 hours per day for 3 days to get it
done.  My classmate gave me the function
specifications, and I wrote the functions.  The
project was a great success, and motivated me to
return to studying Scheme over a decade afterward.

Benjamin L. Russell

--- Jon Rafkind <workmin at ccs.neu.edu> wrote:

> I thought the recently uploaded tetris game to
> planet was fun so I
> converted it to use the Allegro package instead of
> htdp. Theres not
> really much of a point and its not like it runs
> better or anything, but
> it was good to compare htdp's functional style with
> Allegro's mostly
> imperative style. It probably won't work too well in
> osx.
> 
> Tetris on planet:
>
http://planet.plt-scheme.org/display.ss?package=tetris.plt;owner=dvanhorn
> 
> Code attached if you want to try it.
> > (module tetris2 mzscheme
> 
> 	(require (planet "util.ss" ("kazzmir"
> "allegro.plt")))
> 	(require (prefix keyboard- (planet "keyboard.ss"
> ("kazzmir" "allegro.plt"))))
> 	(require (prefix image- (planet "image.ss"
> ("kazzmir" "allegro.plt"))))
> 	(require (lib "list.ss"))
> 
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Defined constants
> (define-struct posn (x y))
> 
> (define block-size   20)  ;; in Pixels
> (define board-width  10)  ;; in Blocks
> (define board-height 20)
> 
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Data Definitions
> 
> ;; A Block is a (make-block Number Number Color)
> (define-struct block (x y color))
> 
> ;; A Tetra is a (make-tetra Posn BSet)
> ;; The center point is the point around which the
> tetra rotates
> ;; when it is rotated.
> (define-struct tetra (center blocks))
> 
> ;; A Set of Blocks (BSet) is one of:
> ;; - empty
> ;; - (cons Block BSet)
> ;; Order does not matter.  Repetitions are NOT
> allowed.
> 
> ;; A World is a (make-world Tetra BSet)
> (define-struct world (tetra blocks))
> 
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Blocks
> 
> ;; block=? : Block Block -> Boolean
> ;; Determines if two blocks are the same (ignoring
> color).
> (define (block=? b1 b2)
>   (and (= (block-x b1) (block-x b2))
>        (= (block-y b1) (block-y b2))))
> 
> ;; block-move : Number Number Block -> Block
> (define (block-move dx dy b)
>   (make-block (+ dx (block-x b))
>               (+ dy (block-y b))
>               (block-color b)))
> 
> ;; block-rotate-ccw : Posn Block -> Block
> ;; Rotate the block 90 counterclockwise around the
> posn.
> (define (block-rotate-ccw c b)
>   (make-block (+ (posn-x c)
> 		 (- (posn-y c)
> 		    (block-y b)))
> 	      (+ (posn-y c)
> 		 (- (block-x b)
> 		    (posn-x c)))
> 	      (block-color b)))
> 
> ;; block-rotate-cw : Posn Block -> Block
> ;; Rotate the block 90 clockwise around the posn.
> (define (block-rotate-cw c b)
>   (block-rotate-ccw c (block-rotate-ccw c
> (block-rotate-ccw c b))))
> 
> 
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Sets of blocks
> 
> ;; blocks-contains? : BSet Block -> Boolean
> (define (blocks-contains? bs b)
>   (ormap (lambda (c) (block=? b c)) bs))
> 
> ;; blocks-subset? : BSet BSet -> Boolean
> ;; is every element in bs1 also in bs2?
> (define (blocks-subset? bs1 bs2)
>   (andmap (lambda (b) (blocks-contains? bs2 b))
> bs1))
> 
> ;; blocks=? : BSet BSet -> Boolean
> (define (blocks=? bs1 bs2)
>    (and (blocks-subset? bs1 bs2) 
>         (blocks-subset? bs2 bs1)))
> 
> ;; blocks-intersect : BSet BSet -> BSet
> ;; Return the set of blocks that appear in both
> sets.
> (define (blocks-intersect bs1 bs2)
>   (filter (lambda (b) (blocks-contains? bs2 b))
> bs1))
> 
> ;; blocks-union : BSet BSet -> BSet
> ;; Union the two sets of blocks.
> (define (blocks-union bs1 bs2)
>   (foldr (lambda (b bs)
>            (cond [(blocks-contains? bs b) bs]
>                  [else (cons b bs)]))
>          bs2
>          bs1))
> 
> ;; blocks-counts : BSet -> Nat
> ;; Return the number of blocks in the set.
> (define (blocks-count bs)
>   (length bs))  ;; No duplicates, cardinality =
> length.
> 
> ;; blocks-max-y : BSet -> Number
> ;; Compute the maximum y coordinate;
> ;; if set is empty, return 0, the coord of the
> board's top edge.
> (define (blocks-max-y bs)
>   (foldr (lambda (b n) (max (block-y b) n)) 0 bs))
>             
> ;; blocks-min-x : BSet -> Number
> ;; Compute the minimum x coordinate;
> ;; if set is empty, return the coord of the board's
> right edge.
> (define (blocks-min-x bs)
>   (foldr (lambda (b n) (min (block-x b) n))
> board-width bs))
> 
> ;; blocks-max-x : BSet -> Number
> ;; Compute the maximum x coordinate;
> ;; if set is empty, return 0, the coord of the
> board's left edge.
> (define (blocks-max-x bs)
>   (foldr (lambda (b n) (max (block-x b) n)) 0 bs))
> 
> ;; blocks-move : Number Number BSet -> BSet
> ;; Move each block by the given X & Y displacement.
> (define (blocks-move dx dy bs)
>   (map (lambda (b) (block-move dx dy b)) bs))
> 
> ;; blocks-rotate-ccw : Posn BSet -> BSet
> ;; Rotate the blocks 90 counterclockwise around the
> posn.
> (define (blocks-rotate-ccw c bs)
>   (map (lambda (b) (block-rotate-ccw c b)) bs))
> 
> ;; blocks-rotate-cw : Posn BSet -> BSet
> ;; Rotate the blocks 90 clockwise around the posn.
> (define (blocks-rotate-cw c bs)
>   (map (lambda (b) (block-rotate-cw c b)) bs))
> 
> ;; blocks-change-color : BSet Color -> BSet
> (define (blocks-change-color bs c)
>   (map (lambda (b) (make-block (block-x b)
>                                (block-y b)
>                                c))
>        bs))
> 
> ;; blocks-overflow? : BSet -> Boolean
> ;; Have any of the blocks reach over the top of the
> board?
> (define (blocks-overflow? bs)
>   (ormap (lambda (b) (<= (block-y b) 0)) bs))
> 
> ;; blocks-row : BSet Number -> BSet
> ;; Return the set of blocks in the given row.
> (define (blocks-row bs i)
>   (filter (lambda (b) (= i (block-y b))) bs))
> 
> ;; full-row? : BSet Nat -> Boolean
> ;; Are there a full row of blocks at the given row
> in the set.
> (define (full-row? bs i)
>   (= board-width (blocks-count (blocks-row bs i))))
> 
> ;; eliminate-full-rows : BSet -> BSet
> ;; Eliminate all full rows and shift down
> appropriately.
> (define (eliminate-full-rows bs)
>   (define (elim-row i offset)
>             (cond [(< i 0) empty]
>                   [(full-row? bs i)   (elim-row
> (sub1 i) (add1 offset))]
>                   [else (blocks-union (elim-row
> (sub1 i) offset)
>                                       (blocks-move 0
> offset (blocks-row bs i)))]))
>     (elim-row board-height 0))
> 
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Tetras
> 
> ;; tetra-move : Number Number Tetra -> Tetra
> ;; Move the Tetra by the given X & Y displacement.
> (define (tetra-move dx dy t)
>   (make-tetra (make-posn (+ dx (posn-x (tetra-center
> t)))
> 			 (+ dy (posn-y (tetra-center t))))
> 	      (blocks-move dx dy (tetra-blocks t))))
> 
> 
=== message truncated ===>
_________________________________________________
>   For list-related administrative tasks:
>  
> http://list.cs.brown.edu/mailman/listinfo/plt-scheme
>