module Exercise08 where

import Data.Bits ( Bits((.&.), shiftL, shiftR, (.|.)) )
import Data.List

import Data.Sequence (fromList, adjust', index, update, Seq)
import Data.Foldable
import System.Random (mkStdGen, randoms, randomIO, Random)

import Data.Ord
import Data.Maybe
--import Debug.Trace
-- 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 (y, x) b 
  | p < 0 = b !! y !! x <= 0
  | otherwise =  b !! y !! x >= 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 
  | p < 0 = not $ any (> 0) c
  | otherwise = not $ any (< 0) c
      where c = concat b

-- the list of neighbors of a cell
neighbors :: Size -> Pos -> [Pos]
neighbors (r, c) (y, x) = filter (\ t -> fst t >= 0 && fst t < r && snd t >= 0 && snd t < c) [up, down, right, left]
  where up = (y-1, x)
        down = (y+1,x)
        right = (y,x+1)
        left = (y,x-1)

-- 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 = toList (fmap toList updated)
    where seqboard = fromList $map fromList b
          updated = adjust' (adjust' ((*p) . f . abs) x) y seqboard

updateRow :: (Int->Int) -> Player -> Pos -> Row -> Int -> Row
updateRow _ _ _ [] _ = []
updateRow f p pos@(y,x) (c:rest) currentX 
  | currentX /= x = c : updateRow f p pos rest (currentX+1)
  | otherwise = ((*p) . f . abs) c : rest

{- x.2 -}
updatePos3 :: (Int -> Int) -> Player -> Pos -> Seq ( Seq Int) -> Seq ( Seq Int)
updatePos3 f p (y, x) b = updated
    where updated = adjust' (adjust' ((*p) . f . abs) x) y b

seqToB :: Seq (Seq Int) -> Board
seqToB sb = toList $ fmap toList sb

-- place an orb for the given player in the given cell
putOrb :: Player -> Pos -> Board -> Board
putOrb p (y, x) b
  | abs (index (index updated y) x) >= ofOrbs = if hasWon p updatedB then updatedB else seqToB $fst $mapAccumL (\b n-> (putOrbSeq p n b, n)) zeroB nb 
  | otherwise = updatedB
    where seqBoard = fromList $map fromList b
          zeroB = updatePos3 (*0) p (y,x) updated
          updated = updatePos3 (+1) p (y,x) seqBoard
          updatedB = seqToB updated
          nb = neighbors (size b) (y,x)
          ofOrbs = length nb

putOrbSeq :: Player -> Pos -> Seq (Seq Field) -> Seq (Seq Field)
putOrbSeq p (y,x) sBoard 
  | abs (index (index updated y) x) >= ofOrbs = if hasWon p (seqToB updated) then updated else fst $mapAccumL (\b n-> (putOrbSeq p n b, n)) zeroB nb 
  | otherwise = updated
    where zeroB = updatePos3 (*0) p (y,x) updated
          updated = updatePos3 (+1) p (y,x) sBoard
          nb = neighbors (length sBoard, length $ index sBoard 1) (y,x)
          ofOrbs = length nb

{- x.3 -}
--returns the winning player for a concatenated board, 0 if no winner yet
whoWon :: [Int] -> Int
whoWon xs = go xs [] []
  where go [] plus minus
          | null plus = if length minus > 1 then -1 else 0
          | null minus = if length plus > 1 then 1 else 0
          | otherwise = 0
        go (x:xs) plus minus
          | x == 0 = go xs plus minus
          | x < 0 = if not (null plus) then go xs plus (1:minus) else 0
          | x > 0 = if not (null minus) then go xs (1:plus) minus else 0

--negative Infinity constant for minimax
negInf :: Int
negInf = minBound :: Int

--positive infinity constant for minimax
posInf :: Int
posInf = maxBound :: Int

--returns true if the player (arg 1) has an orb in the given field (arg 2), false otherwise
belongs :: Int -> Int -> Bool 
belongs (-1) field = field < 0
belongs 1 field = field > 0
belongs _ _ = False 

--easy, hardcoded way to order the moves so potentially better moves (e.g. corners) are evaluated first -> makes AB pruning faster
allMovesOrdered :: [Pos]
allMovesOrdered = [(0,0),(0,5),(8,5),(8,0), -- corners
  (0,1),(0,2),(0,3),(0,4), -- first row
  (1,0),(2,0),(3,0),(4,0),(5,0),(6,0),(7,0), -- first column
  (1,5),(2,5),(3,5),(4,5),(5,5),(6,5),(7,5), -- last column
  (8,1),(8,2),(8,3),(8,4), -- bottom row
  (1,1),(1,2),(1,3),(1,4), -- second row
  (7,1),(7,2),(7,3),(7,4), -- second to last row
  (2,1),(3,1),(4,1),(5,1),(6,1), -- second column
  (2,4),(3,4),(4,4),(5,4),(6,4), --second to last column
  (6,2),(6,3),
  (2,2),(2,3),
  (5,2),(5,3),
  (3,2),(3,3),
  (4,2),(4,3)]
  {-  (6,2),(6,3),
  (2,2),(2,3),
  (5,2),(5,3),
  (3,2),(3,3),
  (4,2),(4,3)]-}

