module Exercise_10 where

import Data.List
import Data.Array
import Data.Ord (comparing)
import Data.Maybe (fromJust)
import Control.Arrow (first, second)
import Control.Monad (liftM2)

import Test.QuickCheck

{-H10.1-}
data Player = V | H
  deriving (Eq, Show)
data Field = P Player | E
  deriving (Eq, Show)
type Row = [Field]
type Column = [Field]
type Board = [Row]
data Game = Game Board Player
  deriving (Eq, Show)

row :: Board -> Int -> Row
row = (!!)

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

height :: Board -> Int
height = length

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

{-H10.1.1-}
prettyShowBoard :: Board -> String
prettyShowBoard = unlines . map (concatMap toString)
  where
    toString E = "+"
    toString (P V) = "V"
    toString (P H) = "H"

{-H10.1.2-}
-- position on a board (row, column)
-- (0,0) corresponds to the top left corner
type Pos = (Int, Int)

isValidMove :: Game -> Pos -> Bool
isValidMove (Game b pl) p = all (liftM2 (&&) exists free) (playerMovePs pl p)
  where
    exists (r, c) = r >= 0 && r < height b && c >= 0 && c < width b
    free (r, c) = b !! r !! c == E

{-H10.1.3-}
canMove :: Game -> Bool
canMove g = any (isValidMove g) (freeFields g)

freeFields :: Game -> [Pos]
freeFields (Game b _) = filter ((E ==) . fieldAt b) (positions b)

fieldAt :: Board -> Pos -> Field
fieldAt b (r, c) = b !! r !! c

positions :: Board -> [Pos]
positions b = [(r, c) | r <- rowIndexes b, c <- colIndexes b]

{-H10.1.4-}
updateBoard :: Board -> Pos -> Field -> Board
updateBoard b (r, c) f = map transform (rowIndexes b)
  where
    transform r' = map (replace r') (colIndexes b)
    replace r' c'
      | r == r' && c == c' = f
      | otherwise = b !! r' !! c'

rowIndexes :: Board -> [Int]
rowIndexes b = [0..height b - 1]

colIndexes :: Board -> [Int]
colIndexes b = [0..width b - 1]

{-H10.1.5-}
playMove :: Game -> Pos -> Game
playMove (Game b pl) p =
  Game (updateBoardPs (P pl) b (playerMovePs pl p)) (nextPlayer pl)

playerMovePs :: Player -> Pos -> [Pos]
playerMovePs V p = [p, first succ p]
playerMovePs H p = [p, second succ p]

nextPlayer :: Player -> Player
nextPlayer V = H
nextPlayer H = V

updateBoardPs :: Field -> Board -> [Pos] -> Board
updateBoardPs f = foldl (\b' p -> updateBoard b' p f)

{-H10.1.6-}
{-WETT-}
type Strategy = [Double] -> Game -> Pos
type BoardArray = Array (Int, Int) Field

