;; Tetris.

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

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

#lang typed-scheme
(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 : Number] [y : Number] [color : 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 : Posn] [blocks : BSet]))

;; A Set of Blocks (BSet) is one of:
;; - empty
;; - (cons Block BSet)
;; Order does not matter.  Repetitions are NOT allowed.
(define-type-alias BSet (Listof Block))

;; A World is a (make-world Tetra BSet)
(define-struct: World ([tetra : Tetra] [blocks : BSet]))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TypedScheme and Student language duct tape

(require/opaque-type Image image? lang/htdp-advanced)
(require-typed-struct posn ([x : Number] [y : Number]) lang/htdp-advanced)
(define-type-alias Posn posn)
(define-type-alias Scene Image)
(define-type-alias Color Symbol)
(define-type-alias Mode Symbol)

(define empty null)
(define empty? null?)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TypedScheme and World teachpack duct tape
;; (has to appear after definition of World.)

;(require/opaque-type KeyEvent key-event? htdp/world)
(define-type-alias KeyEvent (U Symbol Char))

(require/typed key=? (KeyEvent KeyEvent -> Boolean) htdp/world)
(require/typed empty-scene (Number Number -> Image) htdp/world)
(require/typed place-image (Image Number Number Image -> Image) htdp/world)
(require/typed overlay (Image Image -> Image) htdp/world)
(require/typed rectangle (Number Number Mode Color -> Image) htdp/world)

(require/typed big-bang (Number Number Number World -> Boolean) htdp/world)
(require/typed stop-when ((World -> Boolean) -> Boolean) htdp/world)
(require/typed on-tick-event ((World -> World) -> Boolean) htdp/world)
(require/typed on-redraw ((World -> Scene) -> Boolean) htdp/world)
(require/typed on-key-event ((World KeyEvent -> World) -> Boolean) htdp/world)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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))
;; Move the given block by (dx,dy).
(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)
|#
;; Rotate the block 90 counterclockwise around the posn.
(: block-rotate-ccw  (Posn Block -> Block))
(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]) (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 : Block]) (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 : Block]) (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 : Block] [bs : BSet])
           (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 -> Number))
;; 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 : Block] [n : Number]) (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 : Block] [n : Number]) (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 : Block] [n : Number]) (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]) (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]) (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]) (block-rotate-cw c b)) bs))

(: blocks-change-color (BSet Color -> BSet))
;; Change the color of a set of blocks.
(define (blocks-change-color bs c)
  (map (lambda: ([b : Block]) (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]) (<= (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 : Block]) (= 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 Number -> 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)
  (letrec: ((elim-row : (Number Number -> BSet)
             (lambda (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)))

;; letrec: is used here instead of local, which is not supported by Typed Scheme.


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

(: build-tetra-blocks (Color Number Number Number Number Number
                             Number Number Number Number Number -> Tetra))
(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)))))

(: tetras (Listof Tetra))
;; 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

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


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

(: world->image (World -> Scene))
;; Visualize whirled peas
(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))))
  
(: blocks->image (BSet -> Scene))
(define (blocks->image bs)
  (foldr (lambda: ([b : Block] [img : Image])
           (cond [(<= 0 (Block-y b)) (place-block b img)]
                 [else img]))
         (empty-scene (add1 (* board-width block-size)) 
                      (add1 (* board-height block-size)))
         bs))

(: block->image (Block -> Image))
;; Visualizes a block.
(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)))

(: place-block (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 : World]) (blocks-overflow? (World-blocks w))))
(on-tick-event next-world)
(on-redraw world->image)
(on-key-event world-key-move)