(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)))) ;; tetra-rotate-ccw : Tetra -> Tetra ;; Rotate the tetra 90 degrees counterclockwise around its center. (define (tetra-rotate-ccw tetra) (make-tetra (tetra-center tetra) (blocks-rotate-ccw (tetra-center tetra) (tetra-blocks tetra)))) ;; tetra-rotate-cw : Tetra -> Tetra ;; Rotate the tetra 90 degrees clockwise around its center. (define (tetra-rotate-cw tetra) (make-tetra (tetra-center tetra) (blocks-rotate-cw (tetra-center tetra) (tetra-blocks tetra)))) ;; tetra-overlaps-blocks? : Tetra Blocks -> Boolean ;; Is the tetra on any of the blocks? (define (tetra-overlaps-blocks? t bs) (not (empty? (blocks-intersect (tetra-blocks t) bs)))) (define (tetra-change-color t c) (make-tetra (tetra-center t) (blocks-change-color (tetra-blocks t) c))) (define (build-tetra-blocks color xc yc x1 y1 x2 y2 x3 y3 x4 y4) (tetra-move 3 0 (make-tetra (make-posn xc yc) (list (make-block x1 y1 color) (make-block x2 y2 color) (make-block x3 y3 color) (make-block x4 y4 color))))) ;; Bogus centers (define tetras (list (build-tetra-blocks 'green 1/2 -3/2 0 -1 0 -2 1 -1 1 -2) (build-tetra-blocks 'blue 1 -1 0 -1 1 -1 2 -1 3 -1) (build-tetra-blocks 'purple 1 -1 0 -1 1 -1 2 -1 2 -2) (build-tetra-blocks 'cyan 1 -1 0 -1 1 -1 2 -1 0 -2) (build-tetra-blocks 'orange 1 -1 0 -1 1 -1 2 -1 1 -2) (build-tetra-blocks 'red 1 -1 0 -1 1 -1 1 -2 2 -2) (build-tetra-blocks 'pink 1 -1 0 -2 1 -2 1 -1 2 -1) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Worlds ;; touchdown : World -> World ;; Add the current tetra's blocks onto the world's block list, ;; and create a new tetra. (define (touchdown w) (make-world (list-pick-random tetras) (eliminate-full-rows (blocks-union (tetra-blocks (world-tetra w)) (world-blocks w))))) ;; world-jump-down : World -> World ;; Take the current tetra and move it down until it lands. (define (world-jump-down w) (cond [(landed? w) w] [else (world-jump-down (make-world (tetra-move 0 1 (world-tetra w)) (world-blocks w)))])) ;; landed-on-blocks? : World -> Boolean ;; Has the current tetra landed on blocks? ;; I.e., if we move the tetra down 1, will it touch any existing blocks? (define (landed-on-blocks? w) (tetra-overlaps-blocks? (tetra-move 0 1 (world-tetra w)) (world-blocks w))) ;; landed-on-floor? : World -> Boolean ;; Has the current tetra landed on the floor? (define (landed-on-floor? w) (= (blocks-max-y (tetra-blocks (world-tetra w))) (sub1 board-height))) ;; landed? : World -> Boolean ;; Has the current tetra landed? (define (landed? w) (or (landed-on-blocks? w) (landed-on-floor? w))) ;; next-world : World -> World ;; Step the world, either touchdown or move the tetra down on step. (define (next-world w) (cond [(blocks-overflow? (world-blocks w)) (begin (printf "Game over\n") #f)] [(landed? w) (touchdown w)] [else (make-world (tetra-move 0 1 (world-tetra w)) (world-blocks w))])) ;; try-new-tetra : World Tetra -> World ;; Make a world with the new tetra *IF* if doesn't lie on top of some other ;; block or lie off the board. Otherwise, no change. (define (try-new-tetra w new-tetra) (cond [(or (< (blocks-min-x (tetra-blocks new-tetra)) 0) (>= (blocks-max-x (tetra-blocks new-tetra)) board-width) (tetra-overlaps-blocks? new-tetra (world-blocks w))) w] [else (make-world new-tetra (world-blocks w))])) ;; world-move : Number Number World -> World ;; Move the Tetra by the given X & Y displacement, but only if you can. ;; Otherwise stay put. (define (world-move dx dy w) (try-new-tetra w (tetra-move dx dy (world-tetra w)))) ;; world-rotate-ccw : World -> World ;; Rotate the Tetra 90 degrees counterclockwise, but only if you can. ;; Otherwise stay put. (define (world-rotate-ccw w) (try-new-tetra w (tetra-rotate-ccw (world-tetra w)))) ;; world-rotate-cw : World -> World ;; Rotate the Tetra 90 degrees clockwise, but only if you can. ;; Otherwise stay put. (define (world-rotate-cw w) (try-new-tetra w (tetra-rotate-cw (world-tetra w)))) ;; ghost-blocks : World -> Blocks ;; Gray blocks representing where the current tetra would land. (define (ghost-blocks w) (tetra-blocks (tetra-change-color (world-tetra (world-jump-down w)) 'gray))) (define (world-key-move w) (cond ((keyboard-keypressed? 'LEFT) (world-move -1 0 w)) ((keyboard-keypressed? 'RIGHT) (world-move 1 0 w)) ((keyboard-keypressed? 'DOWN) (world-jump-down w)) ((keyboard-keypressed? 'A) (world-rotate-ccw w)) ((keyboard-keypressed? 'S) (world-rotate-cw w)) (else w)) #; (cond [(and (symbol? k) (eq? k 'left)) (world-move -1 0 w)] [(and (symbol? k) (eq? k 'right)) (world-move 1 0 w)] [(and (symbol? k) (eq? k 'down)) (world-jump-down w)] [(and (char? k) (char=? k #\a)) (world-rotate-ccw w)] [(and (char? k) (char=? k #\s)) (world-rotate-cw w)] [else w])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Aux (define (list-pick-random ls) (list-ref ls (random (length ls)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Visualization ;; Visualize whirled peas ;; World -> Image (define (world->image w buffer) (for-each (lambda (b) (draw-block b buffer)) (append (tetra-blocks (world-tetra w)) (ghost-blocks w) (world-blocks w)))) #; (define (blocks->image bs) (foldr (lambda (b img) (cond [(<= 0 (block-y b)) (place-block b img)] [else img])) (empty-scene (add1 (* board-width block-size)) (add1 (* board-height block-size))) bs)) (define (normal-color c) (case c ((green) (image-color 0 255 0)) ((blue) (image-color 0 0 255)) ((purple) (image-color 0 255 255)) ((cyan) (image-color 0 200 128)) ((orange) (image-color 200 80 0)) ((red) (image-color 255 0 0)) ((pink) (image-color 255 200 0)) (else (image-color 255 0 0)))) #| (build-tetra-blocks 'green 1/2 -3/2 0 -1 0 -2 1 -1 1 -2) (build-tetra-blocks 'blue 1 -1 0 -1 1 -1 2 -1 3 -1) (build-tetra-blocks 'purple 1 -1 0 -1 1 -1 2 -1 2 -2) (build-tetra-blocks 'cyan 1 -1 0 -1 1 -1 2 -1 0 -2) (build-tetra-blocks 'orange 1 -1 0 -1 1 -1 2 -1 1 -2) (build-tetra-blocks 'red 1 -1 0 -1 1 -1 1 -2 2 -2) (build-tetra-blocks 'pink 1 -1 0 -2 1 -2 1 -1 2 -1) |# (define (draw-block block buffer) (let* ((x1 (* (block-x block) block-size)) (y1 (* (block-y block) block-size)) (x2 (+ x1 block-size)) (y2 (+ y1 block-size))) (image-rectangle-fill buffer x1 y1 x2 y2 (normal-color (block-color block))) (image-rectangle buffer x1 y1 x2 y2 (image-color 0 0 0)))) ;; Visualizes a block. ;; Block -> Image #; (define (block->image b) (overlay (rectangle (add1 block-size) (add1 block-size) 'solid (block-color b)) (rectangle (add1 block-size) (add1 block-size) 'outline 'black))) ;; Block Scene -> Scene #; (define (place-block b scene) (place-image (block->image b) (+ (* (block-x b) block-size) (/ block-size 2)) (+ (* (block-y b) block-size) (/ block-size 2)) scene)) (define world0 (make-world (list-pick-random tetras) empty)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Big bang (define (play) (easy-init (* board-width block-size) (* board-height block-size) 16) (let ((world world0)) (game-loop (lambda () (set! world (next-world (world-key-move world))) (or (not world) (keyboard-keypressed? 'ESC))) (lambda (buffer) (when world (world->image world buffer))) (fps 10)))) (play) )