module Exercise08 where

import Data.Bits
import Data.List
import System.Random (mkStdGen, randoms, randomIO, Random)
import Data.Function (on)
import Data.Maybe (fromJust, fromMaybe, isNothing)

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

depth :: Int
depth = 3

win :: Int
win = 100000

lose :: Int
lose = -100000
-- 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 (y, x) b = getCell (y, x) b * p >= 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 b = and [canPlaceOrb p (y, x) b| y <- [0 .. height b - 1], x<- [0 .. width b - 1]]

-- the list of neighbors of a cell
neighbors :: Size -> Pos -> [Pos]
neighbors (r, c) (y, x) = [(y1, x1) | (y1, x1) <- [(y-1, x), (y+1, x), (y, x-1), (y, x+1)], y1>=0, y1<r, x1>=0, x1<c]

-- 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 (y, x) b = [[if (y,x) /= (y1, x1) then getCell (y1, x1) b else p * f (abs (getCell (y1, x1) b)) | x1 <- [0..width b -1]] | y1 <- [0..height b -1]]

{- x.2 -}

-- place an orb for the given player in the given cell
putOrb :: Player -> Pos -> Board -> Board
putOrb p (y, x) b = handleOverflow p [(y, x)] (updatePos (1+) p (y, x) b) 

isOverflown :: Pos -> Board -> Bool 
isOverflown pos b = abs (getCell pos b) >= length (neighbors (size b) pos)

overflowCells :: Player -> [Pos] -> Board -> Board
overflowCells _ [] b = b
overflowCells p (pos:ps) b = overflowCells p ps (updatePos (1+) p pos b)

debug [] = ""
debug (b:bs) = showBoard b ++ "\n" ++ debug bs

handleOverflow :: Player -> [Pos] -> Board -> Board
handleOverflow _ [] b = b
handleOverflow p ((y, x):ps) b
  | hasWon p b = b
  | isOverflown (y, x) b = let n = neighbors (size b) (y, x) in handleOverflow p (ps ++ n) (updatePos (\x -> x - length n) p (y, x) (overflowCells p n b))
  | otherwise = handleOverflow p ps b
{- x.3 -}

{-WETT-}



-- Your strategy
strategy2 :: Strategy
strategy2 _ p b 
  | not (null overflowers) = head overflowers
  | not (null corners1) = head corners1
  | not (null walls) = head walls
  | otherwise = head rnd
  where
    overflowers = [(x, y) | y <- [0 .. height b - 1], x<- [0 .. width b - 1], abs (getCell (y, x) b + p) >= length (neighbors (size b) (y, x))]
    corners1 = [pos | pos <- [(0,0), (0, width b -1), (height b - 1, 0), (height b - 1, width b -1)], getCell pos b == p]
    walls = [(y,x)| y <- [0 .. height b - 1], x<- [0 .. width b - 1], x ==0 || x == width b - 1 || y ==0 || y == height b - 1, canPlaceOrb p (y, x) b]
    rnd = [(y,x) | y <- [0 .. height b - 1], x<- [0 .. width b - 1], canPlaceOrb p (y, x) b]


--strategy _ p b = snd (fromMaybe (2, head (playablePositions p b)) (maximizeAB p b 1 (-10000000) 10000000))
strategy3 :: Strategy
strategy3 ds p b = snd (fromJust (maximizeAB ds False p b 2 (-1000000) 1000000))

strategy :: Strategy
strategy ds p b = snd (fromJust (maximizeAB ds False p b 3 (-1000000) 1000000))

maximize :: Player  -> Board -> Int -> (Int, Pos)
maximize p b 0 = (evaluateBoard p b, (0, 0))
maximize p b d = maximumBy (compare `on` fst) [(fst (minimize p (putOrb p (y, x) b) (d-1)), (y, x))|y <- [0 .. height b - 1], x<- [0 .. width b - 1], canPlaceOrb p (y, x) b]


minimize :: Player -> Board -> Int -> (Int, Pos)
minimize p b 0 = (evaluateBoard p b, (0, 0))
minimize p b d = minimumBy (compare `on` fst) [(fst (maximize p (putOrb p (y, x) b) (d-1)), (y,x))|y <- [0 .. height b - 1], x<- [0 .. width b - 1], canPlaceOrb (-p) (y, x) b] 



maximizeAB :: [Double] -> Bool -> Player  -> Board -> Int -> Int -> Int -> Maybe (Int, Pos)
maximizeAB _ _ p b 0 _ _ = Just (evaluateBoard2 p b, (0, 0))
maximizeAB ds notFirst p b d alpha beta
  | hasWon (-p) b && notFirst = Just (-100000, (0,0))
  | otherwise = recMax newDs p b (playablePositions2 ds p b (getCountForD d)) alpha beta d
  where
    newDs = drop (round (head ds)) ds
  
