[plt-scheme] tetris

That's what we're hoping will happen here. Ever since
we started using the functional animation package, I
see students working on their programs after the
semester is over. Not too many, but a bunch.

-- Matthias




On Feb 27, 2008, at 4:15 AM, Benjamin L. Russell wrote:

> 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
>>
>
> _________________________________________________
>   For list-related administrative tasks:
>   http://list.cs.brown.edu/mailman/listinfo/plt-scheme