module Exercise_10 where
import Data.List
import Test.QuickCheck
--import Debug.Trace

{-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-}
printField E = '+'
printField (P V) = 'V'
printField (P H) = 'H'
prettyShowBoard :: Board -> String
{- kind of weird that we have a newline at the end, but no newline for empty -}
prettyShowBoard [] = ""
prettyShowBoard rows = (intercalate "\n" $ map (map printField) rows) ++ "\n"

{-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 rows H) (r, c) = c >= 0 && r >= 0
                                    && height rows > r 
                                    && width rows > c + 1 
                                    && let row = rows !! r in row !! c == E 
                                                              && row !! (c+1) == E

isValidMove (Game rows V) (r, c) = c >= 0 && r >= 0
                                    && height rows > r + 1
                                    && width rows > c 
                                    && rows !! r !! c == E 
                                    && rows !! (r+1) !! c == E

{-H10.1.3-}
canMove :: Game -> Bool
canMove (Game rows player) = any (isValidMove (Game rows player)) [(r, c) | r <- [0..((height rows)-1)], c <- [0..((width rows)-1)]]

{-H10.1.4-}
updateBoard :: Board -> Pos -> Field -> Board
updateBoard rows (r, c) f = newBoard
    where (upperRows, restRows) = splitAt r rows
          row = head restRows 
          bottomRows = drop 1 restRows
          (leftFields, restFields) = splitAt c row
          newRow = leftFields ++ (f:(tail restFields))
          newBoard = upperRows ++ (newRow:(tail restRows))

{-H10.1.5-}
secondPos (r, c) H = (r, c+1)
secondPos (r, c) V = (r+1, c)
otherPlayer H = V
otherPlayer V = H

playMove :: Game -> Pos -> Game
playMove (Game rows player) pos = Game (updateBoard (updateBoard rows pos (P player)) (secondPos pos player) (P player)) (otherPlayer player)

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

-- My strategy: a modified version of Alpha-Beta Pruning, where not only the 
-- depth of the tree is limited, but also the number of children of each node.
-- Instead of calling the recursion again for all possible moves, we partition
-- the possible moves to classes, and only go down the tree for the moves that 
-- are from the best classes available (Moves that domineer new squares first,
-- moves that are already domineered anyways last)
{-WETT-}
notE rows (r, c) = c < 0 || r < 0 || height rows <= r || width rows <= c || (rows !! r !! c) /= E 
posNotE game@(Game board player) pos = notE board pos && notE board (posAfter game pos)

posToSmallerSide (Game rows V) (r, c) = (r, c-1)
posToSmallerSide (Game rows H) (r, c) = (r-1, c)

posToBiggerSide (Game rows V) (r, c) = (r, c+1)
posToBiggerSide (Game rows H) (r, c) = (r+1, c)

posAfter (Game rows V) (r, c) = (r+1, c)
posAfter (Game rows H) (r, c) = (r, c+1)
posBefore (Game rows V) (r, c) = (r-1, c)
posBefore (Game rows H) (r, c) = (r, c-1)

-- partition moves heuristically to classes, from best to worst.
partitionMoves :: Game -> [Pos] -> ([Pos], [Pos], [Pos], [Pos], [Pos], [Pos])
partitionMoves game [] = ([], [], [], [], [], [])
partitionMoves game (move:moves) = 
    if smallDom then    -- one side domineered
        if bigDom then (move:nextDom2, nextDom1, nextHalfDom, nextNotDomed, nextPartDomed, nextRest) -- also other
        else (nextDom2, move:nextDom1, nextHalfDom, nextNotDomed, nextPartDomed, nextRest) -- just one side domed
    else    -- first side not domed
        if bigDom then (nextDom2, move:nextDom1, nextHalfDom, nextNotDomed, nextPartDomed, nextRest) -- other doms
        else    -- no side domineers
            if (bigFree && bigBigNotAllFree) || (smallFree && smallSmallNotAllFree) then (nextDom2, nextDom1, move:nextHalfDom, nextNotDomed, nextPartDomed, nextRest)
            else
                if bigFree || smallFree then (nextDom2, nextDom1, nextHalfDom, move:nextNotDomed, nextPartDomed, nextRest) -- move is completely free, not domineered at all
                else -- move is at least partially domineered
                    if not (smallNotE && bigNotE) then (nextDom2, nextDom1, nextHalfDom, nextNotDomed, move:nextPartDomed, nextRest) -- move is not completely domineered
                    else (nextDom2, nextDom1, nextHalfDom, nextNotDomed, nextPartDomed, move:nextRest) -- move is completely domineered (worst)
    where (nextDom2, nextDom1, nextHalfDom, nextNotDomed, nextPartDomed, nextRest) = partitionMoves game moves
          posSmall          = posToSmallerSide game move        -- the pos next to move
          posSmallSmall     = posToSmallerSide game posSmall    -- the pos two to the side
          posBig            = posToBiggerSide game move         -- the pos to the other side
          posBigBig         = posToBiggerSide game posBig       -- the pos two to the other side
          smallFree         = isValidMove game posSmall         -- two fields alongside are free
          smallSmallNotE    = posNotE game posSmallSmall        -- parallel,distant pos is not E
          bigFree           = isValidMove game posBig           -- two fields on other side free
          bigBigNotE        = posNotE game posBigBig            -- parallel, distant fields not E
          smallDom          = smallFree && smallSmallNotE       -- the side is domineered by move
          bigDom            = bigFree && bigBigNotE           -- other side domineered by move
          bigNotE           = posNotE game posBig               -- side is blocked/end
          smallNotE         = posNotE game posSmall             -- other side blocked/end
          bigBigNotAllFree  = not $ isValidMove game posBigBig
          smallSmallNotAllFree = not $ isValidMove game posSmallSmall