recMax :: [Double] -> Player -> Board -> [Pos] -> Int -> Int -> Int -> Maybe (Int, Pos)
recMax ds p b [pos] alpha beta d 
  | isNothing c = Nothing
  | fst child > beta = Nothing
  | otherwise = Just (fst child, pos)
  where
      c = minimizeAB ds p (putOrb p pos b) (d-1) alpha beta
      child = fromJust c

recMax ds p b (pos:ps) alpha beta d 
  | isNothing nextMax  = Nothing
  | isNothing c = nextMax
  | otherwise = if fst newAlpha > beta then Nothing else Just newAlpha
  where
    nextMax = recMax ds p b ps alpha beta d
    c = minimizeAB ds p (putOrb p pos b) (d-1) recAlpha beta
    child = fromJust c
    recAlpha = fst (fromJust nextMax)
    newAlpha = if recAlpha > fst child then fromJust nextMax else (fst child, pos)

playablePositions :: Player -> Board -> [Pos]
playablePositions p b = [(y, x)|y <- [0 .. height b - 1], x<- [0 .. width b - 1], canPlaceOrb p (y, x) b]

getCountForD :: Int -> Int
getCountForD d 
 | d == 3 || d == 2 = 0
 | otherwise = 8

playablePositions2 :: [Double] -> Player -> Board -> Int -> [Pos]
playablePositions2 (d:ds) p b count
  | count == 1 = let list = if null over then normal else over in [list !! floor ((d - fromIntegral (floor d)) * fromIntegral (length list))]
  | length normal <= count || count == 0 = normal
  | otherwise = randomPlayablePos ds p b count
  where
    over = overflowers p b
    normal = playablePositions p b

randomPlayablePos :: [Double] -> Player -> Board -> Int -> [Pos]
randomPlayablePos _ _ _ 0 = []
randomPlayablePos (k:l:ds) p b count = if canPlaceOrb p (y, x) b then (y, x) : randomPlayablePos ds p b (count - 1) else randomPlayablePos ds p b count
  where
    y = floor ((k - fromIntegral (floor k)) * fromIntegral (height b))
    x = floor ((l - fromIntegral (floor l)) * fromIntegral (width b)) 

overflowers :: Player -> Board -> [Pos]
overflowers p b = [(y, x) | y <- [0 .. height b - 1], x<- [0 .. width b - 1], p * getCell (y, x) b  == length (neighbors (size b) (y, x)) - 1]


minimizeAB :: [Double] -> Player -> Board -> Int -> Int ->Int  -> Maybe (Int, Pos)
minimizeAB _ p b 0 _ _= Just (evaluateBoard2 p b, (0, 0))
minimizeAB ds p b d alpha beta 
  | hasWon p b = Just (100000, (0,0))
  | otherwise = recMin newDs p b (playablePositions2 ds (-p) b (getCountForD d)) alpha beta d
  where
    newDs = drop (round (head ds)) ds

recMin :: [Double] -> Player -> Board -> [Pos] -> Int -> Int -> Int -> Maybe (Int, Pos)
recMin ds p b [pos] alpha beta d 
  | isNothing c = Nothing
  | fst child < alpha = Nothing
  | otherwise = Just (fst child, pos)
  where
      c = maximizeAB ds True  p (putOrb (-p) pos b) (d-1) alpha beta
      child = fromJust c
recMin ds p b (pos:ps) alpha beta d 
  | isNothing nextMin = Nothing
  | isNothing c = nextMin
  | otherwise = if fst newBeta < alpha then Nothing else Just newBeta
  where
    nextMin = recMin ds p b ps alpha beta d
    c = maximizeAB ds True p (putOrb (-p) pos b) (d-1) alpha recBeta
    child = fromJust c
    recBeta = fst (fromJust nextMin)
    newBeta = if recBeta <= fst child then fromJust nextMin else (fst child, pos)

data PosAB = First Int Int | Invalid | Pab Pos Int Int
              deriving(Eq, Show)

data MM = Max | Min
          deriving(Eq, Show)

switch :: MM -> MM
switch Max = Min
switch Min = Max

whoseTurn :: MM -> Int -> Int
whoseTurn Min p = -p
whoseTurn Max p = p

getPos (Pab pos _ _) = pos
getAlpha (Pab _ a _) = a
getAlpha (First a _) = a

getBeta (Pab _ _ b) = b
getBeta (First _ b) = b

insertPos (Pab p a b) pos = Pab pos a b

combinePab :: MM -> PosAB -> PosAB -> PosAB
combinePab _ Invalid _ = Invalid
combinePab _ (First a b) pab = pab
combinePab Max old new = if getAlpha larger >= getBeta old then Invalid else larger
  where 
    larger = if getAlpha old < getAlpha new then new else old

