module Exercise08 where

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

-- Player is either 1 or -1
type Player = Int

-- A field is just an Int value where the absolute gives the number of pieces on the field
-- and the sign corresponds to the player
-- e.g. -3 would mean there are three blobs in this field of player -1
type Field = Int

type Row = [Field]
type Column = [Field]
-- boards are rectangles represented as a list of rows
type Board = [Row]

-- A position on the board is represented as (row, column)
-- (0,0) is the top left corner, coordinate values increase towards the bottom right
type Pos = (Int, Int)

-- A size represented as (height,width)
type Size = (Int, Int)

-- A strategy takes the player who's move it is, optionally takes a list of double values
-- to allow for probabilistic strategies, takes the current board and gives back the position
-- of the move the player should do
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

-- pretty print a single cell
showCell :: Field -> String
showCell c = "- +" !! succ (signum c) : show (abs c)

-- pretty print the given board
showBoard :: Board -> String
showBoard = unlines . map (unwords . map showCell)

-- print a board to the console
printBoard :: Board -> IO ()
printBoard = putStr . showBoard

-- check if a position is one a board of the given size
isValidPos :: Size -> Pos -> Bool
isValidPos (r, c) (y, x) = y >= 0 && y < r && x >= 0 && x < c

{- x.1 -}

-- Check if the given player can put an orb on the given position
canPlaceOrb :: Player -> Pos -> Board -> Bool
canPlaceOrb p pos b = p * getCell pos b >= 0

-- Check if the given player has won the game,
-- you can assume that the opponent has made at least one move before
hasWon :: Player -> Board -> Bool
hasWon p = foldr ((&&) . all ((0 <=) . (p *))) True

-- the list of neighbors of a cell
neighbors :: Size -> Pos -> [Pos]
neighbors size (y, x) = filter (isValidPos size) [(y, x + 1), (y, x - 1), (y + 1, x), (y - 1, x)]

-- update a single position on the board
-- f: function that modifies the number of orbs in the cell
-- p: player to whom the updated cell should belong
updatePos :: (Int -> Int) -> Player -> Pos -> Board -> Board
updatePos f p (0, x) (r : rs) = updateRow f p x r : rs 
  where
    updateRow :: (Int -> Int) -> Player -> Int -> Row -> Row
    updateRow f p 0 (v : vs) = signum p * f (abs v) : vs
    updateRow f p x (v : vs) = v : updateRow f p (x - 1) vs
updatePos f p (y, x) (r : rs) = r : updatePos f p (y - 1, x) rs

{- x.2 -}

-- place an orb for the given player in the given cell
putOrb :: Player -> Pos -> Board -> Board
putOrb p pos b = helper (notEmpty b) p pos b
  where
    notEmpty :: Board -> Bool
    notEmpty = foldr ((&&) . any (0 /=)) True

    -- shouldCheck is set when we should check for infinite loops
    -- shouldCheck is false when the board is empty, otherwise it's always set.
    helper :: Bool -> Player -> Pos -> Board -> Board
    helper shouldCheck p pos b 
      | not shouldCheck || not (hasWon p b) = check shouldCheck p pos $ updatePos succ p pos b
      | otherwise                           = b

    -- Check whether cells are filled and simulate overflows
    check :: Bool -> Player -> Pos -> Board -> Board
    check shouldCheck p pos b = let n = neighbors (size b) pos in
      if abs (getCell pos b) >= length n then
        foldr (helper shouldCheck p) (updatePos (const 0) p pos b) n
      else
        b

{- x.3 -}

{-WETT-}
minimaxPrio1 :: StatefulStrategyFunc Int
minimaxPrio1 x random p b = (minimaxPrio evalEnemyOrbs 3 random p b, 0)

minimaxPrio2 :: StatefulStrategyFunc Int
minimaxPrio2 x random p b = (minimaxPrio evalEnemyOrbs 3 random p b, 0)

