{-# LANGUAGE TupleSections #-}

module Exercise08 where

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

-- 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
  | cell == 0 = True
  | cell > 0 = p > 0
  | cell < 0 = p < 0
  where
    cell = getCell (y, x) b

-- 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
  | p == 1 = not . any (< 0) . concat
  | otherwise = not . any (> 0) . concat

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

-- 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 = boardNewBef ++ rowNew : drop 1 boardNewEqAf
  where
    (boardNewBef, boardNewEqAf) = splitAt y b
    (rowNewBef, rowNewEqAf) = splitAt x (b !! y)
    rowNew = rowNewBef ++ (newVal * p) : drop 1 rowNewEqAf
    newVal = f $abs $getCell (y, x) b

{- x.2 -}

-- place an orb for the given player in the given cell
putOrb :: Player -> Pos -> Board -> Board
putOrb p (y, x) b = if overflow then fst $until (\(boar, n) -> hasWon p boar || null n) (\(boar, n) -> (putOrb p (head n) boar, tail n)) (newBoardOverflow, neighb) else newBoard
  where
    newBoardOverflow = updatePos (\z -> z - length neighb) p (y, x) newBoard
    newBoard = updatePos (1 +) p (y, x) b
    overflow = abs (getCell (y, x) newBoard) >= length neighb
    neighb = neighbors (length b, length (b !! y)) (y, x)

{- x.3 -}

{-WETT-}
-- Your strategy
strategy :: Strategy
strategy ran p b = snd (maximumBy (\x y -> compare (fst x * p) (fst y * p)) (map (\x -> (findBest x (-5000, 5000) tiefe p, snd x)) pMPair))
  where
    possibleMoves = [(a, c) | a <- [0 .. length b -1], c <- [0 .. length (head b) -1], canPlaceOrb p (a, c) b]
    pMPair = zip (replicate lengthpM b) possibleMoves
    tiefe = if lengthpM <= 15 then 4 else 3
    lengthpM = length possibleMoves

findBest :: (Board, (Int, Int)) -> (Int, Int) -> Int -> Player -> Int
findBest (b, (y, x)) (alpha, beta) stepsLeft p
  | stepsLeft <= 0 = calculateValue newBoard
  | hasWon p newBoard = 5000 * p
  | otherwise = maximumBy (\x y -> compare (x * (- p)) (y * (- p))) (if p == -1 then movesP1 else movesP2)
  where
    newBoard = putOrb p (y, x) b
    possibleMoves = [(a, c) | a <- [0 .. length b -1], c <- [0 .. length (head b) -1], canPlaceOrb (- p) (a, c) newBoard]
    pMPair = zip (replicate lengthpM newBoard) possibleMoves
    movesP1 = snd (mapAccumL (\(alpha, beta) x -> if beta <= alpha then ((alpha, beta), alpha) else let recur = findBest x (alpha, beta) tiefe (- p) in ((max alpha recur, beta), recur)) (alpha, beta) pMPair)
    movesP2 = snd (mapAccumL (\(alpha, beta) x -> if beta <= alpha then ((alpha, beta), beta) else let recur = findBest x (alpha, beta) tiefe (- p) in ((alpha, min beta recur), recur)) (alpha, beta) pMPair)
    tiefe = if lengthpM <= 15 then stepsLeft - 1 else stepsLeft - 2
    lengthpM = length possibleMoves

-- This heuristic is inspired by the strategy set out on: https://brilliant.org/discussions/thread/artificial-intelligence-for-chain-reaction/
calculateValue :: Board -> Int
calculateValue b
  | p1Won = 5000
  | p2Won = -5000
  | otherwise = p1Points - p2Points
  where
    p1Won = p2n == 0
    p2Won = p1n == 0
    p1n = sum (filter (> 0) (concat b))
    p2n = sum (filter (< 0) (concat b))
    p1Prop = [(u, i) | u <- [0 .. r -1], i <- [0 .. c -1], (b !! u !! i) > 0]
    p1Neigh = map (\x -> (neighbors (r, c) x, x)) p1Prop
    p1OvNeigh = map (\(n, _) -> filter (\x -> nextOverflow (r, c) x (-1) b) n) p1Neigh
    p1Points = 2 * p1n + sum (map (\((n, po), nOv) -> if null nOv then (if length n -1 == getCell po b then 2 else 0) + specialValue (r, c) po else - (length nOv) * (5 - length n)) (zip p1Neigh p1OvNeigh))

    p2Prop = [(u, i) | u <- [0 .. r -1], i <- [0 .. c -1], (b !! u !! i) < 0]
    p2Neigh = map (\x -> (neighbors (r, c) x, x)) p2Prop
    p2OvNeigh = map (\(n, _) -> filter (\x -> nextOverflow (r, c) x 1 b) n) p2Neigh
    p2Points = 2 * p2n + sum (map (\((n, po), nOv) -> if null nOv then (if length n -1 == - getCell po b then 2 else 0) + specialValue (r, c) po else - (length nOv) * (5 - length n)) (zip p2Neigh p2OvNeigh))

    (r, c) = (length b, length (head b))

nextOverflow :: (Int, Int) -> (Int, Int) -> Int -> Board -> Bool
nextOverflow (r, c) (y, x) p b
  | p == 1 && cell > 0 = neighbC == cell + 1
  | p == -1 && cell < 0 = neighbC == abs cell + 1
  | otherwise = False
  where
    cell = getCell (y, x) b
    neighbC = length (neighbors (r, c) (y, x))

specialValue :: (Int, Int) -> (Int, Int) -> Int
specialValue (r, c) (y, x)
  | (y, x) == (0, 0) || (y, x) == (0, c -1) || (y, x) == (r -1, 0) || (y, x) == (r -1, c -1) = 4
  | y == 0 || x == 0 || y == r -1 || x == c -1 = 3
  | otherwise = 0

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