239 lines
9.4 KiB
Haskell
239 lines
9.4 KiB
Haskell
{-# 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 |