{-WETT-}
{- -------------------------------------SCORE EVALUATION FUNCTIONS--------------------------------------------- -}
--evaluation function for a given board and a given player. returns an Int (higher => better board)
bewertung :: Player -> Board -> Int
bewertung p b 
  | ww /= 0 && signum ww == p = 100000
  | ww /= 0 && signum ww /= p = -100000
  | otherwise = --trace ("bewertung "++ show (sum (map (evaluateCell b p) allPos) + rowScores + columnScores) ++", p: " ++ show p  ++ ", b: " ++ show b) $
     --trace ("player "++ show p ++ ": eC: " ++ show (sum (map (evaluateCell b p) allPos)) ++ ", rS: " ++ show rowScores ++ ", cS: " ++ show columnScores) $
      sum (map (evaluateCell b p) allPos) + --evaluate all cells
      rowScores + --add score for groups of close to Explosion cells (=> more chain reactions possible)
      columnScores
    where c = concat b
          allPos = [(y,x) | y <- [0..height b-1], x <- [0..width b-1]]
          ww = whoWon (concat b)
          transposed = transpose b
          uc = fromJust $uncons b
          ucT = fromJust $uncons transposed
          rowScores = rowScore (fst uc) [] 0 p 2 + rowScore (last $snd uc) [] 0 p 2 + sum (map (\r -> rowScore r [] 0 p 3) (init $snd uc))
          columnScores = columnScore (fst ucT) [] 0 p 2 + columnScore (last $snd ucT) [] 0 p 2 + sum (map (\r -> columnScore r [] 0 p 3) (init $snd ucT))

evaluateCell :: Board -> Player -> Pos -> Int
evaluateCell b p (y,x) 
  | val == 0 = 0
  | signum valOrig /= p = -val
  | otherwise = --trace ("val: " ++ show val ++ ", nbVals: " ++ show nbVals ++ ", posHeur: " ++ show positionHeuristicVal ++ ", isCrit: " ++ show isCritical) $
      val +
      val * (                          --add CurrentOrbs
      sum nbVals +                   --subtract for closeToExplosion enemy neighbors
      if any (/=0) nbVals then 0 else 
        positionHeuristicVal + isCritical)       -- add for edge/corner/close to explosion
        where valOrig = b !! y !! x
              val = abs $valOrig
              nb = neighbors (9,6) (y,x)
              nbVals = map (evHelper b p) nb
              currentFilledVal = filledVal b (y,x)
              positionHeuristicVal 
                | currentFilledVal == 3 = 1 --kante
                | currentFilledVal == 2 = 4 --ecke
                | otherwise = 0
              isCritical 
                | val == currentFilledVal - 1 = 2
                | otherwise = 0

--next two methods add score for multiple close to Explosion cells after each other
rowScore :: [Field] -> [Int] -> Int -> Player -> Int -> Int
rowScore [] stack current p criticalVal = if length stack == 1 then 0 else 2 * length stack
rowScore (f:row) stack current p criticalVal 
  | null row = if belongs p f && abs f == criticalVal - 1 then 2 * (current + lengthG1 (f:stack)) else  2 * (current + lengthG1 stack) --last element
  | length row == 5 = if belongs p f && abs f == criticalVal -1 then rowScore row (f:stack) current p criticalVal else rowScore row stack current p criticalVal --first element
  | belongs p f && abs f == criticalVal = rowScore row (f:stack) current p criticalVal --more critical in current Block
  | otherwise = rowScore row [] (current +  lengthG1 stack) p criticalVal  -- no more critical in current block
  
columnScore :: [Field] -> [Int] -> Int -> Player -> Int -> Int
columnScore [] stack current p criticalVal = if length stack == 1 then 0 else 2 * length stack
columnScore (f:c) stack current p criticalVal 
  | null c = if belongs p f && abs f == criticalVal - 1 then 2 * (current + lengthG1 (f:stack)) else  2 * (current + lengthG1 stack) --last element
  | length c == 8 = if belongs p f && abs f == criticalVal -1 then columnScore c (f:stack) current p criticalVal else columnScore c stack current p criticalVal --first element
  | belongs p f && abs f == criticalVal = columnScore c (f:stack) current p criticalVal --more critical in current Block
  | otherwise = columnScore c [] (current +  lengthG1 stack) p criticalVal  -- no more critical in current block

--returns the length of the given list if it is > 1, 0 otherwise
lengthG1 :: [Int] -> Int
lengthG1 stack = if l <= 1 then 0 else l
    where l = length stack

evHelper :: Board -> Player -> Pos -> Int
evHelper b p (y,x)
  | belongs p val = 0
  | abs val /= fV -1 = 0
  | otherwise = -(5-fV)
    where val = b !! y !! x
          fV = filledVal b (y,x)

filledVal :: Board -> Pos -> Int
filledVal _ (0,0) = 2
filledVal _ (0,5) = 2
filledVal _ (8,0) = 2
filledVal _ (8,5) = 2
filledVal _ (0,_) = 3
filledVal _ (8,_) = 3
filledVal _ (_,0) = 3
filledVal _ (_,5) = 3
filledVal _ _ = 4

