module Exercise08 where

import Data.Bits
import Data.List
import System.Random (mkStdGen, randoms, randomIO, Random)

--import Debug.Trace

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

type Player = Int
type Field = Int
type Row = [Field]
type Column = [Field]
type Board = [Row]
type Pos = (Int, Int)
type Size = (Int, Int)
type Strategy = [Double] -> Player -> Board -> Pos
-- A stateful strategy can additionally pass some object between invocations
type StatefulStrategyFunc a = a -> [Double] -> Player -> Board -> (Pos, a)
-- first value is the state object to pass to the first invocation of each game
type StatefulStrategy a = (a, StatefulStrategyFunc a)

defaultSize :: (Int, Int)
defaultSize = (9,6)

-- Some useful helper functions
row :: Board -> Int -> Row
row = (!!)

column :: Board -> Int -> Column
column = row . transpose

width :: Board -> Int
width (x : _) = length x
width _ = 0

height :: Board -> Int
height = length

size :: Board -> Size
size b = (height b, width b)

getCell :: Pos -> Board -> Field
getCell (y, x) b = b !! y !! x

showCell :: Field -> String
showCell c = "- +" !! succ (signum c) : show (abs c)

showBoard :: Board -> String
showBoard = unlines . map (unwords . map showCell)

printBoard :: Board -> IO ()
printBoard = putStr . showBoard

isValidPos :: Size -> Pos -> Bool
isValidPos (r, c) (y, x) = y >= 0 && y < r && x >= 0 && x < c

{- x.1 -}

canPlaceOrb :: Player -> Pos -> Board -> Bool
canPlaceOrb player pos board 
 | player == -1 = getCell pos board <= 0
 | otherwise = getCell pos board >= 0

hasWon :: Player -> Board -> Bool
hasWon player board = hasWonRec player (0, 0) board

hasWonRec :: Player -> Pos -> Board -> Bool
hasWonRec player (y, x) board
 | x >= width board = hasWonRec player (y + 1, 0) board
 | y >= height board = True
 | otherwise = (getCell (y, x) board * player >= 0) && (hasWonRec player (y, x + 1) board)

neighbors :: Size -> Pos -> [Pos]
neighbors size (y, x) = filter (isValidPos size) [(y - 1, x),(y, x - 1),(y + 1, x),(y, x + 1)]

updatePos :: (Int -> Int) -> Player -> Pos -> Board -> Board
updatePos f player pos board = updatePosRec f player pos board 0

updatePosRec :: (Int -> Int) -> Player -> Pos -> Board -> Int -> Board
updatePosRec f player (y, x) board currentRow
 | currentRow == y = (modifieRow f player (y, x) (row board y) 0) : (updatePosRec f player (y, x) board (currentRow + 1))
 | currentRow >= height board = []
 | otherwise = (row board currentRow) : (updatePosRec f player (y, x) board (currentRow + 1))

modifieRow :: (Int -> Int) -> Player -> Pos -> Row -> Int -> Row
modifieRow f player (y, x) row currentIndex
 | currentIndex == x = (f (abs (row!!currentIndex)) * player) : (modifieRow f player (y, x) row (currentIndex + 1))
 | currentIndex >= length row = []
 | otherwise = row!!currentIndex : (modifieRow f player (y, x) row (currentIndex + 1))

{- x.2 -}

putOrb :: Player -> Pos -> Board -> Board
putOrb player pos board
 | hasWon player board = updatePos (+1) player pos board
 | abs (getCell pos board) + 1 >= length neighborCells = putOrbForEach player neighborCells (updatePos (\_ -> 0) player pos board)
 | otherwise = updatePos (+1) player pos board
  where neighborCells = neighbors (size board) pos

putOrbForEach :: Player -> [Pos] -> Board -> Board
putOrbForEach player [] board = board
putOrbForEach player (m:ms) board = putOrbForEach player ms (putOrb player m board)

{- x.3 -}

