235 lines
9.4 KiB
Haskell
235 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.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 { boardWidth :: Int
|
|
, boardHeight :: Int
|
|
, playerCount :: Int
|
|
, myID :: Int
|
|
, players :: [Player]
|
|
, walls :: [Wall]
|
|
, neighborGrid :: A.Array Point [Point]
|
|
, grids :: [A.Array Point Double]
|
|
} deriving (Show)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
|
|
(boardWidth, boardHeight, 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 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)) $
|
|
mapMaybe (\mv -> let e'' = simulate e i mv in (,(mv,e'')) <$> scoreEnv i e'') $
|
|
findDirMoves e i ++ findWallMoves e i
|
|
return $ if d < 2 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 Just sc' = scoreEnv i e'' in Left ((4 * sc + sc') / 5, (mv, e'))
|
|
else
|
|
let i'' = plID $ head active
|
|
e''' = snd $ bestMove e'' i'' (d - 1)
|
|
in if i'' /= i then Right (i'', e''') else
|
|
let Just sc' = scoreEnv i e'''
|
|
in Left ((4 * sc + sc') / 5, (mv, e'))
|
|
|
|
scoreEnv :: Int -> Env -> Maybe Double
|
|
scoreEnv pid env@Env{..} = (myScore -) <$> (sum <$> sequence (map oppScore opponents))
|
|
where
|
|
(me, opponents) = removeAt pid players
|
|
plCost pl = if plWalls pl < 0 then 0 else (grids !! plID pl) ! (plPt pl)
|
|
oppScore pl = let cost = plCost pl
|
|
in guard (not $ isInfinite cost) *> pure (64 / (max 0.25 cost))
|
|
myScore = let cost = plCost me in if plWalls me < 0 then 1000 else bonus - 20 * cost
|
|
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 =
|
|
let myPt = plPt (players !! plID) in do
|
|
newPt <- neighbors env myPt
|
|
return $ Move $ dirFromPoints myPt newPt
|
|
findWallMoves env@Env{..} plID =
|
|
if plWalls (players !! plID) == 0 then [] else do
|
|
--wall <- if plID /= myID then adjacentWalls env (plPt $ players !! myID) else nub $ do
|
|
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.Array Point Double
|
|
floodFill env@Env{..} plID = STA.runSTArray $ do
|
|
grid <- STA.newArray ((0,0),(boardWidth-1,boardHeight-1)) infinity
|
|
let goalEdge = case plID of
|
|
0 -> [ (boardWidth-1,y) | y <- [0..boardHeight-1] ] -- right
|
|
1 -> [ (0,y) | y <- [0..boardHeight-1] ] -- left
|
|
2 -> [ (x,boardHeight-1) | x <- [0..boardWidth-1] ] -- bottom
|
|
3 -> [ (x,0) | x <- [0..boardWidth-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 -> Env
|
|
simulate env plID move =
|
|
case move of
|
|
Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
|
|
Move dir -> 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] -> Env
|
|
updateGrid env walls = 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), ((boardWidth env)-1,(boardHeight 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 < boardWidth) && (ny < boardHeight)
|
|
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 < boardHeight - 1
|
|
return $ Wall (max x x', top) V
|
|
else do
|
|
left <- [ x - 1, x ]
|
|
guard $ left >= 0 && left < boardWidth - 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 == boardWidth - 1
|
|
1 -> x == 0
|
|
2 -> y == boardHeight - 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.Array 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 |