171 lines
7.1 KiB
Haskell
171 lines
7.1 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 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
|
|
|
|
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 Env = Env { boardWidth :: Int
|
|
, boardHeight :: Int
|
|
, playerCount :: Int
|
|
, myID :: Int
|
|
, walls :: [Wall]
|
|
, neighborGrid :: A.Array Point [Point]
|
|
, grids :: [A.Array Point (Maybe Double)]
|
|
} deriving (Show)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
|
|
(boardWidth, boardHeight, playerCount, myID) <-
|
|
parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
|
|
|
|
repeatM $ 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
|
|
putStrLn $ showMove $ fst $ maximumBy (compare `on` snd) $ findMoves players env
|
|
|
|
findMoves :: [Player] -> Env -> [(Either Dir Wall, Double)]
|
|
findMoves players env = dirMoves ++ wallMoves
|
|
where
|
|
dirMoves = do
|
|
pt <- neighbors env $ plPt me
|
|
let players' = map (\p -> if p == me then p { plPt = pt } else p) players
|
|
let costs = zipWith (\grid pt -> if pt >= (0,0) then grid!pt else Just 0) (grids env) $ map plPt players'
|
|
let dir = dirFromPoints (plPt me) pt
|
|
return $ {-traceShowId-} (Left dir, 3 + score (map fromJust costs))
|
|
wallMoves = if plWalls me == 0 then [] else do
|
|
wall <- nub $ do
|
|
pl <- players
|
|
guard $ plPt pl >= (0,0)
|
|
pt <- (plPt pl) : (neighborGrid env ! (plPt pl))
|
|
adjacentWalls env $ pt
|
|
guard $ not $ any (doWallsCross wall) (walls env)
|
|
let env' = updateGrid env (wall : walls env)
|
|
let costs = zipWith (\grid pt -> if pt >= (0,0) then grid!pt else Just 0) (grids env') $ map plPt players
|
|
guard $ all isJust costs
|
|
return $ {-traceShowId-} (Right wall, score (map fromJust costs))
|
|
score costs = myScore myCost - sum (map oppScore oppCosts)
|
|
where (myCost, oppCosts) = removeAt (myID env) costs
|
|
oppScore cost = 80 / (max 2 cost - 1)
|
|
myScore cost = negate $ cost^2
|
|
me = players !! myID env
|
|
|
|
floodFill :: Env -> Int -> A.Array Point (Maybe Double)
|
|
floodFill env@Env{..} plID = go initGrid
|
|
where
|
|
go :: A.Array Point (Maybe Double) -> A.Array Point (Maybe Double)
|
|
go grid = let grid' = force $ A.array (A.bounds grid) $ map (kernel grid) $ A.indices grid
|
|
in if grid' == grid then grid' else go grid'
|
|
kernel grid pt = (pt,) . minimumBy cmpCost . ((grid!pt):) . map (fmap (1+) . (grid!)) $ neighborGrid!pt
|
|
initGrid :: A.Array Point (Maybe Double)
|
|
initGrid = A.array (A.bounds neighborGrid) (map (,Nothing) (A.indices neighborGrid)) //
|
|
case plID of
|
|
0 -> [ ((boardWidth-1,y),Just 1) | y <- [0..boardHeight-1] ] -- right edge
|
|
1 -> [ ((0,y),Just 1) | y <- [0..boardHeight-1] ] -- left edge
|
|
2 -> [ ((x,boardHeight-1),Just 1) | x <- [0..boardWidth-1] ] -- bottom edge
|
|
3 -> [ ((x,0),Just 1) | x <- [0..boardWidth-1] ] -- top edge
|
|
|
|
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 `elem` [wx, wx+1]) && sort [ny, myY] == [wy-1, wy]) ||
|
|
(hv == V && (ny `elem` [wy, wy+1]) && sort [nx, myX] == [wx-1, 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)
|
|
|
|
cmpCost :: Maybe Double -> Maybe Double -> Ordering
|
|
Nothing `cmpCost` Nothing = EQ
|
|
Nothing `cmpCost` _ = GT
|
|
_ `cmpCost` Nothing = LT
|
|
Just x `cmpCost` Just y = x `compare` y
|
|
|
|
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
|
|
|
|
repeatM :: Monad m => m a -> m b
|
|
repeatM m = m >> repeatM m
|
|
|
|
removeAt :: Int -> [a] -> (a, [a])
|
|
removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
|
|
|
|
showMove :: Either Dir Wall -> String
|
|
showMove (Left dir) = show dir
|
|
showMove (Right (Wall (x, y) o)) = unwords [ show x, show y, show o ]
|
|
|
|
showGrid :: A.Array Point (Maybe Double) -> String
|
|
showGrid grid = unlines . map (unwords . map (maybe "X" (show . truncate))) $
|
|
flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
|
|
where ((x0,y0),(xN,yN)) = A.bounds grid |