{-WETT-}
strategy :: Strategy
strategy random (-1) board = bestMove (createMap board (*(-1)) s) s random
 where s = size board
strategy random 1 board = bestMove (createMap board (\c -> c) s) s random 
 where s = size board

createMap :: Board -> (Int -> Int) -> Size -> IntMap Field
createMap board f (h, w) = IntMap.fromAscList [(mapKey (y, x) w, f (getCell (y, x) board)) | y<-[0..(h - 1)], x<-[0..(w - 1)], getCell (y, x) board /= 0]

increasePosMap :: Player -> IntMap Field -> Int -> IntMap Field
increasePosMap player map index = IntMap.insert index ((1 + abs (IntMap.findWithDefault 0 index map)) * player) map

removePosMap :: IntMap Field -> Int -> IntMap Field
removePosMap map index = IntMap.delete index map

mapKey :: Pos -> Int -> Int
mapKey (y, x) w = x + w * y

indexToCoordinate :: Int -> Int -> Pos
indexToCoordinate index w = (div index w, mod index w)

hasWonMap :: IntMap Field -> Int
hasWonMap map
 | occupiedByPos == 0 = -1
 | occupiedCells == occupiedByPos = 1
 | otherwise = 0
  where occupiedCells = IntMap.size map
        occupiedByPos = IntMap.size (IntMap.filter (>0) map)

putOrbMap :: Player -> IntMap Field -> Int -> Size -> (IntMap Field, Int)
putOrbMap player map index size@(h, w)
 | hasWonMap map == player = (map, player)
 | abs (IntMap.findWithDefault 0 index map) + 1 >= length neighborCells = putOrbForEachMap player neighborCells (removePosMap map index) size
 | otherwise = (increasePosMap player map index, 0)
  where neighborCells = neighborsMap size index 

putOrbForEachMap :: Player -> [Int] -> IntMap Field -> Size -> (IntMap Field, Int)
putOrbForEachMap _ [] map _ = (map, hasWonMap map)
putOrbForEachMap player (m:ms) map size 
 | winner == player = (changedMap, player)
 | otherwise = putOrbForEachMap player ms changedMap size
  where (changedMap, winner) = putOrbMap player map m size

neighborsMap :: Size -> Int -> [Int]
neighborsMap (h, w) index = 
  (if mod index w /= 0 then [index - 1] else []) ++ 
  (if mod (index + 1) w /= 0 then [index + 1] else []) ++ 
  (if index >= w then [index - w] else []) ++ 
  (if index + w < w * h then [index + w] else [])

neighborsMapAmount :: Size -> Int -> Int
neighborsMapAmount (h, w) index = 
  (if mod index w /= 0 then 1 else 0) + 
  (if mod (index + 1) w /= 0 then 1 else 0) + 
  (if index >= w then 1 else 0) + 
  (if index + w < w * h then 1 else 0)

allMoves :: Player -> IntMap Field -> Size -> [Int]
allMoves player map (h, w) = [index | index<-[0..(h * w - 1)], IntMap.notMember index map || map IntMap.! index * player > 0]

allMovesFiltered :: Player -> IntMap Field -> Size -> [Int]
allMovesFiltered player map size = removeChainMultiples (allMoves player map size) map size

removeChainMultiples :: [Int] -> IntMap Field -> Size -> [Int]
removeChainMultiples moves map size@(h, w) = filter (\index -> 
  not (isCritical index map size) || 
    ((mod (index + 1) w == 0 || IntMap.findWithDefault 0 (index + 1) map * (IntMap.findWithDefault 0 index map) <= 0 || not (isCritical (index + 1) map size)) && 
    (index + w >= w * h || IntMap.findWithDefault 0 (index + w) map * (IntMap.findWithDefault 0 index map) <= 0  || not (isCritical (index + w) map size)))) moves

emptyCornerMoves :: IntMap Field -> Size -> [Int]
emptyCornerMoves map size@(h, w) = filter (\index -> IntMap.notMember index map) [0, w - 1, w * (h - 1), w * h - 1]

