module Exercise_10 where
import Data.List
import Data.Tree
import Data.Ord
import Test.QuickCheck

{-H10.1-}
data Player = V | H -- vertical or horizontal player
  deriving (Eq,Show)
data Field = P Player | E -- a field is occupied by a player or empty
  deriving (Eq,Show)
type Row = [Field]
type Column = [Field]
type Board = [Row] -- we assume that boards are squares and encode a board row by row
data Game = Game Board Player -- stores the current board and player
  deriving (Eq,Show)

-- get a given row of a board
row :: Board -> Int -> Row
row = (!!)

-- get a given column of a board
column :: Board -> Int -> Column
column = row . transpose

-- width of a board
width :: Board -> Int
width [] = 0
width (x:xs) = length x

-- height of a board
height :: Board -> Int
height = length

{-H10.1.1-}
prettyPrintField :: Field -> String
prettyPrintField E = "+"
prettyPrintField (P player) = case player of
                                V -> "V"
                                H -> "H"
prettyPrintRow :: Row -> String
prettyPrintRow []  = ""
prettyPrintRow xs  = concatMap prettyPrintField xs

prettyShowBoard :: Board -> String
prettyShowBoard [] = ""
prettyShowBoard rs = aux rs
    where
        aux []     = ""
        aux [x]    = prettyPrintRow x ++ "\n"
        aux (r:rs) = prettyPrintRow r ++ "\n" ++ aux rs

{-H10.1.2-}
-- position on a board (row, column)
-- (0,0) corresponds to the top left corner
type Pos = (Int, Int)

posInRangeV :: Board -> Pos -> Bool
posInRangeV b pos = let x = snd  pos
                        y = fst  pos
                        w = width  b
                        h = height b
                    in
                        x >= 0 && x < w && y >= 0 && y < (h-1)

posInRangeH :: Board -> Pos -> Bool
posInRangeH b pos = let x = snd  pos
                        y = fst  pos
                        w = width  b
                        h = height b
                    in
                        x >= 0 && x < (w-1) && y >= 0 && y < h

posIsEmpty :: Board -> Pos -> Bool
posIsEmpty b pos = b !! fst pos !! snd pos == E

isValidMoveV :: Board -> Pos -> Bool
isValidMoveV b pos = posInRangeV b pos &&
                     posIsEmpty b pos && posIsEmpty b (fst pos + 1, snd pos)

isValidMoveH :: Board -> Pos -> Bool
isValidMoveH b pos = posInRangeH b pos && 
                     posIsEmpty b pos && posIsEmpty b (fst pos, snd pos + 1)

isValidMove :: Game -> Pos -> Bool
isValidMove (Game b p) pos
  | p == V = isValidMoveV b pos
  | p == H = isValidMoveH b pos

{-H10.1.3-}
canMove :: Game -> Bool
--canMove (Game b p) = any (map (isValidMove b) [(x,y) | x <- [0..(width b) - 1], y <- [0..(height b) - 1]])
canMove (Game b p) = let g = Game b p in
--    any (isValidMove g) [(x,y) | x <- [0..width b - 1], y <- [0..height b - 1]]
    any (isValidMove g) [(x,y) | x <- [0..height b - 1], y <- [0..width b - 1]]

{-H10.1.4-}
updateBoard :: Board -> Pos -> Field -> Board
updateBoard [] _ _ = []
--updateBoard rs pos val = snd $ unzip $ map aux $ zip [0..] rs
updateBoard rs pos val = map (snd . aux) (zip [0..] rs)
    where
        aux (i, r) = if i == fst pos
                     then let s = splitAt (snd pos) r in
                          (i, fst s ++ (val : tail (snd s)))
                     else (i, r)

{-H10.1.5-}
playMove :: Game -> Pos -> Game
playMove (Game b p) pos
  | p == V = Game (updateBoard (updateBoard b pos (P V)) (fst pos + 1, snd pos) (P V)) H
  | p == H = Game (updateBoard (updateBoard b pos (P H)) (fst pos, snd pos + 1) (P H)) V