-- instead of doing extra work to ignore fields that are not really domineered (blocked for both)
-- I just count them for both players (this just happens naturaly)
-- TOO SLOW
-- fieldDomineered game@(Game board player) pos = notE board (posToSmallerSide game pos) && notE board (posToBiggerSide game pos)
-- countDomineeredFields game@(Game board player) = 
--     length [1 | r <- [0..(height board)-1], c <- [0..(width board)-1], fieldDomineered game (r,c)]

-- evaluateBoard (Game rows player) (freeV, freeH) | trace ("eval " ++ show player ++ " " ++ show ((length freeV) - (length freeH))) False = undefined
evaluateBoard (Game rows V) ([], freeH) = minBound :: Int -- it's V's turn but they can't play
evaluateBoard (Game rows H) (freeV, []) = maxBound :: Int -- it's H's turn but they can't play
evaluateBoard (Game rows V) (freeV, []) = maxBound :: Int -- V wins next turn
evaluateBoard (Game rows H) ([], freeH) = minBound :: Int -- H wins next turn
evaluateBoard game (freeV, freeH) = (length freeV) - (length freeH)

-- This seems to be a worse heuristic (loses to sister)
-- evaluateBoard game (freeV, freeH) = (countV freeV) - (countH freeH)
-- countV freeVMoves = length $ nub $ map (\(r, c) -> (r - (mod r 2), c)) freeVMoves
-- countH freeHMoves = length $ nub $ map (\(r, c) -> (r, c - (mod c 2))) freeHMoves

-- too slow!
-- evaluateBoard (Game rows player) freeMoves = (countDomineeredFields (Game rows V)) - (countDomineeredFields (Game rows H))

-- bring forward good moves, send backwards tested bad moves
-- updateFM game moves freeMoves = freeMoves
updateFM (Game rows V) moves (freeV, freeH) = newFree
    where rest = reverse $ filter (`notElem` moves) freeV
          newFree = (moves++rest, freeH)
updateFM (Game rows H) moves (freeV, freeH) = newFree
    where rest = reverse $ filter (`notElem` moves) freeH
          newFree = (freeV, moves++rest)

-- reached maximal search depth!
alphaBeta game 0 _a _b freeMoves = evaluateBoard game freeMoves
alphaBeta (Game rows V) depth a b ([], _) = minBound :: Int
alphaBeta (Game rows H) depth a b (_, []) = maxBound :: Int
alphaBeta game@(Game rows player) depth a b freeMoves = 
    alphaBetaChildren moves starterValue game depth a b orderedFreeMoves
    where moves = getMoves game freeMoves
          orderedFreeMoves = updateFM game moves freeMoves
          starterValue = if player == V then minBound :: Int else maxBound :: Int

-- V maximizes (a), H minimizes (b)
-- no possible moves!
alphaBetaChildren [] value (Game rows V) depth a b freeMoves = minBound :: Int -- worst value
alphaBetaChildren (move:moves) value game@(Game rows V) depth a b freeMoves  
    | a >= b = value
--    | a >= b = trace ("pruning! " ++ show a ++ " " ++ show b) value
    | otherwise = max newValue (alphaBetaChildren moves value (Game rows V) depth newA b freeMoves)
    where   newGame = playMove game move
            newFreeMoves = unfreeMove move freeMoves V
            newDepth = depth - 1
            newValue = max value (alphaBeta newGame newDepth a b newFreeMoves)
            newA = max a newValue

-- H minimizes
alphaBetaChildren [] value (Game rows H) depth a b freeMoves = maxBound :: Int -- worst value
alphaBetaChildren (move:moves) value game@(Game rows H) depth a b freeMoves  
    | a >= b = value