isCorner :: Int -> Size -> Bool
isCorner index (h, w) = index == 0 || index == w - 1 || index == w * (h - 1) || index == w * h - 1

isEdge :: Int -> Size -> Bool
isEdge index (h, w) = index < w || mod index w == 0 || mod (index + 1) w == 0 || index >= w * (h - 1)

isCritical :: Int -> IntMap Field -> Size -> Bool
isCritical index map size = abs (IntMap.findWithDefault 0 index map) == neighborsMapAmount size index - 1

bestMove :: IntMap Field -> Size -> [Double] -> Pos
bestMove map size@(h, w) (r:rs)
 | shouldNotUseMiniMax map = indexToCoordinate (getRandomElement (makeNonMiniMaxMove map size) r) w
 | otherwise =  indexToCoordinate miniMaxMove w
 where miniMaxMove = fst (maximizeStart map size rs)

shuffel :: (Eq a) => [a] -> [Double] -> [a]
shuffel [] _ = []
shuffel list (r:rs) = removedValue : (shuffel [value | value<-list, value /= removedValue] rs)
 where removedIndex = (floor (r * fromIntegral (length list - 1)))
       removedValue = list !! removedIndex

getRandomElement :: [a] -> Double -> a
getRandomElement list random = list !! (floor (random * fromIntegral (length list - 1)))

shouldNotUseMiniMax :: IntMap Field -> Bool
shouldNotUseMiniMax map = IntMap.foldr (\a b -> abs a + b) 0 map < 4

makeNonMiniMaxMove :: IntMap Field -> Size -> [Int]
makeNonMiniMaxMove map size@(h, w)
 | null moveNextToOpponent = emptyCornerMoves map size
 | otherwise = moveNextToOpponent
  where moveNextToOpponent = [index |index<-[0..(w * h - 1)], isEdge index size, not(isCorner index size),any (\neighbor -> not (isEdge neighbor size) && IntMap.findWithDefault 0 neighbor map < 0) (neighborsMap size index)]

maxBranches :: Int
maxBranches = 400000

maximizePlaceHolder :: (Int, Int)
maximizePlaceHolder = (-1, -10000000)

maximizeStartDebug :: IntMap Field -> Size -> ([Int], Int)
maximizeStartDebug map size = maximizeEvaluation
 where moves = allMovesFiltered 1 map size
       maximizeEvaluation = if (not (null (fst maximizeEvaluationBigAlpha))) then maximizeEvaluationBigAlpha else maximizeEvaluationSmallBeta
       currentEvaluation = evaluateMap map size 1
       maximizeEvaluationBigAlpha = maximizeStartDebugRec map (length moves) currentEvaluation 1000000 size moves ([], snd maximizePlaceHolder)
       maximizeEvaluationSmallBeta = maximizeStartDebugRec map (length moves) (-1000000) currentEvaluation size moves ([], snd maximizePlaceHolder)

maximizeStartDebugRec :: IntMap Field -> Int -> Int -> Int -> Size -> [Int] -> ([Int], Int) -> ([Int], Int)
maximizeStartDebugRec _ _ _ _ _ [] evaluation = evaluation
maximizeStartDebugRec map currentBranches alpha beta size (m:ms) evaluation
 | winner /= 0 = ([m], winner * 1000000)
 | otherwise = maximizeStartDebugRec map currentBranches newAlpha beta size ms newEvaluation
  where (changedMap, winner) = putOrbMap 1 map m size
        minimizeEvaluation = minimize changedMap currentBranches alpha beta size
        newAlpha = max alpha (minimizeEvaluation - 1)
        newEvaluation = if (minimizeEvaluation > snd evaluation) then ([m], minimizeEvaluation) else (if (minimizeEvaluation == snd evaluation) then (m : (fst evaluation), snd evaluation) else evaluation)