combinePab Min old new = if getAlpha old >= getBeta smaller then Invalid else smaller
  where
    smaller = if getBeta old > getBeta new then new else old

treeLevel :: Player -> MM -> Board -> Int -> Int-> Int -> PosAB
treeLevel p mm b 0 alpha beta = if mm == Max then Pab (0,0) (evaluateBoard2 p b) beta else Pab (0,0) alpha (evaluateBoard2 p b)
treeLevel p mm b d alpha beta 
  | d /= depth && hasWon (-(whoseTurn mm p)) b = if mm == Min then Pab (0, 0) 0 lose else Pab (0,0) lose 0 
  | otherwise = foldl (treeFolder p mm b d) (First alpha beta) [(y,x)|y<-[0..height b - 1], x<-[0..width b - 1]]

treeFolder :: Player -> MM ->  Board -> Int -> PosAB -> Pos -> PosAB
treeFolder _ _ _ _ Invalid  _ = Invalid --aply alpha beta prunning
treeFolder p mm b d old pos
  | winningPos old p current = old
  | not (canPlaceOrb current pos b) = old
  | not (isValid next) = old
  | winningPos next p current = next
  | otherwise = combinePab mm old r
  where
    current = whoseTurn mm p
    next = treeLevel p (switch mm) (putOrb current pos b) (d-1) (getAlpha old) (getBeta old)
    r = if mm == Max then Pab pos (getBeta next) (getBeta old) else Pab pos (getAlpha old) (getAlpha next)

winningPos :: PosAB -> Int -> Int -> Bool 
winningPos pab p current = (getAlpha pab == win && current == p) || (getBeta pab == lose && current/=p)

isValid :: PosAB -> Bool 
isValid Invalid = False 
isValid (First _ _) = False 
isValid _ = True 

evaluateBoard2 :: Player -> Board -> Int
evaluateBoard2 p b 
  | hasWon p b = 100000
  | hasWon (-p) b = -100000
  | otherwise = sum [evaluatePos2 p (y, x) b | y <- [0 .. height b - 1], x<- [0 .. width b - 1]]


evaluateBoard :: Player -> Board -> Int
evaluateBoard p b 
  | hasWon p b = 100000
  | hasWon (-p) b = -100000
  | otherwise = sum [evaluatePos p (y, x) b | y <- [0 .. height b - 1], x<- [0 .. width b - 1]]

evaluatePos2 :: Player -> Pos ->Board -> Int
evaluatePos2 p (y, x) b = if cell * p >0 then points else - points
  where
    cell = getCell (y,x) b
    points = pointsForCell p (y, x) b
    n = if points == 4 then sum [if abs(getCell n b) == length (neighbors (size b) n) -1 && signum (p * getCell n b)<0 then -2 else 0 | n <- neighbors (size b) (y,x)] else 0

pointsForCell :: Player -> Pos -> Board -> Int
pointsForCell p (y, x) b
  | (y == 0 || y == height b - 1) && (x == 0 || x == height b -1) = if cell == 1 then cell + 3  else 0
  | y == 0 || y == height b - 1 || x == 0 || x == height b -1 = if cell == 2 then cell + 2 else cell
  | otherwise = if cell == 3 then cell + 1  else cell
  where
    cell = abs (getCell (y,x) b)
    
evaluatePos :: Player -> Pos -> Board -> Int
evaluatePos p pos b = if c*p<=0 then 0 else heur2 adj pos c b + heurForFriendly adj pos c b + c + snd adj * (5 - criticalVal pos b)
  where
    adj = getAdjOrbs (neighbors pos (size b)) p b
    c = getCell pos b

heurForFriendly :: (Int, Int) -> Pos -> Int -> Board -> Int
heurForFriendly (n, m) pos orbs b 
  | m > 0 = 0
  | crit == 2 = 3
  | crit == 3 = 2
  | crit == orbs + 1 = 2 
  | otherwise = 0
  where
    crit = criticalVal pos b

heur2 :: (Int, Int) -> Pos -> Int -> Board -> Int
heur2 (n, m) pos orbs b = if criticalVal pos b == orbs + 1 && n > 0 then 2 else 0

getAdjOrbs :: [Pos] ->Player -> Board -> (Int, Int)
getAdjOrbs [] _ _ = (0, 0)
getAdjOrbs (pos:ps) p b 
  | c * p > 0 = (n+1, m)
  | c * p < 0 = (n, m+1)
  | otherwise = (n, m)
  where
    c = getCell pos b
    (n, m) = getAdjOrbs ps p b

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

strategyState2 :: StatefulStrategy Int
strategyState2 = wrapStrategy strategy3
{-TTEW-}

criticalVal :: Pos -> Board -> Int
criticalVal p b = length (neighbors (size b) p)

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