possiblePositions :: Player -> Board -> [(Pos, Field)]
possiblePositions p rs = helper p 0 rs
  where
    helper :: Player -> Int -> Board -> [(Pos, Field)]
    helper p _ []        = []
    helper p rx (r : rs) = helperRow p rx 0 r ++ helper p (succ rx) rs
    
    helperRow :: Player -> Int -> Int -> Row -> [(Pos, Field)]
    helperRow p _ _ []         = []
    helperRow p rx fx (f : fs) = [((rx, fx), f) | p * f >= 0] ++ helperRow p rx (succ fx) fs

data Minimax = Leaf Player Int | Node Player Int Pos [(Pos, Minimax)]

minimax :: (Player -> Board -> Int) -> Int -> Strategy
minimax eval d _ p b = getPos $ genMinimax p b eval p d

minimaxPrio :: (Player -> Board -> Int) -> Int -> Strategy
minimaxPrio eval d _ p b = getPos $ genMinimaxPrio p b eval p d

getPos :: Minimax -> Pos
getPos (Node _ _ pos _) = pos

genMinimax :: Player -> Board -> (Player -> Board -> Int) -> Player -> Int -> Minimax
genMinimax p b eval _ 0 = Leaf p (eval p b)
genMinimax p b eval currentP d = 
  let children = map ((\pos -> let currentB = putOrb currentP pos b in (pos, genMinimax p currentB eval (-currentP) (d - 1))) . fst) (possiblePositions currentP b) in
    if null children then
      genMinimax p b eval currentP 0
    else
      uncurry (Node currentP) (bestMove children) children
  where
    bestMove :: [(Pos, Minimax)] -> (Int, Pos)
    bestMove xs = maxMinFunc (\(a, _) (b, _) -> compare a b) $ reverse $ map (\(a, b) -> (nodeValue b, a)) xs

    maxMinFunc :: (a -> a -> Ordering) -> [a] -> a
    maxMinFunc = if p == currentP then maximumBy else minimumBy

    nodeValue :: Minimax -> Int
    nodeValue (Leaf _ x)     = x
    nodeValue (Node _ x _ _) = x

genMinimaxPrio :: Player -> Board -> (Player -> Board -> Int) -> Player -> Int -> Minimax
genMinimaxPrio p b eval _ 0 = Leaf p (eval p b)
genMinimaxPrio p b eval currentP d = 
  let children = map (\pos -> let currentB = putOrb currentP (fst pos) b in (pos, genMinimaxPrio p currentB eval (-currentP) (d - 1))) (possiblePositions currentP b) in
    if null children then
      genMinimaxPrio p b eval currentP 0
    else
      uncurry (Node currentP) (bestMove children) (map (\((a, _), c) -> (a, c)) children)
  where
    bestMove :: [((Pos, Field), Minimax)] -> (Int, Pos)
    bestMove = snd . minimumBy maximum' . map givePrio . head . groupBy (\(a, _) (b, _) -> a == b) . sortBy maxMinFunc . map (\(a, b) -> (nodeValue b, a))

    maxMinFunc :: Ord a => (a, b) -> (a, b) -> Ordering
    maxMinFunc = if p == currentP then maximum' else minimum'

    maximum' :: Ord a => (a, b) -> (a, b) -> Ordering
    maximum' = \(a, _) (b, _) -> compare b a

    minimum' :: Ord a => (a, b) -> (a, b) -> Ordering
    minimum' = \(a, _) (b, _) -> compare a b

    givePrio :: (Int, (Pos, Field)) -> (Int, (Int, Pos))
    givePrio (x, (pos, f))
     | isCorner b pos && f < 1 = (2, (x, pos))
     | isEdge b pos && f < 2   = (1, (x, pos))
     | otherwise               = (0, (x, pos))

    isCorner :: Board -> Pos -> Bool
    isCorner b pos = let (h, w) = size b in pos `elem` [(0, 0), (h - 1, 0), (0, w - 1), (h - 1, w - 1)]

    isEdge :: Board -> Pos -> Bool
    isEdge b (y, x) = let (h, w) = size b in y == 0 || x == 0 || y == (h - 1) || x == (w - 1)

    nodeValue :: Minimax -> Int
    nodeValue (Leaf _ x)     = x
    nodeValue (Node _ x _ _) = x