maximizeStart :: IntMap Field -> Size -> [Double] -> (Int, Int)
maximizeStart map size random = maximizeEvaluation
 where moves = allMovesFiltered 1 map size
       miniMaxMoves = shuffel moves random
       maximizeEvaluation = maximizeStartRec map (length miniMaxMoves) (-1000000) 1000000 size miniMaxMoves maximizePlaceHolder

maximizeStartRec :: IntMap Field -> Int -> Int -> Int -> Size -> [Int] -> (Int, Int) -> (Int, Int)
maximizeStartRec _ _ _ _ _ [] evaluation = evaluation
maximizeStartRec map currentBranches alpha beta size (m:ms) evaluation 
 | winner /= 0 = (m, winner * 1000000)
 | otherwise = maximizeStartRec map currentBranches newAlpha beta size ms newEvaluation
  where (changedMap, winner) = putOrbMap 1 map m size
        minimizeEvaluation = minimize changedMap currentBranches alpha beta size
        newAlpha = max alpha minimizeEvaluation
        newEvaluation = if (minimizeEvaluation > snd evaluation) then (m, minimizeEvaluation) else evaluation

maximize :: IntMap Field -> Int -> Int -> Int -> Size -> Int
maximize map currentBranches alpha beta size
 | newBranches > maxBranches = evaluateMap map size 1
 | otherwise = maximizeRec map newBranches alpha beta size moves (snd maximizePlaceHolder)
  where moves = allMovesFiltered 1 map size
        newBranches = currentBranches * (length moves)

maximizeRec :: IntMap Field -> Int -> Int -> Int -> Size -> [Int] -> Int -> Int
maximizeRec _ _ _ _ _ [] evaluation = evaluation
maximizeRec map currentBranches alpha beta size (m:ms) evaluation
 | winner /= 0 = winner * 1000000
 | newAlpha >= beta = newEvaluation
 | otherwise = maximizeRec map currentBranches newAlpha beta size ms newEvaluation
  where (changedMap, winner) = putOrbMap 1 map m size
        minimizeEvaluation = minimize changedMap currentBranches alpha beta size
        newAlpha = max alpha minimizeEvaluation
        newEvaluation = max evaluation minimizeEvaluation

minimizePlaceHolder :: Int
minimizePlaceHolder = 10000000

minimize :: IntMap Field -> Int -> Int -> Int -> Size -> Int
minimize map currentBranches alpha beta size
 | newBranches > maxBranches = evaluateMap map size (-1)
 | otherwise = minimizeRec map newBranches alpha beta size moves minimizePlaceHolder
  where moves = allMovesFiltered (-1) map size
        newBranches = currentBranches * (length moves)

minimizeRec :: IntMap Field -> Int -> Int -> Int -> Size -> [Int] -> Int -> Int
minimizeRec _ _ _ _ _ [] evaluation = evaluation
minimizeRec map currentBranches alpha beta size (m:ms) evaluation
 | winner /= 0 = winner * 1000000
 | newBeta <= alpha = newEvaluation
 | otherwise = minimizeRec map currentBranches alpha newBeta size ms newEvaluation
  where (changedMap, winner) = putOrbMap (-1) map m size
        maximizeEvaluation = maximize changedMap currentBranches alpha beta size
        newBeta = min beta maximizeEvaluation
        newEvaluation = min evaluation maximizeEvaluation

cellScore :: Player -> Int
cellScore 1 = 57
cellScore (-1) = 100

cellQuotientScore :: Player -> Int
cellQuotientScore 1 = 34
cellQuotientScore (-1) = 55

orbScore :: Player -> Int
orbScore 1 = 86
orbScore (-1) = 48

orbQuotientScore :: Player -> Int
orbQuotientScore 1 = 75
orbQuotientScore (-1) = 67

orbCellScore :: Player -> Int
orbCellScore 1 = 30
orbCellScore (-1) = 10

orbCellQuotientScore :: Player -> Int
orbCellQuotientScore 1 = 34
orbCellQuotientScore (-1) = 50

