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

{-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 currenty 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-}
prettyShowBoard :: Board -> String
prettyShowBoard rs = unlines $ map prettyShowRow rs -- ++ "V: " ++ show (heuristics (Game rs V)) ++ " H: " ++ show (heuristics (Game rs H)) ++ "\n"

prettyShowRow :: Row -> [Char]
prettyShowRow fs = concat $ map prettyShowField fs

prettyShowField :: Field -> [Char]
prettyShowField (P x) = show x
prettyShowField E = "+"

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

isValidMove :: Game -> Pos -> Bool
isValidMove (Game b H) (r,c) = c >= 0 && c < width b - 1 && r >= 0 && r < height b && row b r !! c == E && row b r !! (c+1) == E
isValidMove (Game b V) (r,c) = isValidMove (Game (transpose b) H) (c,r)

{-H10.1.3-}
canMove :: Game -> Bool
canMove = not . null . validMoves

{-H10.1.4-}
updateBoard :: Board -> Pos -> Field -> Board
updateBoard rs (r,c) f = let (xs, (y:ys)) = splitAt r rs in xs ++ ((updateRow y c f): ys) 

updateRow :: Row -> Int -> Field -> Row
updateRow fs c f = let (xs, (y:ys)) = splitAt c fs in xs ++ (f:ys)

{-H10.1.5-}
playMove :: Game -> Pos -> Game
playMove (Game b H) (r,c)  = Game (updateBoard (updateBoard b (r,c) (P H)) (r,c+1) (P H)) V
playMove (Game b V) (r,c) = Game (updateBoard (updateBoard b (r,c) (P V)) (r+1,c) (P V)) H


{-H10.1.6-}
-- the first paramter of a strategy is an infite list of
-- random values between (0,1) (in case you wanna go wild with
-- probabilistic methods)
type Strategy = [Double] -> Game -> Pos

{-WETT-}
opponent :: Player -> Player
opponent H = V
opponent V = H

validPositions :: [Pos] -> Player -> [Pos]
validPositions ms H = nub $ ms ++ (map (\(r,c) -> (r,c+1)) ms)
validPositions ms V = nub $ ms ++ (map (\(r,c) -> (r+1,c)) ms)

validMoves :: Game -> [Pos]
validMoves (Game b H) = map fst . filter (\(_,m) -> m ==(E,E)) $ zip (allMoves $ Game b H) $ concat $ map(\fs -> zip fs $ tail fs) b
validMoves (Game b V) = map fst . filter (\(_,m) -> m ==(E,E)) $ zip (allMoves $ Game b V) $ concat . transpose $ map(\fs -> zip fs $ tail fs) $ transpose b

allMoves :: Game -> [Pos]
allMoves (Game b H) = [(r,c) | r <- [0..(height b - 1)], c <- [0..(width b - 2)]]
allMoves (Game b V) = [(r,c) | r <- [0..(height b - 2)], c <- [0..(width b - 1)]]

{-
Standard implementation of alpha-beta pruning that recieves a evaluation function and
a sort function to determine the order of looking at valid moves
-}
alphabeta :: [Double] -> ([Double] -> Game -> [Pos]) -> (Game -> Int) -> Game -> Int -> Int -> Int -> Bool -> (Int, Pos)
alphabeta _ _ e g 0 _ _ _ = (e g, (-1,-1)) -- depth limit reached
alphabeta rnds r e g d alpha beta m
  | not . canMove $ g = (e g, (-1,-1)) -- check if game has already ended
  | m = maximize rms (minBound, (-1,-1)) alpha beta
  | otherwise = minimize rms (maxBound, (-1,-1)) alpha beta
  where
    rms = r rnds g  -- sort valid moves randomly
    rems = drop (length rms) rnds -- remove used random numbers

    maximize [] best _ _ = best
    maximize (m:ms) (value, best) alpha beta
      | alpha >= beta = (value, best) -- beta cut-off
      | otherwise = maximize ms (if gt then (newValue, m) else (value, best)) (max alpha (if gt then newValue else value)) beta
      where
        gt = newValue > value
        (newValue, _) = alphabeta rems r e nextGame (d-1) alpha beta False
        nextGame = playMove g m
    minimize [] best _ _ = best
    minimize (m:ms) (value, best) alpha beta
        | alpha >= beta = (value, best) -- alpha cut-off
        | otherwise = minimize ms (if lt then (newValue, m) else (value, best)) alpha (min beta (if lt then newValue else value))
        where
          lt = newValue < value
          (newValue, _) = alphabeta rems r e nextGame (d-1) alpha beta True
          nextGame = playMove g m

{-
Opening table to save computational time in the beginning
There are four moves for each player that guarantee an additional future move 
-}
openingTable :: Player -> Int -> Int -> [Pos]
openingTable H h w = [(1,0),(h-2,w-2),(1,w-2),(h-2,0)]
openingTable V h w = [(0,w-2),(h-2,1),(0,1),(h-2,w-2)]

