module Exercise_10 where
import Data.List
import Data.Maybe
import Test.QuickCheck

import Data.IntMap.Lazy (IntMap)
import qualified Data.IntMap.Lazy as IntMap

{-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 [] = ""
prettyShowBoard (x:xs) = showRow x ++ prettyShowBoard xs

showRow :: Row -> String
showRow [] = "\n"
showRow (x:xs) = showFieldDifferent x ++ showRow xs

showFieldDifferent :: Field -> String
showFieldDifferent E = "+"
showFieldDifferent (P V) = "V"
showFieldDifferent (P H) = "H"

{-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 pl) po = isEmpty b po && isEmpty b otherPo
  where otherPo = if pl == V then (fst po + 1, snd po) else (fst po, snd po + 1)

isEmpty :: Board -> Pos -> Bool
isEmpty [] _ = False
isEmpty b p
 | fst p < 0 || snd p < 0 = False
 | fst p >= length b || snd p >= length b = False
 | otherwise = (b!!(fst p))!!(snd p) == E

{-H10.1.3-}
canMove :: Game -> Bool
canMove (Game b p)
 | length b <= 1 = False
 | otherwise = canMoveRec (Game b p) (0,0)

canMoveRec :: Game -> Pos -> Bool
canMoveRec (Game b pl) po
 | snd po >= length b = canMoveRec (Game b pl) (fst po + 1, 0)
 | fst po >= length b = False
 | otherwise = isValidMove (Game b pl) po || canMoveRec (Game b pl) (fst po, snd po + 1)

{-H10.1.4-}
updateBoard :: Board -> Pos -> Field -> Board
updateBoard (b:bs) p f
 | fst p == 0 = (updateRow b p f):bs
 | otherwise = b:(updateBoard bs (fst p - 1, snd p) f)

updateRow :: Row -> Pos -> Field -> Row
updateRow (r:rs) p f
 | snd p == 0 = f:rs
 | otherwise = r:(updateRow rs (fst p, snd p - 1) f)

{-H10.1.5-}
playMove :: Game -> Pos -> Game
playMove (Game b pl) po = (Game (updateBoard (updateBoard b po (P pl)) otherPo (P pl)) (otherPlayer pl))
  where otherPo = if pl == V then (fst po + 1, snd po) else (fst po, snd po + 1)

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

{-
Explanation of Strategy:
I focused on a hopefully and seemingly good evaluation function. The downside of this, is the time it takes to compute the function. 
So a minmax tree that looks into every single move takes too long, which forces me to look only into the moves that are currently evaluated as good.
I also implemented a threshold for the consideration of moves that are used for minmax. The initial problem was that not so perfect moves were use since the programm thought that they could be fixed later. After some tweeking it worked.
Another improvement is the exclusion of safeSpots in the minmax, as I'm  limited by my recursion depth. So I can't look far enough until the end of the game. So I discard every possible move wich takes up a safeSpot.
Since they are the last moves of a game, this isn't a problem and I can determine earlier wether I could win or loose the game.
After I determined the best spots with the help of minMax I choose a random spot of them in order to make it impossible to predict my moves.
This and the resulting fact, that I'm not building up on one side of the board, seems to help a lot against the simpler strategies.

For my evaluation function I used three things: the amount of avaviable pots, the amount of avaviable safe spots and the amount of holes, since in a perfectly played game the second player always wins.
To be honest the weights for these three were calculated in a Java programm. But right now, I'm not able to simulate 250.000 games in a reasonable time in Haskell in order to find goof weights.
Interestingly the weights for the vertical player were pretty clear, the weights for the horizonotal player were close. Even after more than 2000 wins for each possible ai the best 5 weight packages were within 20 wins.

I also convert the board into a HashMap in the hope of getting better performance, which isn't the case at all...
-}

{-WETT-}
christmasAI :: Strategy -- receives a game and plays a move for the next player
christmasAI r (Game b pl) = chooseRandomSpot bestSpots (head r)
 where bestSpots = chooseBest goodPositions gameMap pl lengthB
       goodPositions = getGoodPositions possiblePositions
       possiblePositions = evaluatePositions gameMap pl (0,0) lengthB
       gameMap = createMap b
       lengthB = length b

chooseRandomSpot :: [Pos] -> Double -> Pos
chooseRandomSpot pos r = pos!!(floor (r * fromIntegral (length pos - 1)))

chooseBest :: [(Int, Pos)] -> IntMap Field -> Player -> Int -> [Pos]
chooseBest [p] _ _ _ = [snd p]
chooseBest (p:pos) map pl lengthB = chooseBestRec pos map pl [snd p] scoreOfP recDepthValue lengthB
  where scoreOfP = fst p + (minMax (hypotheticalMap map pl (snd p) lengthB) pl recDepthValue False (0-1000000000) (1000000000) pl lengthB)
        recDepthValue = recDepth (length pos + 1) (length pos) 0

chooseBestRec :: [(Int, Pos)] -> IntMap Field -> Player -> [Pos] -> Int -> Int -> Int -> [Pos]
chooseBestRec [] _ _ pB _ _ _ = pB
chooseBestRec (p:pos) map pl pB best recDepthValue lengthB
 | scoreOfP > best = chooseBestRec pos map pl [snd p] scoreOfP recDepthValue lengthB
 | scoreOfP == best = chooseBestRec pos map pl ((snd p):pB) scoreOfP recDepthValue lengthB
 | otherwise = chooseBestRec pos map pl pB best recDepthValue lengthB
   where scoreOfP = fst p + (minMax (hypotheticalMap map pl (snd p) lengthB) pl recDepthValue False (0-1000000000) (1000000000) pl lengthB)

recDepth :: Int -> Int -> Int -> Int
recDepth branches possibilities currentDepth
 | branches * possibilities > 550 || possibilities <= 1 = currentDepth
 | otherwise = recDepth (branches * possibilities) possibilities (currentDepth + 1)

minMax :: IntMap Field -> Player -> Int -> Bool -> Int -> Int -> Player -> Int -> Int
minMax map pl 0 _ _ _ player lengthB = boardScoreCompute map player lengthB
minMax map pl depth True alpha beta player lengthB = maximize map pl depth alpha beta player possibleMoves (0-1000000000) lengthB
  where possibleMoves = getRelevantSpotsForMinMax map pl lengthB
minMax map pl depth False alpha beta player lengthB = minimize map pl depth alpha beta player possibleMoves (1000000000) lengthB
  where possibleMoves = getRelevantSpotsForMinMax map pl lengthB

maximize :: IntMap Field -> Player -> Int -> Int -> Int -> Player -> [Pos] -> Int -> Int -> Int
maximize map pl depth alpha beta player [] initialValue lengthB = if computeWinForPlayer map pl player lengthB then 1000000000 else -1000000000
maximize map pl depth alpha beta player (p:pos) initialValue lengthB
 | alpha >= beta = initialValue
 | otherwise = max valueOfP (maximize map pl depth newAlpha beta player pos initialValue lengthB)
  where valueOfP = minMax (hypotheticalMap map pl p lengthB) (otherPlayer pl) (depth - 1) False alpha beta player lengthB
        newAlpha = max valueOfP alpha

minimize :: IntMap Field -> Player -> Int -> Int -> Int -> Player -> [Pos] -> Int -> Int -> Int
minimize map pl depth alpha beta player [] initialValue lengthB = if computeWinForPlayer map pl player lengthB then 1000000000 else -1000000000
minimize map pl depth alpha beta player (p:pos) initialValue lengthB
 | alpha >= beta = initialValue
 | otherwise = min valueOfP (minimize map pl depth alpha newBeta player pos initialValue lengthB)
  where valueOfP = minMax (hypotheticalMap map pl p lengthB) (otherPlayer pl) (depth - 1) True alpha beta player lengthB
        newBeta = min valueOfP beta

computeWinForPlayer :: IntMap Field -> Player -> Player -> Int -> Bool
computeWinForPlayer map pl currentPl lengthB = if currentPl == pl then spotDifference > 0 else spotDifference >= 0
  where spotDifference = computeWinForPlayerRec map pl (0,0) lengthB

computeWinForPlayerRec :: IntMap Field -> Player -> Pos -> Int -> Int
computeWinForPlayerRec map pl po lengthB
 | fst po >= lengthB = 0
 | snd po >= lengthB = computeWinForPlayerRec map pl (fst po + 1, 0) lengthB
 | otherwise = (if isValidMoveMap map pl po lengthB then 1 else 0) - (if isValidMoveMap map (otherPlayer pl) po lengthB then 1 else 0) + computeWinForPlayerRec map pl (fst po, snd po + 1) lengthB

getRelevantSpotsForMinMax :: IntMap Field -> Player -> Int -> [Pos]
getRelevantSpotsForMinMax map pl lengthB = Prelude.map (snd) goodPositions
  where goodPositions = getGoodPositions noSafeSpots
        noSafeSpots = filter (\(_,po) -> not (safeSpot map pl po lengthB)) positions
        positions = evaluatePositions map pl (0,0) lengthB

getGoodPositions :: [(Int, Pos)] -> [(Int, Pos)]
getGoodPositions positions = filter (\x -> fst x >= threshold) positions
  where maxValue = fst (head (sortBy (\(a,_) (b,_) -> compare b a) positions))
        threshold = maxValue - signum(maxValue) * maxValue `div` 2

evaluatePositions :: IntMap Field -> Player -> Pos -> Int -> [(Int, Pos)]
evaluatePositions map pl po lengthB
 | fst po >= lengthB = []
 | isValidMoveMap map pl po lengthB = (spotScore, po) : (evaluatePositions map pl newPosition lengthB)
 | otherwise = evaluatePositions map pl newPosition lengthB
  where spotScore = boardScoreCompute newMap pl lengthB
        newPosition = if snd po >= lengthB then (fst po + 1, 0) else (fst po, snd po + 1)
        newMap = hypotheticalMap map pl po lengthB

boardScoreCompute :: IntMap Field -> Player -> Int -> Int
boardScoreCompute map pl lengthB = playerScore - opponentScore
  where playerScore = boardScoreOnePlayer map pl (0,0) lengthB False False 0
        opponentScore = boardScoreOnePlayer map (otherPlayer pl) (0,0) lengthB False False 0

boardScoreOnePlayer :: IntMap Field -> Player -> Pos -> Int -> Bool -> Bool -> Int -> Int
boardScoreOnePlayer map pl po lengthB wasSpot wasSafeSpot holes
 | pl == H && fst po >= lengthB = if even ((holes + 1) `div` 2) then (holeScore pl) else 0
 | pl == V && snd po >= lengthB = if odd ((holes + 1) `div` 2) then (holeScore pl) else 0
 | pl == H && snd po >= lengthB = boardScoreOnePlayer map pl (fst po + 1, 0) lengthB False False holes
 | pl == V && fst po >= lengthB = boardScoreOnePlayer map pl (0, snd po + 1) lengthB False False holes
 | isValidMoveMap map pl po lengthB = emptySpotScore + boardScoreOnePlayer map pl newPosition lengthB (not wasSpot) ((not wasSafeSpot) && isSafeSpot) holes
 | isHole map po lengthB = boardScoreOnePlayer map pl newPosition lengthB False False (holes + 1)
 | otherwise = boardScoreOnePlayer map pl newPosition lengthB False False holes
    where newPosition = if pl == H then (fst po, snd po + 1) else (fst po + 1, snd po)
          isSafeSpot = safeSpot map pl po lengthB
          emptySpotScore = (if wasSpot then 0 else (spotScore pl)) + (if (not wasSafeSpot) && isSafeSpot then (safeScore pl) else 0)

safeSpot :: IntMap Field -> Player -> Pos -> Int -> Bool
safeSpot map H po lengthB = not ((isEmptyMap map (fst po + 1, snd po) lengthB) || (isEmptyMap map (fst po - 1, snd po) lengthB) || (isEmptyMap map (fst po + 1, snd po + 1) lengthB) || (isEmptyMap map (fst po - 1, snd po + 1) lengthB))
safeSpot map V po lengthB = not ((isEmptyMap map (fst po, snd po + 1) lengthB) || (isEmptyMap map (fst po, snd po - 1) lengthB) || (isEmptyMap map (fst po + 1, snd po + 1) lengthB) || (isEmptyMap map (fst po + 1, snd po - 1) lengthB))

isHole :: IntMap Field -> Pos -> Int -> Bool
isHole map po lengthB = (isEmptyMap map po lengthB) 
  && not (isEmptyMap map (fst po + 1, snd po) lengthB) && not (isEmptyMap map (fst po - 1, snd po) lengthB) && not (isEmptyMap map (fst po, snd po + 1) lengthB) && not (isEmptyMap map (fst po, snd po - 1) lengthB)

holeScore :: Player -> Int
holeScore H = 2
holeScore V = 0

spotScore :: Player -> Int
spotScore H = 3
spotScore V = 1

safeScore :: Player -> Int
safeScore H = 3
safeScore V = 1

otherPlayer :: Player -> Player
otherPlayer H = V
otherPlayer V = H

createMap :: Board -> IntMap Field
createMap b = IntMap.fromAscList [(x + lengthB * y, b!!x!!y) | y<-[0..(lengthB - 1)], x<-[0..(lengthB - 1)]]
  where lengthB = length b

calculateKey :: Pos -> Int -> Int
calculateKey po lengthB = (fst po + lengthB * snd po)

hypotheticalMap :: IntMap Field -> Player -> Pos -> Int -> IntMap Field
hypotheticalMap map H po lengthB = updateMap (updateMap map H po lengthB) H (fst po, snd po + 1) lengthB
hypotheticalMap map V po lengthB = updateMap (updateMap map V po lengthB) V (fst po + 1, snd po) lengthB

updateMap :: IntMap Field -> Player -> Pos -> Int -> IntMap Field
updateMap map pl po lengthB = IntMap.insert (calculateKey po lengthB) (P pl) map

isEmptyMap :: IntMap Field -> Pos -> Int -> Bool
isEmptyMap map po lengthB
 | fst po >= 0 && snd po >= 0 && fst po < lengthB && snd po < lengthB = ((fromJust field) == E)
 | otherwise = False
  where field = IntMap.lookup (calculateKey po lengthB) map

isValidMoveMap :: IntMap Field -> Player -> Pos -> Int -> Bool
isValidMoveMap map H po lengthB = (isEmptyMap map po lengthB) && (isEmptyMap map (fst po, snd po + 1) lengthB)
isValidMoveMap map V po lengthB = (isEmptyMap map po lengthB) && (isEmptyMap map (fst po + 1, snd po) lengthB)
{-TTEW-}

{-H10.1.7-}
play :: [[Double]] -> Int -> Strategy -> Strategy -> ([Board],Player)
play r d sv sh = playRec r (Game (createEmptyBoard d) V) sv sh []

createEmptyBoard :: Int -> Board
createEmptyBoard n = [[E | x<-[0..(n-1)]] | y<-[0..(n-1)]]

playRec :: [[Double]] -> Game -> Strategy -> Strategy -> [Board] ->  ([Board],Player)
playRec r (Game b pl) sv sh boards
 | canMove (Game b pl) && (isValidMove (Game b pl) po) = playRec (tail r) (Game newBoard newPlayer) sv sh (boards ++ [newBoard])
 | otherwise = (boards, newPlayer) 
  where sC = if pl == V then sv else sh
        po = sC (head r) (Game b pl)
        newPlayer = otherPlayer pl
        newBoard = getBoard (playMove (Game b pl) po)

getBoard :: Game -> Board
getBoard (Game b _ ) = b 

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