awayFromCritScore :: Player -> Int
awayFromCritScore 1 = 94
awayFromCritScore (-1) = 26

neighborOwn :: Player -> Int
neighborOwn 1 = 54
neighborOwn (-1) = -10

neighborOpp :: Player -> Int
neighborOpp 1 = 21
neighborOpp (-1) = 0

criticalNeighborOwn :: Player -> Int
criticalNeighborOwn 1 = -58
criticalNeighborOwn (-1) = -7

criticalNeighborOpp :: Player -> Int
criticalNeighborOpp 1 = 1
criticalNeighborOpp (-1) = -76

criticalNeighborSameCritical :: Player -> Int
criticalNeighborSameCritical 1 = 24
criticalNeighborSameCritical (-1) = -83

criticalNeighborDifferentCritical :: Player -> Int
criticalNeighborDifferentCritical 1 = 55
criticalNeighborDifferentCritical (-1) = -67

cornerBoost :: Player -> Int
cornerBoost 1 = 99
cornerBoost (-1) = -12

edgeBoost :: Player -> Int
edgeBoost 1 = 78
edgeBoost (-1) = 73

evaluateMap :: IntMap Field -> Size -> Player -> Int
evaluateMap map size currentPlayer = cScore + cQScore + oScore + oQScore + ownOCScore + ownOCQScore - oppOCScore - oppOCQSCore + score
  where (ownC, ownO, oppC, oppO, score) = evaluateMapRec map size currentPlayer 0
        cScore = (ownC - oppC) * (cellScore currentPlayer)
        cQScore = floor ((fromIntegral ownC) / (fromIntegral oppC) * (fromIntegral (cellQuotientScore currentPlayer)))
        oScore = (ownO - oppO) * (orbScore currentPlayer)
        oQScore = floor ((fromIntegral ownO) / (fromIntegral oppO) * (fromIntegral (orbQuotientScore currentPlayer)))
        ownOCScore = (ownO - ownC) * (orbCellScore currentPlayer)
        ownOCQScore = floor ((fromIntegral ownO) / (fromIntegral ownC) * (fromIntegral (orbCellQuotientScore currentPlayer)))
        oppOCScore = (oppO - oppC) * (orbCellScore currentPlayer)
        oppOCQSCore = floor ((fromIntegral oppO) / (fromIntegral oppC) * (fromIntegral (orbCellQuotientScore currentPlayer)))

evaluateMapRec :: IntMap Field -> Size -> Player -> Int -> (Int, Int, Int, Int, Int)
evaluateMapRec gameMap size@(h, w) currentPlayer index
 | index >= h * w = (0, 0, 0, 0, 0)
 | currentCell == 0 = evaluateMapRec gameMap size currentPlayer (index + 1)
 | otherwise = (ownCNew, ownONew, oppCNew, oppONew, score + corner + edge + critEvaluation + nOwn + nOpp + criticalNOwn + criticalNOpp + criticalNSameCritical + criticalNDifferentCritical) 
  where (ownC, ownO, oppC, oppO, score) = evaluateMapRec gameMap size currentPlayer (index + 1)
        currentCell = IntMap.findWithDefault 0 index gameMap
        signOfCell = signum currentCell
        neighborCells = neighborsMap size index
        ownCNew = ownC + if currentCell > 0 then 1 else 0
        ownONew = ownO + if currentCell > 0 then currentCell else 0
        oppCNew = oppC + if currentCell < 0 then 1 else 0
        oppONew = oppO + if currentCell < 0 then (-currentCell) else 0
        corner = if isCorner index size then (cornerBoost currentPlayer) * signOfCell else 0
        edge = if isEdge index size && not (isCorner index size) then (edgeBoost currentPlayer) * signOfCell else 0
        critEvaluation = (3 - (length neighborCells) + (abs currentCell)) * (awayFromCritScore currentPlayer) * signOfCell
        isCrit = isCritical index gameMap size
        ownNeighbors = filter (\indexN -> IntMap.findWithDefault 0 indexN gameMap * signOfCell > 0) neighborCells
        oppNeighbors = filter (\indexN -> IntMap.findWithDefault 0 indexN gameMap * signOfCell < 0) neighborCells
        nOwn = length ownNeighbors * (neighborOwn currentPlayer) * signOfCell
        nOpp = length oppNeighbors * (neighborOpp currentPlayer) * signOfCell
        criticalNOwn = if isCrit then length ownNeighbors * (criticalNeighborOwn currentPlayer) * signOfCell else 0
        criticalNOpp = if isCrit then length oppNeighbors * (criticalNeighborOpp currentPlayer) * signOfCell else 0
        criticalNSameCritical = if isCrit then length (filter (\indexN -> isCritical indexN gameMap size) ownNeighbors) * (criticalNeighborSameCritical currentPlayer) * signOfCell else 0
        criticalNDifferentCritical = if isCrit then length (filter (\indexN -> isCritical indexN gameMap size) oppNeighbors) * (criticalNeighborDifferentCritical currentPlayer) else 0

