{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Arrow (first, second, (&&&))
import Control.DeepSeq
import Control.Monad
import Control.Monad.ST
import Control.Monad.State
import Data.Array.IArray ((!), (//))
import Data.Either
import Data.Function
import Data.Functor.Identity
import Data.List
import Data.Maybe
import Data.Monoid
import Debug.Trace
import System.IO
import Text.Parsec hiding (many, (<|>))

import qualified Data.Array.IArray  as A
import qualified Data.Array.Unboxed as A
import qualified Data.Array.MArray  as MA
import qualified Data.Array.ST      as STA

type Point  = (Int, Int)

data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
data Move   = Move Dir | Place Wall deriving (Eq)

data Env = Env { width   :: Int
               , height  :: Int
               , playerCount  :: Int
               , myID         :: Int
               , players      :: [Player]
               , walls        :: [Wall]
               , neighborGrid :: A.Array Point [Point]
               , grids        :: [A.UArray Point Double]
               } deriving (Show)

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering -- DO NOT REMOVE

    (width, height, playerCount, myID) <-
        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine

    forever $ do
        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
        let Just env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls

        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
        let depth = 5 - length (filter ((>= 0) . plWalls) players)
        print $ fst $ bestMove env myID depth

bestMove :: Env -> Int -> Int -> (Move, Env)
bestMove e i d = snd $ maximumBy (compare `on` fst) $ do
    (sc,(mv,e')) <- take (max 1 d) $ sortBy (flip (compare `on` fst)) $
        map (\(mv, e') -> (scoreEnv i e', (mv, e'))) $
        mapMaybe (\mv -> (mv,) <$> simulate e i mv) $
        findDirMoves e i ++ findWallMoves e i
    return $ if d < 1 then (sc,(mv,e')) else flip loopEither (i, e') $ \(i', e'') -> do
        let active = filter ((>= 0) . plWalls) . rotateL (i' + 1) $ players e''
        if length active < 2 then
            let sc' = scoreEnv i e'' in Left ((2 * sc + sc') / 3, (mv, e'))
        else
            let i'' = plID $ head active
                d' = if i'' == i then d - 1 else d - 2
                e''' = snd $ bestMove e'' i'' d'
            in if i'' /= i then Right (i'', e''') else
                let sc' = scoreEnv i e'''
                in Left ((2 * sc + sc') / 3, (mv, e'))

scoreEnv :: Int -> Env -> Double
scoreEnv pid env@Env{..} = myScore - sum (map oppScore opponents)
    where
        (me, opponents) = removeAt pid players
        plCost pl   = (grids !! plID pl) ! (plPt pl)
        oppScore pl = if plWalls pl < 0 then 1500 else 64 / (max 0.25 (plCost pl))
        myScore     = if plWalls me < 0 then 1000 else bonus - 20 * (plCost me)
        bonus       = 48 * (max 0 (fromIntegral (plWalls me)) / maxWalls)**2
        maxWalls    = if playerCount == 3 then 6 else 10

findDirMoves, findWallMoves :: Env -> Int -> [Move]
findDirMoves env@Env{..} plID = do
    let myPt = plPt (players !! plID)
    guard $ A.inRange (A.bounds neighborGrid) myPt
    newPt <- neighborGrid ! myPt
    return $ Move $ dirFromPoints myPt newPt
findWallMoves env@Env{..} plID = do
    guard $ plWalls (players !! plID) > 0
    wall <- nub $ do
        pt   <- nub $ map plPt $ filter ((>=0) . plWalls) players
        pt'  <- pt  : (neighborGrid!pt)
        --pt'' <- pt' : (neighborGrid!pt')
        adjacentWalls env pt'
    guard $ not $ any (doWallsCross wall) walls
    return $ Place wall

floodFill :: Env -> Int -> A.UArray Point Double
floodFill env@Env{..} plID = STA.runSTUArray $ do
    grid <- STA.newArray ((0,0),(width-1,height-1)) infinity
    let goalEdge = case plID of
            0 -> [ (width-1,y)  | y <- [0..height-1] ] -- right
            1 -> [ (0,y)        | y <- [0..height-1] ] -- left
            2 -> [ (x,height-1) | x <- [0..width-1]  ] -- bottom
            3 -> [ (x,0)        | x <- [0..width-1]  ] -- top
    forM_ goalEdge $ flip (MA.writeArray grid) 0
    flip evalStateT (map (,0) goalEdge) $ untilM (null <$> get) $ do
        pts <- get
        put []
        forM_ pts $ \(pt, new) -> do
            let new' = new + 1
            forM_ (neighborGrid!pt) $ \pt' -> do
                old <- lift $ MA.readArray grid pt'
                when (new' < old) $ do
                    lift $ MA.writeArray grid pt' new'
                    modify ((pt', new'):)
    return grid

simulate :: Env -> Int -> Move -> Maybe Env
simulate env plID move =
    case move of
        Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
        Move  dir  -> Just . checkEsc . modPlayer env $ \p@(Player { plPt = (x,y) }) ->
            case dir of
                LEFT  -> p { plPt = (x-1,y) }
                RIGHT -> p { plPt = (x+1,y) }
                UP    -> p { plPt = (x,y-1) }
                DOWN  -> p { plPt = (x,y+1) }
    where modPlayer e f = e { players = modifyAt plID f (players e) }
          decPlWalls p = p { plWalls = plWalls p - 1 }
          checkEsc e
            | escaped plID e = modPlayer e (\p -> p { plPt = (-1,-1), plWalls = -1 })
            | otherwise      = e

updateGrid :: Env -> [Wall] -> Maybe Env
updateGrid env walls = guard (and (zipWith (\g p -> (plWalls p < 0) || not (isInfinite (g ! plPt p))) grids (players env))) *> pure env'
    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
          grids = map (floodFill env') [0..(playerCount env)-1]
          gridIx = ((0,0), ((width env)-1,(height env)-1))

neighbors :: Env -> Point -> [Point]
neighbors Env{..} (myX, myY) = do
    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
    guard $ (nx >= 0) && (ny >= 0) && (nx < width) && (ny < height)
    let wallBetween (Wall (wx, wy) hv) =
            (hv == H && (nx == wx || nx == wx+1) &&
                ((ny == wy-1 && myY == wy) || (myY == wy-1 && ny == wy))) ||
            (hv == V && (ny == wy || ny == wy+1) &&
                ((nx == wx-1 && myX == wx) || (myX == wx-1 && nx == wx)))
    guard $ not $ any wallBetween walls
    return (nx, ny)

adjacentWalls :: Env -> Point -> [Wall]
adjacentWalls env@Env{..} (x, y) = do
    (x', y') <- neighborGrid ! (x, y)
    if y' == y then do
        top <- [ y - 1, y ]
        guard $ top >= 0 && top < height - 1
        return $ Wall (max x x', top) V
    else do
        left <- [ x - 1, x ]
        guard $ left >= 0 && left < width - 1
        return $ Wall (left, max y y') H

doWallsCross :: Wall -> Wall -> Bool
doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
    case (d1, d2) of
        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)

escaped :: Int -> Env -> Bool
escaped pid Env{..} = plWalls (players !! pid) < 0 || case pid of
        0 -> x == width - 1
        1 -> x == 0
        2 -> y == height - 1
        3 -> y == 0
    where (x, y) = plPt (players !! pid)

dirFromPoints :: Point -> Point -> Dir
dirFromPoints from@(x0,y0) to@(x1,y1)
    | x1 < x0 = LEFT
    | x1 > x0 = RIGHT
    | y1 < y0 = UP
    | True    = DOWN

intP :: Stream s m Char => ParsecT s u m Int
intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))

tok s   = spaces *> string s
pointP  = (,) <$> intP <*> intP
orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")

wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
playerP = \plID -> Player plID <$> pointP <*> intP

parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
parseE p src s = either (error . show) id $ parse p src s

modifyAt :: Int -> (a -> a) -> [a] -> [a]
modifyAt ix f xs = let (as, b:cs) = splitAt ix xs in as ++ [f b] ++ cs

removeAt :: Int -> [a] -> (a, [a])
removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)

rotateL :: Int -> [a] -> [a]
rotateL _ [] = []
rotateL n xs = let (as, bs) = splitAt (n `mod` length xs) xs in bs ++ as

untilM :: Monad m => m Bool -> m a -> m ()
untilM mc m = do { c <- mc; if c then return () else m >> untilM mc m }

loopEither :: (a -> Either b a) -> a -> b
loopEither f a = case f a of
    Left  b  -> b
    Right a' -> loopEither f a'

infinity :: Double
infinity = read "Infinity"

instance Show Move where
    show (Move dir)              = show dir
    show (Place (Wall (x, y) o)) = unwords [ show x, show y, show o ]

showGrid :: A.UArray Point Double -> String
showGrid grid = unlines . map (unwords . map (\x -> if isInfinite x then "X" else show (truncate x))) $
                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
    where ((x0,y0),(xN,yN)) = A.bounds grid

traceShowGridId g = trace (showGrid g) g