nybble
/
CodinGame
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Restructure to include an 80ms timeout—ranking is much worse. TBD.

This commit is contained in:
Jesse D. McDonald 2016-05-07 00:00:02 -05:00
parent e0dbc9d164
commit 5546d1bc17
1 changed files with 131 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

208
SmashTheCode/SmashTheCode.hs
View File

@ -1,7 +1,9 @@
{-# LANGUAGE FlexibleContexts, LambdaCase, TupleSections, UnicodeSyntax #-} {-# LANGUAGE LambdaCase, TupleSections, UnicodeSyntax, Rank2Types #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
import Control.Applicative import Control.Applicative
import Control.Arrow (first, second, (&&&)) import Control.Arrow (first, second, (&&&))
import Control.Concurrent
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
import Control.Monad.Writer import Control.Monad.Writer
@ -10,14 +12,17 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Array (Array, (!), (//)) import Data.Array (Array, (!), (//))
import Data.Set (Set)
import System.IO import System.IO
import System.Random
import System.Time import System.Time
import System.Timeout
import System.CPUTime
import Debug.Trace
import qualified Data.Array as A import qualified Data.Array as A
import qualified Data.Foldable as F import qualified Data.Foldable as F
import qualified Data.Traversable as T import qualified Data.Traversable as T
import qualified Data.Set as S
{-# ANN module "HLint: ignore Use if" #-} {-# ANN module "HLint: ignore Use if" #-}
{-# ANN module "HLint: ignore Redundant $" #-} {-# ANN module "HLint: ignore Redundant $" #-}
@ -31,36 +36,35 @@ type Row = Int
data Cell = Empty | Skull | Color Color deriving (Eq, Ord, Show) data Cell = Empty | Skull | Color Color deriving (Eq, Ord, Show)
type Grid = Array (Column, Row) Cell type Grid = Array (Column, Row) Cell
main :: IO () main ∷ IO ()
main = do main = do
hSetBuffering stdout NoBuffering -- DO NOT REMOVE hSetBuffering stdout NoBuffering -- DO NOT REMOVE
flip evalStateT initState $ forever $ do threadDelay =<< randomRIO (0,800000)
forever $ do
blocks ← liftIO (replicateM 8 getBlock) blocks ← liftIO (replicateM 8 getBlock)
start <- liftIO getClockTime start ← liftIO getClockTime
myGrid ← liftIO getGrid myGrid ← liftIO getGrid
opGrid ← liftIO getGrid opGrid ← liftIO getGrid
((col, rot), debug) ← runWriterT (step blocks myGrid) let limiter = evaluateListWithTimeout 88000
liftIO $ mapM_ (hPutStrLn stderr) debug (col, rot) ← step limiter blocks myGrid
end <- col `seq` rot `seq` liftIO getClockTime
end ← col `seq` rot `seq` liftIO getClockTime
let ms = round ((end `diffSeconds` start) * 1000) let ms = round ((end `diffSeconds` start) * 1000)
liftIO $ putStrLn $ unwords [show col, show rot, show ms ++ "ms"]
diffSeconds :: ClockTime -> ClockTime -> Double liftIO $ hPutStrLn stderr $ show ms ++ "ms"
diffSeconds (TOD s' p') (TOD s p) = liftIO $ putStrLn $ unwords [show col, show rot]
fromIntegral ((s' - s) * 1000000000000 + (p' - p)) / 1e12
getBlock :: IO Block getBlock ∷ IO Block
getBlock = do getBlock = do
[colorA, colorB] ← map read . words <$> getLine [colorA, colorB] ← map read . words <$> getLine
pure (colorA, colorB) pure (colorA, colorB)
getGrid :: IO Grid getGrid ∷ IO Grid
getGrid = fmap (A.array ((0,0),(5,11)) . concat) $ getGrid = fmap (A.array ((0,0),(5,11)) . concat) $
forM [0..11] $ \row → do forM [0..11] $ \row → do
line ← getLine line ← getLine
@ -70,57 +74,55 @@ getGrid = fmap (A.array ((0,0),(5,11)) . concat) $
cell '0' = Skull cell '0' = Skull
cell ch = Color (read [ch]) cell ch = Color (read [ch])
type StepState = () newtype Candidates = Candidates [(Int, ((Column, Rotation), Candidates))]
initState = ()
step :: (Applicative m, MonadState StepState m, MonadWriter [String] m) step ∷ Functor f ⇒ (∀a. [a] → f [a]) → [Block] → Grid → f (Column, Rotation)
⇒ [Block] → Grid → m (Column, Rotation) step limiter blocks myGrid = select <$> limiter stream
step blocks myGrid = fst <$> step' 0 blocks myGrid where
Candidates start = candidates blocks myGrid
stream = deepen (take 11 start)
deepen cs = (cs ++) $ do
k ← [0..]
n ← [0..8]
mapMaybe (follow n <=< other k) cs
dummy = (-1000000, ((0, 0), Candidates []))
follow 0 c = Just c
follow _ (_, (_, Candidates [])) = Nothing
follow n (_, (_, Candidates (c':_))) = follow (n-1) c'
other n c@(_, (_, Candidates cs)) = listToMaybe (drop n cs)
select cs = trace (show $ length cs)
$ fst $ snd $ maximumBy (compare `on` fst) (dummy:cs)
step' :: (Applicative m, MonadState StepState m, MonadWriter [String] m) candidates ∷ [Block] → Grid → Candidates
⇒ Int → [Block] → Grid → m ((Column, Rotation), Int) candidates [] _ = Candidates []
step' depth (block:blocks) myGrid = do candidates (block:blocks) grid = Candidates best
let try c rot = do where
result ← simulate myGrid block c rot try c rot = do
pure (score result, (result, (c, rot))) (grid', points) ← simulate grid block c rot
let candidates = catMaybes $ try <$> [3,2,4,1,5,0] <*> [1,3,0,2] let score1 = score grid' points
let best = sortBy (flip compare `on` fst) candidates let adjust (score2, (mv', cs')) =
let scoreAvg = (2 * score1 + 3 * score2) `div` 5
in (scoreAvg, ((c, rot), cs'))
let Candidates cs = candidates blocks grid'
pure $! score1 `seq` (score1, ((c, rot), Candidates (map adjust cs)))
hint = uncurry (+) block `div` 2
columns = filter (\c → c >= 0 && c <= 5) $ map (hint +) [0,-1,1,-2,2,-3,3,-4,4,-5,5]
rotations = [1,0,3,2]
best = sortBy (flip compare `on` fst) . catMaybes
$ try <$> columns <*> rotations
let limit = case depth of { 0 -> 9; 1 -> 1; _ -> 1 } score ∷ Grid → Int → Int
best' ← if length (take limit best) < 1 || null blocks then pure best else do score grid points = 10*points + matches -- + 50*nonSkulls
s ← get
candidates' ← forM (take limit best) $
\(score1, ((grid', points), (c, rot))) → do
let ((_, score2), w) = flip evalState s $ runWriterT $
step' (depth + 1) blocks grid'
tell w
pure (score1 + score2, ((grid', points), (c, rot)))
pure $ sortBy (flip compare `on` fst) candidates'
-- tell [show depth ++ ": " ++ show (map fst $ take limit best')]
case best' of
[] → pure ((0, 0), -1000000)
((score1, (_, move1)):_) → pure (move1, score1)
score :: (Grid, Int) → Int
score (grid, points) = 1000*points + 5*nonSkulls + matches
where where
free = length $ filter (== Empty) $ A.elems grid free = length $ filter (== Empty) $ A.elems grid
nonSkulls = length $ filter (/= Skull) $ A.elems grid nonSkulls = length $ filter (/= Skull) $ A.elems grid
levels = length $ takeWhile emptyLevel [0..11] levels = length $ takeWhile emptyLevel [0..11]
matches = sum . map (^2) . filter (> 1) . map length $ colorGroups
emptyLevel r = all (\c → grid!(c,r) == Empty) [0..5] emptyLevel r = all (\c → grid!(c,r) == Empty) [0..5]
matches = sum (map (matchingNeighbours grid) (A.indices grid)) colorCells = filter (isColor . snd) $ A.assocs grid
colorGroups = connectedGroups adjacentMatch colorCells
matchingNeighbours grid (col, row) = if isColor cell then sum (map match ns) else 0 simulate ∷ Grid → Block → Column → Rotation → Maybe (Grid, Int)
where
cell = grid!(col, row)
ns = [(col,row-1), (col,row+1), (col-1,row), (col+1,row)]
match (c, r) | c < 0 || c > 5 || r < 0 || r > 11 = 0
| grid!(c,r) == cell = 1
| otherwise = 0
simulate :: Grid → Block → Column → Rotation → Maybe (Grid, Int)
simulate grid (colorA, colorB) col rot simulate grid (colorA, colorB) col rot
| not (A.inRange (A.bounds grid) crA) || | not (A.inRange (A.bounds grid) crA) ||
not (A.inRange (A.bounds grid) crB) || not (A.inRange (A.bounds grid) crB) ||
@ -134,7 +136,17 @@ simulate grid (colorA, colorB) col rot
3 → ((col,0), (col, 1)) 3 → ((col,0), (col, 1))
startGrid = grid // [ (crB, Color colorB), (crA, Color colorA) ] startGrid = grid // [ (crB, Color colorB), (crA, Color colorA) ]
simFall :: (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid addSkulls ∷ Int → Grid → Grid
addSkulls nskulls grid = newGrid
where
packColumn c = zipWith (\r x → ((c,r),x)) [11,10..0]
$ (++ repeat Empty)
$ (++ replicate nskulls Skull)
$ takeWhile (/= Empty)
$ map (\r → grid!(c,r)) [11,10..0]
newGrid = A.array ((0,0),(5,11)) $ concatMap packColumn [0..5]
simFall ∷ (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid
simFall grid = simDisappear newGrid simFall grid = simDisappear newGrid
where where
packColumn c = zipWith (\r x → ((c,r),x)) [11,10..0] packColumn c = zipWith (\r x → ((c,r),x)) [11,10..0]
@ -143,7 +155,7 @@ simFall grid = simDisappear newGrid
$ map (\r → grid!(c,r)) [11,10..0] $ map (\r → grid!(c,r)) [11,10..0]
newGrid = A.array ((0,0),(5,11)) $ concatMap packColumn [0..5] newGrid = A.array ((0,0),(5,11)) $ concatMap packColumn [0..5]
simDisappear :: (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid simDisappear ∷ (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid
simDisappear grid stage = case null erased of simDisappear grid stage = case null erased of
True → pure grid True → pure grid
False → do False → do
@ -152,9 +164,9 @@ simDisappear grid stage = case null erased of
where where
colorCells = filter (isColor . snd) $ A.assocs grid colorCells = filter (isColor . snd) $ A.assocs grid
skullCells = filter ((== Skull) . snd) $ A.assocs grid skullCells = filter ((== Skull) . snd) $ A.assocs grid
groups = connectedGroups adjacentMatch (S.fromList colorCells) groups = connectedGroups adjacentMatch colorCells
largeGroups = filter ((>= 4) . S.size) groups largeGroups = filter ((>= 4) . length) groups
erasedColors = concatMap S.toList largeGroups erasedColors = concat largeGroups
erasedSkulls = filter (\(cr,_) → any (adjacent cr . fst) erasedColors) skullCells erasedSkulls = filter (\(cr,_) → any (adjacent cr . fst) erasedColors) skullCells
erased = erasedColors ++ erasedSkulls erased = erasedColors ++ erasedSkulls
erasedGrid = grid // map (second (const Empty)) erased erasedGrid = grid // map (second (const Empty)) erased
@ -162,30 +174,72 @@ simDisappear grid stage = case null erased of
chainPower = if stage < 2 then 0 else 8 * 2^(stage-2) chainPower = if stage < 2 then 0 else 8 * 2^(stage-2)
uniqueColors = length . nub $ map snd erasedColors uniqueColors = length . nub $ map snd erasedColors
colorBonus = if uniqueColors < 2 then 0 else 2^(uniqueColors-1) colorBonus = if uniqueColors < 2 then 0 else 2^(uniqueColors-1)
groupBonus = sum (map (perGroupBonus . S.size) largeGroups) groupBonus = sum (map (perGroupBonus . length) largeGroups)
perGroupBonus n = if n >= 11 then 8 else n - 4 perGroupBonus n = if n >= 11 then 8 else n - 4
scale = max 1 $ min 999 $ chainPower + colorBonus + groupBonus scale = max 1 $ min 999 $ chainPower + colorBonus + groupBonus
isColor :: Cell → Bool isColor ∷ Cell → Bool
isColor Empty = False isColor Empty = False
isColor Skull = False isColor Skull = False
isColor (Color _) = True isColor (Color _) = True
adjacent :: (Column,Row) → (Column,Row) → Bool adjacent ∷ (Column,Row) → (Column,Row) → Bool
adjacent (c1,r1) (c2,r2) = (c1 == c2 && (r1 == r2 - 1 || r1 == r2 + 1)) || adjacent (c1,r1) (c2,r2) = (c1 == c2 && (r1 == r2 - 1 || r1 == r2 + 1)) ||
(r1 == r2 && (c1 == c2 - 1 || c1 == c2 + 1)) (r1 == r2 && (c1 == c2 - 1 || c1 == c2 + 1))
adjacentMatch :: ((Column, Row), Cell) → ((Column, Row), Cell) → Bool adjacentMatch ∷ ((Column, Row), Cell) → ((Column, Row), Cell) → Bool
adjacentMatch (cr1,x1) (cr2,x2) = x1 == x2 && adjacent cr1 cr2 adjacentMatch (cr1,x1) (cr2,x2) = x1 == x2 && adjacent cr1 cr2
connectedGroups :: Ord a ⇒ (a → a → Bool) → Set a → [Set a] connectedGroups ∷ (a → a → Bool) → [a] → [[a]]
connectedGroups p rem = case S.minView rem of connectedGroups p rem = case rem of
Nothing → [] [] → []
Just (x, rem') → (x:rem') →
let go fringe others = case S.minView fringe of let go fringe others = case fringe of
Nothing → (S.empty, others) [] → ([], others)
Just (y, fringe') → case S.partition (p y) others of (y:fringe') →
(adj, notAdj) → first (S.insert y) $ let (adj, notAdj) = partition (p y) others
go (S.union fringe' adj) notAdj in first (y:) $ go (fringe' ++ adj) notAdj
(conn, notConn) = go (S.singleton x) rem' (conn, notConn) = go [x] rem'
in conn : connectedGroups p notConn in conn : connectedGroups p notConn
diffSeconds ∷ ClockTime → ClockTime → Double
diffSeconds (TOD s' p') (TOD s p) =
fromIntegral ((s' - s) * 1000000000000 + (p' - p)) / 1e12
-- From package "random", not available in CodinGame
class Monad m ⇒ MonadRandom m where
getRandom ∷ Random a ⇒ m a
getRandoms ∷ Random a ⇒ m [a]
getRandomR ∷ Random a ⇒ (a, a) → m a
getRandomRs ∷ Random a ⇒ (a, a) → m [a]
instance MonadIO m ⇒ MonadRandom m where
getRandom = liftIO randomIO
getRandoms = liftIO $ fmap randoms newStdGen
getRandomR = liftIO . randomRIO
getRandomRs r = liftIO $ fmap (randomRs r) newStdGen
shuffle ∷ MonadRandom m ⇒ [a] → m [a]
shuffle [] = return []
shuffle [x] = return [x]
shuffle xs = do
i ← getRandomR (0, length xs - 1)
let (as, x:bs) = splitAt i xs
xs' ← shuffle (as ++ bs)
return (x:xs')
-- Compute elements of the list to WHNF for `t` microseconds. After
-- `t` microseconds, abandon the calculation and terminate the list.
evaluateListWithTimeout :: Integer -> [a] -> IO [a]
evaluateListWithTimeout t xs = do
end <- (+) <$> getCPUTime <*> pure (1000000 * t)
flip fix xs $ \loop xs -> do
now <- getCPUTime
r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
case xs of
[] -> pure []
(a:as) -> pure $! a `seq` (a:as)
case r of
Nothing -> pure []
Just [] -> pure []
Just (a:as) -> (a:) <$> loop as