-- Es wird versucht, die Anzahl der möglichen Felder vom Gegner zu minimieren
evalEnemyPossiblePositions :: Player -> Board -> Int
evalEnemyPossiblePositions p = negate . length . possiblePositions (-p)

evalPossiblePositions :: Player -> Board -> Int
evalPossiblePositions p = length . possiblePositions p

-- Es wird versucht, die Anzahl an besetzen Feldern des Gegeners zu minimieren
evalEnemyFields :: Player -> Board -> Int
--evalEnemyFields p = negate . foldl' (\acc -> (acc +) . sum . filter (0 <) . map ((p *) . negate . signum)) 0
evalEnemyFields p b = negate $ helper (-p) 0 b
  where
    helper :: Player -> Int -> Board -> Int
    helper p _ []        = 0
    helper p rx (r : rs) = helperRow p rx 0 r + helper p (succ rx) rs
    
    helperRow :: Player -> Int -> Int -> Row -> Int
    helperRow p _ _ []         = 0
    helperRow p rx fx (f : fs) = (if p * f > 0 then 1 else 0) + helperRow p rx (succ fx) fs

-- Es wird versucht, die Anzahl an besetzen Feldern von uns zu maximieren
evalFields :: Player -> Board -> Int
evalFields p = helper p 0
  where
    helper :: Player -> Int -> Board -> Int
    helper p _ []        = 0
    helper p rx (r : rs) = helperRow p rx 0 r + helper p (succ rx) rs
    
    helperRow :: Player -> Int -> Int -> Row -> Int
    helperRow p _ _ []         = 0
    helperRow p rx fx (f : fs) = (if p * f > 0 then 1 else 0) + helperRow p rx (succ fx) fs

-- Es wird versucht, die Anzahl an möglichen Explosionen des Gegners zu minimieren
evalEnemyExplosions :: Player -> Board -> Int
evalEnemyExplosions p b = negate $ helper (-p) 0 b
  where
    helper :: Player -> Int -> Board -> Int
    helper p _ []        = 0
    helper p rx (r : rs) = helperRow p rx 0 r + helper p (succ rx) rs
    
    helperRow :: Player -> Int -> Int -> Row -> Int
    helperRow p _ _ []         = 0
    helperRow p rx fx (f : fs) = (let pos = (rx, fx) in if p * f > 0 && abs f + 1 == length (neighbors (size b) pos) then 1 else 0) + helperRow p rx (succ fx) fs

evalEnemyOrbs :: Player -> Board -> Int
evalEnemyOrbs p = negate . helper (-p) 0
  where
    helper :: Player -> Int -> Board -> Int
    helper p _ []        = 0
    helper p rx (r : rs) = helperRow p rx 0 r + helper p (succ rx) rs
    
    helperRow :: Player -> Int -> Int -> Row -> Int
    helperRow p _ _ []         = 0
    helperRow p rx fx (f : fs) = (if p * f > 0 then abs f else 0) + helperRow p rx (succ fx) fs

evalOrbs :: Player -> Board -> Int
evalOrbs p = helper p 0
  where
    helper :: Player -> Int -> Board -> Int
    helper p _ []        = 0
    helper p rx (r : rs) = helperRow p rx 0 r + helper p (succ rx) rs
    
    helperRow :: Player -> Int -> Int -> Row -> Int
    helperRow p _ _ []         = 0
    helperRow p rx fx (f : fs) = (if p * f > 0 then abs f else 0) + helperRow p rx (succ fx) fs

-- 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 = (0, minimaxPrio1)
{-TTEW-}

-- Simulate a game between two strategies on a board of the given size and
-- returns the state of the board before each move together with the player that won the game
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
    -- type signature is necessary, inferred type is wrong!
    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

-- Play a game and print it to the console
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