{-
Strategy that first checks if there are still valid moves from the opening table.
If not, the strategy uses the alpha-beta pruning implementation.
Usually, a random sort is used to determine the order in which the possible moves are analyzed.
The random sort seems to perform quite good against the AIs of other submissions.
A possible reason for that could be that the strategy does not focus on a specific area on the game board.
Moreover, the probabiltiy of a good move in the beginning of the randomly sorted collection of valid moves is relatively high.
As a result, computational time can be saved because alpha-beta pruning cuts off many possibilities.
However, if the the game does not look good, the strategy tries to adapt by using another sorting criterion.
Maybe there is still a chance of winning.
-}
alphabetaAI :: Strategy
alphabetaAI rnds (Game b p) 
  | not . null $ openings = head $ openings
  | otherwise = snd $ alphabeta rnds (if p == V && evaluate (Game b p) < 0 || p == H && evaluate (Game b p) < -6 then preferCenterSort else randomSort) evaluate (Game b p) 2 minBound maxBound True -- perform alpha-beta pruning with depth 2
  where
    openings = filter (isValidMove $ Game b p) $ openingTable p (height b) (width b)

christmasAI :: Strategy -- receives a game and plays a move for the next player
christmasAI = alphabetaAI

{-
Evaluation function counts the number of positions both player are able to put blocks on.
This is a meaningful measure for the evaluation of the current game.
Moreover, it counts the possible moves each player has.
More moves means more possibilites which is usually an advantage.
-}
evaluate :: Game  -> Int
evaluate (Game b p) = 2 * (pPos - opPos) + length pMoves - length opMoves
  where
    pPos = length $ validPositions pMoves p
    opPos = length $ validPositions opMoves op
    pMoves = validMoves $ Game b p
    opMoves = validMoves $ Game b op
    op = opponent p

-- Sort valid moves by using the provided random numbers
randomSort :: [Double] -> Game -> [Pos]
randomSort rnds g = let ms = validMoves g in map fst $ sortBy (comparing snd) $ zip ms rnds

{-
Sort valid moves by looking at the coordinates.
Moves that are in the center (horizontally) and close to the borders (vertically) are prefered for the H player.
Moves that are in the center (vertically) and close to the borders (horizontally) are prefered for the V player.
Moreover, moves that are in even rows (for V player) or columns (for H player) are prefered.
This sorting strategy analyzes more promising moves earlier but still tries to move towards the center of the game board.
-}
preferCenterSort :: [Double] -> Game -> [Pos]
preferCenterSort _ g@(Game b V) = let w = width b in let h = height b in sortBy (comparing (\(r,c) -> ((w `div` 2) * ((h-1) `div` 2 + 1)) * (r `mod` 2) + (w `div` 2 - dis c w) * (dis r (h - 1) + 1))) $ validMoves g
preferCenterSort _ g@(Game b H) = let w = width b in let h = height b in sortBy (comparing (\(r,c) -> ((h `div` 2) * ((w-1) `div` 2 + 1)) * (c `mod` 2) + (h `div` 2 - dis r h) * (dis c (w - 1) + 1))) $ validMoves g

-- Distance to the borders of the game board
dis :: Int -> Int -> Int
dis v m = min v (m - 1 - v)
{-TTEW-}

-- Alternative strategies to test implementation
firstAI :: Strategy
firstAI _ g = head . validMoves $ g

-- Fills every second column (V)/row (H) from top to bottom (V)/from left to right (H)
-- and starts at the left (V)/at the top (H)
simpleAI :: Strategy
simpleAI _ g = head . sortBy (comparing $ val g) $ validMoves g
  where
    val (Game b H) (r,c) = let h = height b in let w = width b in w * h * ((r + 1) `mod` 2) + w * r - c
    val (Game b V) (r,c) = val (Game b H) (c,r)

-- Sets blocks every second column (V)/row (H) from left to right (V)/from top to bottom (H)
-- and starts at the top (V)/at the left (H)
simpleAI2 :: Strategy
simpleAI2 _ g = head . sortBy (comparing $ val g) $ validMoves g
  where
    val (Game b V) (r,c) = let h = height b in let w = width b in w * h * ((c) `mod ` 2) + w * r - c
    val (Game b H) (r,c) = val (Game b V) (c,r)

randomAI :: Strategy
randomAI (r:rs) g = let ms = validMoves g in head $ randomSort rs g

{-H10.1.7-}
play :: [[Double]] -> Int -> Strategy -> Strategy -> ([Board],Player)
play rss dim sv sh = (reverse bs, w)
  where
    (bs,w) = go rss (Game (createEmptyBoard dim) V) ([],V)
    go (rs:rss) (Game b p) (xs,_) 
      | not (canMove (Game b p)) || not (isValidMove (Game b p) nextMove) = (xs, o)
      | otherwise = go rss (Game nextBoard o) (nextBoard:xs, V)
      where
        o = opponent p
        strategy = if p == V then sv else sh
        nextMove = strategy rs (Game b p)
        Game nextBoard _ = playMove (Game b p) nextMove

createEmptyBoard :: Int -> Board
createEmptyBoard dim = [[E | c <- [1..dim]] | r <- [1..dim]]

-- 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"