christmasAI :: Strategy
christmasAI rs (Game b pl) = toCurPlayerMove pl move
  where
    move
      | not (null vAdjOpeningMoves') = head vAdjOpeningMoves'
      | not (null openingMoves') = head openingMoves'
      | not (null vAdjBestUnsafeMoves') = randomMoveOf rs vAdjBestUnsafeMoves'
      | not (null unsafeMoves') = randomMoveOf rs bestUnsafeMoves'
      | otherwise = head safeMoves'

    b' = toVirtualBoard pl b
    ba' = toBoardArray b'

    safeMoves' = safeMoves ba'
    unsafeMoves' = unsafeMoves ba'
    bestUnsafeMoves' = bestMovesOf ba' unsafeMoves'
    openingMoves' = openingMoves `intersect` bestUnsafeMoves'
    vAdjBestUnsafeMoves' = vAdjacentToOppMoves ba' bestUnsafeMoves'
    vAdjOpeningMoves' = openingMoves `intersect` vAdjBestUnsafeMoves'

    {- Field access utils -}

    fieldAt' :: BoardArray -> Pos -> Field
    fieldAt' = (!)

    {- Navigation / finding adjacent positions -}

    left :: Pos -> Pos
    left = second pred

    right :: Pos -> Pos
    right = second succ

    up :: Pos -> Pos
    up = first pred

    down :: Pos -> Pos
    down = first succ

    {- Board creation and manipulation utils -}

    mapBoardRows :: (Pos -> a) -> [[a]]
    mapBoardRows f = mapBoardRC (curry f)

    mapBoardColumns :: (Pos -> a) -> [[a]]
    mapBoardColumns f = mapBoardCR (curry f)

    mapBoardRC :: (Int -> Int -> a) -> [[a]]
    mapBoardRC f = map (\r -> map (f r) [0..11]) [0..11]

    mapBoardCR :: (Int -> Int -> a) -> [[a]]
    mapBoardCR f = map (\r -> map (`f` r) [0..11]) [0..11]

    mapBoard :: (Field -> Field) -> Board -> Board
    mapBoard  = map . map

    playMove' :: BoardArray -> Pos -> BoardArray
    playMove' ba pos = ba // [(pos, P V), (down pos, P V)]

    {- Position / move lists -}

    freePos :: BoardArray -> [Pos]
    freePos ba = filter (isFree ba) allPos

    allPos :: [Pos]
    allPos = concat $ mapBoardRows id

    allowedMoves :: BoardArray -> [Pos]
    allowedMoves ba = filter (isAllowedMove ba) (freePos ba)

    safeMoves :: BoardArray -> [Pos]
    safeMoves ba = filter isSafe (allowedMoves ba)
      where
        isSafe p = oppCanNotCover ba p && oppCanNotCover ba (down p)

    unsafeMoves :: BoardArray -> [Pos]
    unsafeMoves ba = allowedMoves ba \\ safeMoves ba

    bestMovesOf :: BoardArray -> [Pos] -> [Pos]
    bestMovesOf _ [pos] = [pos]
    bestMovesOf ba pos = map snd $ filter ((bestScore ==) . fst) scoredMoves
      where
        bestScore = bestScoreOf scoredMoves
        scoredMoves = scoreMoves ba pos

    vAdjacentToOppMoves :: BoardArray -> [Pos] -> [Pos]
    vAdjacentToOppMoves = filter . isVAdjacentToOpp

    openingMoves :: [Pos]
    openingMoves = [(0,1), (0,10), (10,1), (10,10)]

    {- Move and position validation and checks -}

    isInBounds :: Pos -> Bool
    isInBounds (r, c) = r >= 0 && r < 12 && c >= 0 && c < 12

    isFree :: BoardArray -> Pos -> Bool
    isFree = ((E ==) .) . fieldAt'

    isCovered :: BoardArray -> Pos -> Bool
    isCovered = (not .) . isFree

    isInBoundsAndFree :: BoardArray -> Pos -> Bool
    isInBoundsAndFree ba pos = isInBounds pos && isFree ba pos

    isAllowedMove :: BoardArray -> Pos -> Bool
    isAllowedMove ba pos =
      isInBoundsAndFree ba pos && isInBoundsAndFree ba (down pos)

    oppCanNotCover :: BoardArray -> Pos -> Bool
    oppCanNotCover ba pos =
      not (isInBoundsAndFree ba (left pos)) &&
      not (isInBoundsAndFree ba (right pos))

    coveredByOpp :: BoardArray -> Pos -> Bool
    coveredByOpp = ((P H ==) .) . fieldAt'

    isVAdjacentToOpp :: BoardArray -> Pos -> Bool
    isVAdjacentToOpp ba pos =
      (isInBounds uP && coveredByOpp ba uP) || (isInBounds dP && coveredByOpp ba dP)
      where
        uP = up pos
        dP = down pos

    {- Board / move scoring -}

    scoreBoard :: BoardArray -> Int
    scoreBoard ba =
      countNOMoves ba -
      countNOOppMoves ba +
      2 * countNOSafeMoves ba -
      2 * countNOOppSafeMoves ba -
      countNOOppSMCMoves ba

    scoreMoves :: BoardArray -> [Pos] -> [(Int, Pos)]
    scoreMoves ba = map ((,) =<< scoreMove ba)

    scoreMove :: BoardArray -> Pos -> Int
    scoreMove = (scoreBoard . ) . playMove'

    bestScoreOf :: [(Int, Pos)] -> Int
    bestScoreOf = fst . maximumBy (comparing fst)

    -- Non-overlapping moves.
    countNOMoves :: BoardArray -> Int
    countNOMoves = sum . map (countNOMovesWhereEq E) . mapBoardColumns . (!)

    -- Non-overlapping opponent moves.
    countNOOppMoves :: BoardArray -> Int
    countNOOppMoves = sum . map (countNOMovesWhereEq E) . mapBoardRows . (!)

    -- Non-overlapping safe moves.
    countNOSafeMoves :: BoardArray -> Int
    countNOSafeMoves =
      sum . map (countNOMovesWhereEq True) . mapBoardColumns . leftAndRightCovered
      where
        leftAndRightCovered ba pos
          | isCovered ba pos = False
          | isInBounds lP && isFree ba lP = False
          | otherwise = not (isInBounds rP && isFree ba rP)
          where
            lP = left pos
            rP = right pos

    -- Non-overlapping opponent safe moves.
    countNOOppSafeMoves :: BoardArray -> Int
    countNOOppSafeMoves =
      sum . map (countNOMovesWhereEq True) . mapBoardRows . upAndDownCovered
      where
        upAndDownCovered ba pos
          | isCovered ba pos = False
          | isInBounds uP && isFree ba uP = False
          | otherwise = not (isInBounds dP && isFree ba dP)
          where
            uP = up pos
            dP = down pos

    -- Non-overlapping opponent moves creating safe moves.
    countNOOppSMCMoves :: BoardArray -> Int
    countNOOppSMCMoves =
      sum . map (countNOMovesWhereEq True) . mapBoardRows . upFreeXorDownFree
      where
        upFreeXorDownFree ba pos
          | isCovered ba pos = False
          | otherwise = upFree `xor` downFree
          where
            uP = up pos
            dP = down pos
            upFree = isInBounds uP && isFree ba uP
            downFree = isInBounds dP && isFree ba dP

    countNOMovesWhereEq :: Eq a => a -> [a] -> Int
    countNOMovesWhereEq c =
      sum . map ((`div` 2) . length) . filter ((c ==) . head) . group

    xor :: Bool -> Bool -> Bool
    xor x y = (x || y) && not (x && y)

    {- Board, move and position conversion -}

    toCurPlayerMove :: Player -> Pos -> Pos
    toCurPlayerMove V = id
    toCurPlayerMove H = rotatePos45DegInv

    -- Rotate the board if we are H, so we can always play as V.
    toVirtualBoard :: Player -> Board -> Board
    toVirtualBoard V = id
    toVirtualBoard H = rotateBoard45Deg . mapBoard invField

    invField :: Field -> Field
    invField E = E
    invField (P V) = P H
    invField (P H) = P V

    rotateBoard45Deg :: Board -> Board
    rotateBoard45Deg board = mapBoardRows (fieldAt'' board . rotatePos45DegInv)
      where fieldAt'' b'' (r, c) = b'' !! r !! c

    rotatePos45DegInv :: Pos -> Pos
    rotatePos45DegInv (r, c) = (11 - c, r)

    toBoardArray :: Board -> BoardArray
    toBoardArray = listArray ((0, 0), (11, 11)) . concat

    {- Random move selection -}

    randomMoveOf :: [Double] -> [Pos] -> Pos
    randomMoveOf = (head .) . infRandomPosOf

    infRandomPosOf :: [Double] -> [Pos] -> [Pos]
    infRandomPosOf rs' ps = map ((ps !!) . round . (maxI *)) rs'
      where maxI = pred $ genericLength ps
{-TTEW-}

{-H10.1.7-}
play :: [[Double]] -> Int -> Strategy -> Strategy -> ([Board], Player)
play rss dim me you = playRec rss [b] [(V, me), (H, you)] V
  where b = replicate dim (replicate dim E)

playRec :: [[Double]] -> [Board] -> [(Player, Strategy)] -> Player -> ([Board], Player)
playRec (rs:rss) bs plss pl
  | not (isValidMove g p) = (tBs bs, nextPlayer pl)
  | not (canMove g') = (tBs bs', pl)
  | otherwise = playRec rss bs' plss (nextPlayer pl)
  where
    bs' = b':bs
    g = Game (head bs) pl
    g'@(Game b' _) = playMove g p
    p = s rs g where s = fromJust $ lookup pl plss
    tBs = reverse . init

genRandomZeroOne :: Gen [Double]
genRandomZeroOne = mapM (const $ choose (0::Double, 1)) [(1 :: Integer)..]

playAndPrint :: Int -> Strategy -> Strategy -> IO ()
playAndPrint dim sh sv = do
  rss <- generate $ mapM (const genRandomZeroOne) [(1 :: Integer)..]
  let (bs, w) = play rss dim sh sv
  putStr $ unlines (map prettyShowBoard bs) ++ "\nWinner: " ++ show w ++ "\n"