{-H10.1.6-}
type TreeNode = Game
type TreeEdge = Pos

validMoves :: Game -> [Pos]
--canMove (Game b p) = let g = (Game b p) in
--    any (isValidMove g) [(x,y) | x <- [0..width b - 1], y <- [0..height b - 1]]
validMoves (Game b p) = let g = Game b p in
--    [(x,y) | x <- [0..width b - 1], y <- [0..height b - 1], isValidMove g (x,y)]
    [(x,y) | x <- [0..height b - 1], y <- [0..width b - 1], isValidMove g (x,y)]

isEmptyBoard :: Board -> Bool
isEmptyBoard b = all (posIsEmpty b) [(x,y) | x <- [0..height b - 1], y <- [0..width b - 1]]

buildGameTree :: Game -> Tree (Pos, Game)
buildGameTree g = unfoldTree buildNode ((-1,-1), g)
    where
        buildNode (pos, g') = ((pos, g'), [(p, playMove g' p) | p <- validMoves g'])

-- Simple heuristic: A move is good if it yields as few as possible followups
-- for the other player
heuristic :: Tree (Pos, Game) -> Int
heuristic (Node _ []) = 0
heuristic (Node _ ts) = length ts

-- Returns the child tree with the minimum heuristic value as specified by
-- the function above
hMin :: Tree (Pos, Game) -> Tree (Pos, Game)
hMin (Node x []) = Node x []
hMin t = snd $ minimumBy (comparing fst) (zip tmp (subForest t))
    where
        tmp = map heuristic (subForest t)

hMax :: Tree (Pos, Game) -> Tree (Pos, Game)
hMax (Node x []) = Node x []
hMax t = snd $ maximumBy (comparing fst) (zip tmp (subForest t))
    where
        tmp = map heuristic (subForest t)

--minimax :: Tree (Pos, Game) -> Pos
--minimax (game :< []) = 10
--minimax (_    :< children) =
--    maximum $ negate . minimax <$> children

negamax :: Tree (Pos, Game) -> Int -> Pos
negamax t depth 
  | depth == 0 || null (subForest t) = fst $ rootLabel t
  | otherwise = fst $ rootLabel $ hMin t -- TODO


-- the first parameter of a strategy is an infinite list of
-- random values between (0,1) (in case you wanna go wild with
-- probabilistic methods)
type Strategy = [Double] -> Game -> Pos

{-WETT-}
christmasAI :: Strategy -- receives a game and plays a move for the next player
christmasAI _ g = negamax (buildGameTree g) 4
{-TTEW-}

{-H10.1.7-}
play :: [[Double]] -> Int -> Strategy -> Strategy -> ([Board],Player)
play rss dim sv sh = let result = aux rss [start] in
                     (getBoards result, winner . getPlayer $ last result)
                     where
                         start = Game (replicate dim (replicate dim E)) V
                         winner p
                           | p == V = H
                           | p == H = V
                         getPlayer (Game _ p) = p
                         getBoard  (Game b _) = b
                         getBoards            = filter (/= getBoard start) . map (\g@(Game b _) -> b)
                         moveForPlayer p rs
                           | p == V = sv rs
                           | p == H = sh rs
                         aux xss acc
                           | null acc = acc
                           | not $ canMove (last acc) = acc
                           | let nextMove = moveForPlayer (getPlayer (last acc)) (head xss) (last acc), otherwise = if isValidMove (last acc) nextMove then aux (tail xss) (acc ++ [playMove (last acc) nextMove]) else acc


-- generates infinite list of values between (0,1)
genRandomZeroOne :: Gen [Double]
genRandomZeroOne = mapM (const $ choose (0::Double,1)) [1..]

-- plays a game and prints it to the console
playAndPrint :: Int -> Strategy -> Strategy -> IO ()
playAndPrint dim sh sv = do 
  rss <- generate $ mapM (const $ genRandomZeroOne) [1..]
  let (bs, w) = play rss dim sh sv
  putStr $ (unlines $ map prettyShowBoard bs) ++ "\nWinner: " ++ show w ++ "\n"