--debug :: (Show a) => String -> a -> a
--debug string a = trace (string ++ (show a)) a

-- adds state to a strategy that doesn't use it
wrapStrategy :: Strategy -> StatefulStrategy Int
wrapStrategy strat = (0, \s r p b -> (strat r p b, succ s))

-- the actual strategy submissions
-- if you want to use state modify this instead of strategy
-- additionally you may change the Int in this type declaration to any type that is usefully for your strategy
strategyState :: StatefulStrategy Int
strategyState = wrapStrategy strategy

{-TTEW-}

play :: [Int] -> Size -> StatefulStrategy a -> StatefulStrategy b -> [(Board, Pos)]
play rss (r, c) (isa, sa) (isb, sb) = go rss isa sa isb sb 1 0 (replicate r (replicate c 0))
  where
    go :: [Int] -> a -> StatefulStrategyFunc a -> b -> StatefulStrategyFunc b -> Player -> Int -> Board -> [(Board, Pos)]
    go (rs:rss) stc sc stn sn p n b
      | won       = []
      | valid     = (b, m) : go rss stn sn st' sc (-p) (succ n) (putOrb p m b)
      | otherwise = []
      where
        won      = n > 1 && hasWon (-p) b
        (m, st') = sc stc (mkRandoms rs) p b
        valid    = isValidPos (size b) m && canPlaceOrb p m b

playAndPrint :: Size -> StatefulStrategy a -> StatefulStrategy b -> IO ()
playAndPrint size sa sb = do
  seed <- randomIO
  -- let seed = 42
  let moves = play (mkRandoms seed) size sa sb
  putStr $
    unlines (zipWith showState moves $ cycle ['+', '-']) ++ "\n" ++
    (case length moves `mod` 2 of { 1 -> "Winner: +"; 0 -> "Winner: -" }) ++ "\n" ++
    "View at https://vmnipkow16.in.tum.de/christmas2020/embed.html#i" ++ base64 (1 : t size ++ concatMap (t . snd) moves) ++ "\n"
  where
    showState (b, pos) p = showBoard b ++ p : " places at " ++ show pos ++ "\n"
    t (a, b) = [a, b]

mkRandoms :: Random a => Int -> [a]
mkRandoms = randoms . mkStdGen

base64 :: [Int] -> String
base64 xs = case xs of
  []            -> ""
  [a]           -> f1 a : f2 a 0 : "=="
  [a, b]        -> f1 a : f2 a b : f3 b 0 : "="
  a : b : c : d -> f1 a : f2 a b : f3 b c : f4 c : base64 d
  where
    alphabet = (!!) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    f1 a     = alphabet $ shiftR a 2
    f2 a b   = alphabet $ shiftL (a .&. 3 ) 4 .|. shiftR b 4
    f3 b c   = alphabet $ shiftL (b .&. 15) 2 .|. shiftR c 6
    f4 c     = alphabet $ c .&. 63