;; Tetris.

;; Copyright (c) 2007, 2008 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; (at dvanhorn (dot ccs neu edu))

;; This program has only partial test coverage.

#lang scheme
(require htdp/testing)
(require htdp/world)
(require lang/htdp-advanced)
(provide (all-defined-out))
         
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defined constants

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

"Identical blocks are equal."
(check-expect (block=? (make-block 0 0 'black)
                       (make-block 0 0 'black))
              true)
   
"Identical (modulo color) blocks are equal."
(check-expect (block=? (make-block 0 0 'black)
                       (make-block 0 0 'red))
              true)

"Blocks with different coordinates are different."
(check-expect (block=? (make-block 0 1 'black)
                       (make-block 0 0 'black))
              false)
(check-expect (block=? (make-block 0 0 'black)
                       (make-block 0 1 'black))
              false)

;; 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 move."
(check-expect (block=? (block-move 0 0 (make-block 0 0 'black))
                       (make-block 0 0 'black))
              true)
(check-expect (block=? (block-move 0 1 (make-block 0 0 'black))
                       (make-block 0 1 'black))
              true)

;; 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
;; Determine if the block is in the set of blocks.
(define (blocks-contains? bs b)
  (ormap (lambda (c) (block=? b c)) bs))

"Block set membership."
(check-expect (blocks-contains? empty (make-block 0 0 'black))
              false)
(check-expect (blocks-contains? (list (make-block 0 0 'black))
                                (make-block 0 0 'black))
              true)
(check-expect (blocks-contains? (list (make-block 0 1 'black))
                                (make-block 0 0 'black))
              false)

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

"Block set containment."
(check-expect (blocks-subset? empty empty)
              true)
(check-expect (blocks-subset? empty (list (make-block 0 0 'black)))
              true)
(check-expect (blocks-subset? (list (make-block 0 0 'black))
                              (list (make-block 0 0 'black)))
              true)

;; blocks=? : BSet BSet -> Boolean
;; Determine if given sets of blocks are equal.
(define (blocks=? bs1 bs2)
   (and (blocks-subset? bs1 bs2) 
        (blocks-subset? bs2 bs1)))

"Block set equality."
(check-expect (blocks=? (list (make-block 0 0 'black))
                        (list (make-block 0 0 'black)))
              true)
(check-expect (blocks=? (list (make-block 0 0 'black))
                        (list (make-block 0 1 'black)))
              false)

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

"Block set intersection."
(check-expect (blocks=? (blocks-intersect empty empty) 
                        empty)
              true)
(check-expect (blocks=? (blocks-intersect empty (list (make-block 0 0 'black)))
                        empty)
              true)
(check-expect (blocks=? (blocks-intersect (list (make-block 0 0 'black)) empty) 
                        empty)
              true)
(check-expect (blocks=? (blocks-intersect (list (make-block 0 0 'black))
                                          (list (make-block 0 0 'black)))
                        (list (make-block 0 0 'black)))
              true)

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

"Block set union."
(check-expect (blocks=? (blocks-union empty empty) empty)
              true)
(check-expect (blocks=? (blocks-union empty (list (make-block 0 0 'black)))
                        (list (make-block 0 0 'black)))
              true)
(check-expect (blocks=? (blocks-union (list (make-block 0 0 'black)) empty) 
                        (list (make-block 0 0 'black)))
              true)
(check-expect (blocks=? (blocks-union (list (make-block 0 0 'black))
                                      (list (make-block 0 0 'black)))
                        (list (make-block 0 0 'black)))
              true)
(check-expect (blocks=? (blocks-union (list (make-block 0 0 'black))
                                      (list (make-block 0 1 'black)))
                        (list (make-block 0 0 'black)
                              (make-block 0 1 'black)))
              true)

;; blocks-count : BSet -> Nat
;; Return the number of blocks in the set.
(define (blocks-count bs)
  (length bs))  ;; No duplicates, cardinality = length.

"Block set cardinality."
(check-expect (blocks-count empty) 0)
(check-expect (blocks-count (list (make-block 0 0 'black))) 1)
(check-expect (blocks-count (blocks-union (list (make-block 0 0 'black))
                                          (list (make-block 0 0 'black))))
              1)
(check-expect (blocks-count (blocks-union (list (make-block 0 0 'black))
                                          (list (make-block 1 1 'black))))
              2)

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

"Block set maximal y-coordinate."
(check-expect (blocks-max-y empty) 0)
(check-expect (blocks-max-y (list (make-block 0 1 'black))) 1)
(check-expect (blocks-max-y (list (make-block 1 0 'black))) 0)

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

"Block set minimal x-coordinate."
(check-expect (blocks-min-x empty) board-width)
(check-expect (blocks-min-x (list (make-block 0 1 'black))) 0)
(check-expect (blocks-min-x (list (make-block 1 0 'black))) 1)

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

"Block set maximal x-coordinate."
(check-expect (blocks-max-x empty) 0)
(check-expect (blocks-max-x (list (make-block 0 1 'black))) 0)
(check-expect (blocks-max-x (list (make-block 1 0 'black))) 1)

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

"Block set move."
(check-expect (blocks=? (blocks-move 0 0 empty) empty)
              true)
(check-expect (blocks=? (blocks-move 0 0 (list (make-block 0 0 'black)))
                        (list (make-block 0 0 'black)))
              true)
(check-expect (blocks=? (blocks-move 1 1 (list (make-block 0 0 'black)))
                        (list (make-block 1 1 'black)))
              true)

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

"Block overflow."
(check-expect (blocks-overflow? empty) 
              false)
(check-expect (blocks-overflow? (list (make-block 0 0 'black))) 
              true)
(check-expect (blocks-overflow? (list (make-block 0 1 'black))) 
              false)

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

"Block set row selection."
(check-expect (blocks=? (blocks-row empty 0) empty) 
              true)
(check-expect (blocks=? (blocks-row (list (make-block 0 0 'black)) 1) empty) 
              true)
(check-expect (blocks=? (blocks-row (list (make-block 0 0 'black)) 0)
                        (list (make-block 0 0 'black)))
              true)
    
;; 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))))

"Full row."
(check-expect (full-row? empty 0) false)
             
;; eliminate-full-rows : BSet -> BSet
;; Eliminate all full rows and shift down appropriately.
(define (eliminate-full-rows bs)
  (local [(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 BSet -> Boolean
;; Is the tetra on any of the blocks?
(define (tetra-overlaps-blocks? t bs)
  (not (empty? (blocks-intersect (tetra-blocks t) bs))))

;; tetra-change-color : Tetra Color -> Tetra
;; Change the color of the given tetra.
(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 [(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 -> BSet
;; 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)))

;; world-key-move : World KeyEvent -> World
;; Move the world according to the given key event.
(define (world-key-move w k)
  (cond [(key=? k 'left)
	 (world-move -1 0 w)]
	[(key=? k 'right)
	 (world-move 1 0 w)]
        [(key=? k 'down)
         (world-jump-down w)]
	[(key=? k #\a)
	 (world-rotate-ccw w)]
	[(key=? k #\s)
	 (world-rotate-cw w)]
	[else w]))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Aux

;; list-pick-random : [Listof a] -> a
;; Randomly pick an element from the list.
(define (list-pick-random ls)
  (list-ref ls (random (length ls))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Visualization

;; Visualize whirled peas
;; World -> Scene
(define (world->image w)
  (place-image (blocks->image (append (tetra-blocks (world-tetra w))
                                      (append (ghost-blocks w)
                                              (world-blocks w))))
	       0 0 
	       (empty-scene (* board-width block-size)
			    (* board-height block-size))))
  
;; BSet -> Scene
(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))

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

(generate-report)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Big bang

(big-bang (* board-width block-size)
          (* board-height block-size)
          (/ 1.0 5)
          world0)
(stop-when (lambda (w) (blocks-overflow? (world-blocks w))))
(on-tick-event next-world)
(on-redraw world->image)
(on-key-event world-key-move)