--    | a >= b = trace ("pruning! " ++ show a ++ " " ++ show b) value
    | otherwise = min newValue (alphaBetaChildren moves value (Game rows H) depth a newB freeMoves)
    where   newGame = playMove game move
            newFreeMoves = unfreeMove move freeMoves H
            newDepth = depth - 1
            newValue = min value (alphaBeta newGame newDepth a b newFreeMoves)
            newB = min b newValue

-- deletes a move (pos) from the lists of freeMoves
unfreeMove (r, c) (freeV, freeH) V = (newV, newH)
    where newV = delete (r-1, c) (delete (r+1, c) (delete (r, c) freeV))
          newH = delete (r+1, c-1) (delete (r+1, c) (delete (r, c-1) (delete (r, c) freeH)))
unfreeMove (r, c) (freeV, freeH) H = (newV, newH)
    where newH = delete (r, c-1) (delete (r, c+1) (delete (r, c) freeH))
          newV = delete (r-1, c+1) (delete (r, c+1) (delete (r-1, c) (delete (r, c) freeV)))

-- chose moves to evaluate out of all currently possible moves
getMoves game@(Game rows player) (freeV, freeH) = take 5 $
    dom2 ++ dom1 ++ domHalf ++ notDomed ++ partDomed ++ rest
    where   freeMoves = if player == V then freeV else freeH
            (dom2, dom1, domHalf, notDomed, partDomed, rest) = partitionMoves game freeMoves


maxOn f x y = if f x >= f y then x else y
minOn f x y = if f x <= f y then x else y

-- choose best move at top level, (maximumOn idea)
bestMove (Game rows V) tups = fst $ foldl1 (maxOn snd) tups
bestMove (Game rows H) tups = fst $ foldl1 (minOn snd) tups

bestMoves (Game board player) (tup:tups) = bestMovesAcc player tups (snd tup) [fst tup]

bestMovesAcc player [] bestScore bests = bests
bestMovesAcc V (tup:tups) bestScore bests = 
    if snd tup > bestScore then bestMovesAcc V tups (snd tup) [fst tup] else
    if snd tup == bestScore then bestMovesAcc V tups bestScore ((fst tup):bests) else
    bestMovesAcc V tups bestScore bests

bestMovesAcc H (tup:tups) bestScore bests = 
    if snd tup < bestScore then bestMovesAcc H tups (snd tup) [fst tup] else
    if snd tup == bestScore then bestMovesAcc H tups bestScore ((fst tup):bests) else
    bestMovesAcc H tups bestScore bests

-- create the (freeV, freeH)
allFreeMoves (Game rows player) = (freeV, freeH)
    where freeV = [(r, c) | r <- [0..(height rows)-1], c <- [0..(width rows)-1], 
            isValidMove (Game rows V) (r,c) ]
          freeH = [(r, c) | r <- [0..(height rows)-1], c <- [0..(width rows)-1], 
            isValidMove (Game rows H) (r,c) ]

christmasAI :: Strategy -- receives a game and plays a move for the next player
christmasAI rs game@(Game rows V) = randomAI rs game
christmasAI rs game@(Game rows H) = determiinsticAI rs game

--type Strategy = [Double] -> Game -> Pos
randomAI :: Strategy -- receives a game and plays a move for the next player
randomAI rs game@(Game rows player) = bests !! random
    where   freeMoves = allFreeMoves game
            moves = getMoves game freeMoves
            orderedFreeMoves = updateFM game moves freeMoves
            maxDepth = 5
            bests = bestMoves game [(move, (alphaBeta (playMove game move) maxDepth (minBound :: Int) (maxBound :: Int) (unfreeMove move orderedFreeMoves player))) | move <- moves]
            random = ((floor $ (head rs) * (fromIntegral $ length bests)) `mod` (length bests)) :: Int

{-TTEW-}
determiinsticAI :: Strategy -- receives a game and plays a move for the next player
determiinsticAI _ game@(Game rows player) = bestMove game [(move, (alphaBeta (playMove game move) maxDepth (minBound :: Int) (maxBound :: Int) (unfreeMove move orderedFreeMoves player))) | move <- moves]
    where   freeMoves = allFreeMoves game
            moves = getMoves game freeMoves
            orderedFreeMoves = updateFM game moves freeMoves
            maxDepth = 5

{-H10.1.7-}
play :: [[Double]] -> Int -> Strategy -> Strategy -> ([Board],Player)
play rss dim sv sh = playTurn rss (Game initialBoard V) sv sh
    where initialBoard = replicate dim (replicate dim E)

playTurn (rs:rss) game@(Game rows player) sv sh 
    | canMove game && isValidMove game move = 
                    let newGame@(Game board player) = playMove game move 
                        (boards, winner) = playTurn rss newGame sv sh
                    in (board:boards, winner)
    | otherwise = ([], otherPlayer player) -- can't play or chose invalid move
    where   strategy = if player == V then sv else sh
            move = (strategy rs game)

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