From 5546d1bc177924feea92c61ac40831aa040c75ea Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sat, 7 May 2016 00:00:02 -0500 Subject: [PATCH] =?UTF-8?q?Restructure=20to=20include=20an=2080ms=20timeou?= =?UTF-8?q?t=E2=80=94ranking=20is=20much=20worse.=20TBD.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- SmashTheCode/SmashTheCode.hs | 208 ++++++++++++++++++++++------------- 1 file changed, 131 insertions(+), 77 deletions(-) diff --git a/SmashTheCode/SmashTheCode.hs b/SmashTheCode/SmashTheCode.hs index d371b2e..0f1e04e 100644 --- a/SmashTheCode/SmashTheCode.hs +++ b/SmashTheCode/SmashTheCode.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE FlexibleContexts, LambdaCase, TupleSections, UnicodeSyntax #-} +{-# LANGUAGE LambdaCase, TupleSections, UnicodeSyntax, Rank2Types #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} import Control.Applicative import Control.Arrow (first, second, (&&&)) +import Control.Concurrent import Control.Monad import Control.Monad.State import Control.Monad.Writer @@ -10,14 +12,17 @@ import Data.List import Data.Maybe import Data.Monoid import Data.Array (Array, (!), (//)) -import Data.Set (Set) import System.IO +import System.Random import System.Time +import System.Timeout +import System.CPUTime + +import Debug.Trace import qualified Data.Array as A import qualified Data.Foldable as F import qualified Data.Traversable as T -import qualified Data.Set as S {-# ANN module "HLint: ignore Use if" #-} {-# ANN module "HLint: ignore Redundant $" #-} @@ -31,36 +36,35 @@ type Row = Int data Cell = Empty | Skull | Color Color deriving (Eq, Ord, Show) type Grid = Array (Column, Row) Cell -main :: IO () +main ∷ IO () main = do hSetBuffering stdout NoBuffering -- DO NOT REMOVE - flip evalStateT initState $ forever $ do + threadDelay =<< randomRIO (0,800000) + + forever $ do blocks ← liftIO (replicateM 8 getBlock) - start <- liftIO getClockTime + start ← liftIO getClockTime myGrid ← liftIO getGrid opGrid ← liftIO getGrid - ((col, rot), debug) ← runWriterT (step blocks myGrid) - liftIO $ mapM_ (hPutStrLn stderr) debug - - end <- col `seq` rot `seq` liftIO getClockTime + let limiter = evaluateListWithTimeout 88000 + (col, rot) ← step limiter blocks myGrid + end ← col `seq` rot `seq` liftIO getClockTime let ms = round ((end `diffSeconds` start) * 1000) - liftIO $ putStrLn $ unwords [show col, show rot, show ms ++ "ms"] -diffSeconds :: ClockTime -> ClockTime -> Double -diffSeconds (TOD s' p') (TOD s p) = - fromIntegral ((s' - s) * 1000000000000 + (p' - p)) / 1e12 + liftIO $ hPutStrLn stderr $ show ms ++ "ms" + liftIO $ putStrLn $ unwords [show col, show rot] -getBlock :: IO Block +getBlock ∷ IO Block getBlock = do [colorA, colorB] ← map read . words <$> getLine pure (colorA, colorB) -getGrid :: IO Grid +getGrid ∷ IO Grid getGrid = fmap (A.array ((0,0),(5,11)) . concat) $ forM [0..11] $ \row → do line ← getLine @@ -70,57 +74,55 @@ getGrid = fmap (A.array ((0,0),(5,11)) . concat) $ cell '0' = Skull cell ch = Color (read [ch]) -type StepState = () -initState = () +newtype Candidates = Candidates [(Int, ((Column, Rotation), Candidates))] -step :: (Applicative m, MonadState StepState m, MonadWriter [String] m) - ⇒ [Block] → Grid → m (Column, Rotation) -step blocks myGrid = fst <$> step' 0 blocks myGrid +step ∷ Functor f ⇒ (∀a. [a] → f [a]) → [Block] → Grid → f (Column, Rotation) +step limiter blocks myGrid = select <$> limiter stream + 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) - ⇒ Int → [Block] → Grid → m ((Column, Rotation), Int) -step' depth (block:blocks) myGrid = do - let try c rot = do - result ← simulate myGrid block c rot - pure (score result, (result, (c, rot))) - let candidates = catMaybes $ try <$> [3,2,4,1,5,0] <*> [1,3,0,2] - let best = sortBy (flip compare `on` fst) candidates +candidates ∷ [Block] → Grid → Candidates +candidates [] _ = Candidates [] +candidates (block:blocks) grid = Candidates best + where + try c rot = do + (grid', points) ← simulate grid block c rot + let score1 = score grid' points + 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 } - best' ← if length (take limit best) < 1 || null blocks then pure best else do - 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 +score ∷ Grid → Int → Int +score grid points = 10*points + matches -- + 50*nonSkulls where free = length $ filter (== Empty) $ A.elems grid nonSkulls = length $ filter (/= Skull) $ A.elems grid 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] - 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 - 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 → Block → Column → Rotation → Maybe (Grid, Int) simulate grid (colorA, colorB) col rot | not (A.inRange (A.bounds grid) crA) || not (A.inRange (A.bounds grid) crB) || @@ -134,7 +136,17 @@ simulate grid (colorA, colorB) col rot 3 → ((col,0), (col, 1)) 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 where 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] 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 True → pure grid False → do @@ -152,9 +164,9 @@ simDisappear grid stage = case null erased of where colorCells = filter (isColor . snd) $ A.assocs grid skullCells = filter ((== Skull) . snd) $ A.assocs grid - groups = connectedGroups adjacentMatch (S.fromList colorCells) - largeGroups = filter ((>= 4) . S.size) groups - erasedColors = concatMap S.toList largeGroups + groups = connectedGroups adjacentMatch colorCells + largeGroups = filter ((>= 4) . length) groups + erasedColors = concat largeGroups erasedSkulls = filter (\(cr,_) → any (adjacent cr . fst) erasedColors) skullCells erased = erasedColors ++ erasedSkulls 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) uniqueColors = length . nub $ map snd erasedColors 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 scale = max 1 $ min 999 $ chainPower + colorBonus + groupBonus -isColor :: Cell → Bool +isColor ∷ Cell → Bool isColor Empty = False isColor Skull = False 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)) || (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 -connectedGroups :: Ord a ⇒ (a → a → Bool) → Set a → [Set a] -connectedGroups p rem = case S.minView rem of - Nothing → [] - Just (x, rem') → - let go fringe others = case S.minView fringe of - Nothing → (S.empty, others) - Just (y, fringe') → case S.partition (p y) others of - (adj, notAdj) → first (S.insert y) $ - go (S.union fringe' adj) notAdj - (conn, notConn) = go (S.singleton x) rem' +connectedGroups ∷ (a → a → Bool) → [a] → [[a]] +connectedGroups p rem = case rem of + [] → [] + (x:rem') → + let go fringe others = case fringe of + [] → ([], others) + (y:fringe') → + let (adj, notAdj) = partition (p y) others + in first (y:) $ go (fringe' ++ adj) notAdj + (conn, notConn) = go [x] rem' 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