;; 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
(require (planet dvanhorn/typed-student/advanced)
         (planet dvanhorn/typed-student/world))
(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]))
(define-type-alias Block block)

;; 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]))
(define-type-alias Tetra tetra)

;; 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]))
(define-type-alias World world)

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

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

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

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

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

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

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

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

(: blocks-count (BSet -> Number))
;; 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 : Block] [n : Number]) (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 : Block] [n : Number]) (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 : Block] [n : Number]) (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]) (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]) (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))

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

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

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


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