{- -----------------------------------------------------MINIMAX IMPLEMENTATION------------------------------------------------------ -}
minimaxAB :: Board -> Player -> Bool -> Int -> Int -> Int -> Int
minimaxAB b p max depth al be 
  | depth == 0 = --trace ("   bewertung: " ++ show (if max then bewertung p b else bewertung (-1*p) b)) $ 
    if max then bewertung p b else bewertung (-1*p) b
  | ww /= 0 && signum ww == p = if max then 100000 else -100000
  | ww /= 0 && signum ww /= p = if max then -100000 else 100000
  | max = --trace (map (const ' ') [0..3-depth] ++ "getVal " ++ show (getVal posMoves negInf b p max depth al be) ++ " b: " ++show b ++", p: " ++ show p ++ ", max: " ++ show max) $
      getVal posMoves negInf b p max depth al be
  | otherwise = --trace (map (const ' ') [0..3-depth] ++ "getVal " ++ show (getVal posMoves posInf b p max depth al be) ++ " b: " ++show b ++", p: " ++ show p ++ ", max: " ++ show max) $
      getVal posMoves posInf b p max depth al be
    where ww = whoWon (concat b)
          posMoves = possibleMoves b p

{-simulates this loop (for maxi, with min and alpha cutoff for not maxi):
for each next possible Move:
            value = max(value, minimaxAB(child, depth − 1, alpha, beta, False))
            alpha = max(alpha, value)
            if alpha >= beta then
                break --beta cutoff
-}
getVal :: [Pos] -> Int -> Board -> Player -> Bool -> Int -> Int -> Int -> Int
getVal [] value _ _ _ _ _ _ = value
getVal _ value _ _ _ 0 _ _ = value
getVal (m:moves) value b p maxi depth alpha beta 
  | maxi      = if newAlpha >= beta then newValMax else getVal moves newValMax b p maxi depth newAlpha beta
  | otherwise = if newBeta <= alpha then newValMin else getVal moves newValMin b p maxi depth alpha newBeta
    where nextStep = minimaxAB (putOrb p m b) (-1*p) (not maxi) (depth-1) alpha beta
          newValMax = max value nextStep
          newValMin = min value nextStep
          newAlpha = max alpha newValMax
          newBeta = min beta newValMin

--filters illegal moves from the lsit of ordered moves
possibleMoves :: Board -> Player -> [Pos]
possibleMoves b p = filter (\pos -> canPlaceOrb p pos b) allMovesOrdered

--first run of the getVal loop. assumes max is true (which is the case as this is only the first loop)
--this is almost the same as getVal, but is needed because the rest of the minimax implementation only returns scores, not the move that led to it, but I need the move. 
minimaxABStrat :: [Pos] -> Pos -> Int -> Board -> Player -> Int -> Int -> Int -> Pos
minimaxABStrat [] currentPos _ _ _ _ _ _ = currentPos
minimaxABStrat (m:moves) currentPos val b p depth alpha beta = --trace ("nextStep for move " ++ show m ++" has nextStep " ++ show nextStep ++" newValMax: " ++ show newValMax) $
  if newAlpha >= beta then currentBestPos else minimaxABStrat moves currentBestPos newValMax b p depth newAlpha beta
    where nextStep = minimaxAB (putOrb p m b) (-1*p) False (depth-1) alpha beta
          newValMax = max val nextStep
          newAlpha = max alpha newValMax
          currentBestPos = if val < nextStep then m else currentPos


-- Your strategy
strategy :: Strategy
strategy d p b = minimaxABStrat posM (0,0) negInf b p depth negInf posInf
    where posM = possibleMoves b p
          depth = 3 --if length posM <= 25 then 5 else 3

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

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


--not used at the moment, still kept here if i choose to use it again 
cornerMove :: [Double] -> Player -> Board -> Maybe Pos
cornerMove d p b = if null good then Nothing else Just (snd $last good)
    where corners = [(0,0), (0,5), (8,0), (8,5)]
          cornerVals = map (\(y,x) -> (b !! y !! x, (y,x))) corners
          possible = filter (\v -> fst v == 0 || belongs p (fst v)) cornerVals
          good = filter (\v -> abs (fst v) == 1 && belongs p (fst v)) cornerVals

updatePos' :: (Int->Int) -> Player -> Pos -> Board -> Int -> Board
updatePos' _ _ _ [] _ = []
updatePos' f p pos@(y,x) (r:rest) currentY 
  | currentY /= y = r : updatePos'  f p pos rest (currentY+1) 
  | otherwise = updateRow f p pos r 0 : rest

--filledVal working for Board sizes other than (9,6)
{-filledVal :: Board -> Pos -> Int 
filledVal b (y,x) 
  | (y == 0 && x == 0) || (y == 0 && x == w-1) || (y == h-1 && x==0) || (y == h-1 && x == w-1) = 2 --corner
  | y==0 || x == 0 || y == h-1 ||x == w-1 = 3 --edge
  | otherwise = 4
    where (h,w) = size b-}