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

Smash the Code contest -- Final version

This commit is contained in:
Jesse D. McDonald 2016-05-08 14:26:55 -05:00
parent 5546d1bc17
commit 4404a00a78
1 changed files with 68 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
SmashTheCode/SmashTheCode.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE LambdaCase, TupleSections, UnicodeSyntax, Rank2Types #-} {-# LANGUAGE LambdaCase, TupleSections, UnicodeSyntax, Rank2Types #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
module Main (main) where
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.Writer import Control.Monad.Writer
import Data.Function import Data.Function
import Data.List import Data.List
@ -13,18 +13,16 @@ import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Array (Array, (!), (//)) import Data.Array (Array, (!), (//))
import System.IO import System.IO
import System.Random --import System.Time
import System.Time
import System.Timeout import System.Timeout
import System.CPUTime import System.CPUTime
import Debug.Trace import Debug.Trace
import qualified Data.Array as A import qualified Data.Array as A
import qualified Data.Foldable as F
import qualified Data.Traversable as T
{-# ANN module "HLint: ignore Use if" #-} {-# ANN module "HLint: ignore Use if" #-}
{-# ANN module "HLint: ignore Eta reduce" #-}
{-# ANN module "HLint: ignore Redundant $" #-} {-# ANN module "HLint: ignore Redundant $" #-}
{-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Redundant do" #-}
@ -40,24 +38,23 @@ main ∷ IO ()
main = do main = do
hSetBuffering stdout NoBuffering -- DO NOT REMOVE hSetBuffering stdout NoBuffering -- DO NOT REMOVE
threadDelay =<< randomRIO (0,800000)
forever $ do forever $ do
blocks ← liftIO (replicateM 8 getBlock) blocks ← replicateM 8 getBlock
start ← liftIO getClockTime --start ← getClockTime
myGrid ← liftIO getGrid myGrid ← getGrid
opGrid ← liftIO getGrid opGrid ← getGrid
let limiter = evaluateListWithTimeout 88000 --let traceLength xs = traceShow (length xs) xs
let limiter xs = {-traceLength <$>-} evaluateListWithTimeout 88000 xs
(col, rot) ← step limiter blocks myGrid (col, rot) ← step limiter blocks myGrid
end ← col `seq` rot `seq` liftIO getClockTime --end ← col `seq` rot `seq` getClockTime
let ms = round ((end `diffSeconds` start) * 1000) --let ms = round ((end `diffSeconds` start) * 1000)
liftIO $ hPutStrLn stderr $ show ms ++ "ms" --hPutStrLn stderr $ show ms ++ "ms"
liftIO $ putStrLn $ unwords [show col, show rot] putStrLn $ unwords [show col, show rot]
getBlock ∷ IO Block getBlock ∷ IO Block
getBlock = do getBlock = do
@ -80,47 +77,54 @@ step ∷ Functor f ⇒ (∀a. [a] → f [a]) → [Block] → Grid → f (Column,
step limiter blocks myGrid = select <$> limiter stream step limiter blocks myGrid = select <$> limiter stream
where where
Candidates start = candidates blocks myGrid Candidates start = candidates blocks myGrid
stream = deepen (take 11 start) stream = concatMap snd . drop 1 . takeWhile (not . null . snd)
deepen cs = (cs ++) $ do . iterate deepen . (0,)
k ← [0..] . take 40 . sortBy (flip compare `on` fst)
n ← [0..8] $ start
mapMaybe (follow n <=< other k) cs deepen (depth, cs0) =
dummy = (-1000000, ((0, 0), Candidates [])) {- trace (show depth ++ " " ++ show (fst (head cs))) $ -}
follow 0 c = Just c (depth+1, cs')
follow _ (_, (_, Candidates [])) = Nothing where
follow n (_, (_, Candidates (c':_))) = follow (n-1) c' cs = sortBy (flip compare `on` fst) cs0
other n c@(_, (_, Candidates cs)) = listToMaybe (drop n cs) cs' = map (first (`div` (depth + 3)))
select cs = trace (show $ length cs) . take 40 . sortBy (flip compare `on` fst)
$ fst $ snd $ maximumBy (compare `on` fst) (dummy:cs) $ concatMap (\k → mapMaybe (candidate k) cs) [0..6]
candidate n c@(_, (_, Candidates cs)) = listToMaybe (drop n cs)
select [] = (0, 0)
select cs = fst $ snd $ maximumBy (compare `on` fst) cs
candidates ∷ [Block] → Grid → Candidates candidates ∷ [Block] → Grid → Candidates
candidates [] _ = Candidates [] candidates [] _ = Candidates []
candidates (block:blocks) grid = Candidates best candidates (block:blocks) grid0 = Candidates cs
where where
try c rot = do try col rot = do
(grid', points) ← simulate grid block c rot (grid1, points1) ← simulate grid0 block col rot
let score1 = score grid' points let score1 = score grid1 points1
let adjust (score2, (mv', cs')) = let Candidates cs1 = candidates blocks grid1
let adjust (score2, (mv2, Candidates cs2)) =
let scoreAvg = (2 * score1 + 3 * score2) `div` 5 let scoreAvg = (2 * score1 + 3 * score2) `div` 5
in (scoreAvg, ((c, rot), cs')) in (score1 + score2, ((col, rot), Candidates (map adjust cs2)))
let Candidates cs = candidates blocks grid' pure $! score1 `seq` (score1, ((col, rot), Candidates (map adjust cs1)))
pure $! score1 `seq` (score1, ((c, rot), Candidates (map adjust cs)))
hint = uncurry (+) block `div` 2 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] 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] rotations = [1,0,3,2]
best = sortBy (flip compare `on` fst) . catMaybes cs = catMaybes $ try <$> columns <*> rotations
$ try <$> columns <*> rotations
score ∷ Grid → Int → Int score ∷ Grid → Int → Int
score grid points = 10*points + matches -- + 50*nonSkulls score grid points = 100 * points + 10 * matches + emptyNeighbours
where 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 matches = sum . map (^2) . filter (> 1) . map length $ colorGroups
emptyLevel r = all (\c → grid!(c,r) == Empty) [0..5]
colorCells = filter (isColor . snd) $ A.assocs grid colorCells = filter (isColor . snd) $ A.assocs grid
colorGroups = connectedGroups adjacentMatch colorCells colorGroups = connectedGroups adjacentMatch colorCells
neighbours (c,r) = map (id &&& (grid!))
$ filter (A.inRange (A.bounds grid))
$ [(c-1,r), (c+1,r), (c,r-1), (c,r+1)]
supported (c,r) = any (\n → r+n > 11 || grid!(c,r+n) /= Empty) [0..3]
emptyNeighbours = flip count colorCells $
any (\(p,v) → v == Empty && supported p) . neighbours . fst
count ∷ (a → Bool) → [a] → Int
count p xs = length (filter p xs)
simulate ∷ Grid → Block → Column → Rotation → Maybe (Grid, Int) simulate ∷ Grid → Block → Column → Rotation → Maybe (Grid, Int)
simulate grid (colorA, colorB) col rot simulate grid (colorA, colorB) col rot
@ -135,7 +139,7 @@ simulate grid (colorA, colorB) col rot
2 → ((col,0), (col-1,0)) 2 → ((col,0), (col-1,0))
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) ]
{-
addSkulls ∷ Int → Grid → Grid addSkulls ∷ Int → Grid → Grid
addSkulls nskulls grid = newGrid addSkulls nskulls grid = newGrid
where where
@ -145,7 +149,7 @@ addSkulls nskulls grid = newGrid
$ takeWhile (/= Empty) $ takeWhile (/= Empty)
$ 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]
-}
simFall ∷ (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid simFall ∷ (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid
simFall grid = simDisappear newGrid simFall grid = simDisappear newGrid
where where
@ -201,45 +205,23 @@ connectedGroups p rem = case rem of
in first (y:) $ go (fringe' ++ adj) notAdj in first (y:) $ go (fringe' ++ adj) notAdj
(conn, notConn) = go [x] rem' (conn, notConn) = go [x] rem'
in conn : connectedGroups p notConn in conn : connectedGroups p notConn
{-
diffSeconds ∷ ClockTime → ClockTime → Double diffSeconds ∷ ClockTime → ClockTime → Double
diffSeconds (TOD s' p') (TOD s p) = diffSeconds (TOD s' p') (TOD s p) =
fromIntegral ((s' - s) * 1000000000000 + (p' - p)) / 1e12 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 -- Compute elements of the list to WHNF for `t` microseconds. After
-- `t` microseconds, abandon the calculation and terminate the list. -- `t` microseconds, abandon the calculation and terminate the list.
evaluateListWithTimeout :: Integer -> [a] -> IO [a] evaluateListWithTimeout ∷ Integer → [a] → IO [a]
evaluateListWithTimeout t xs = do evaluateListWithTimeout t xs = do
end <- (+) <$> getCPUTime <*> pure (1000000 * t) end ← (+) <$> getCPUTime <*> pure (1000000 * t)
flip fix xs $ \loop xs -> do flip fix xs $ \loop xs → do
now <- getCPUTime now ← getCPUTime
r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ r ← timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
case xs of case xs of
[] -> pure [] [] → pure []
(a:as) -> pure $! a `seq` (a:as) (a:as) → pure $! a `seq` (a:as)
case r of case r of
Nothing -> pure [] Nothing → pure []
Just [] -> pure [] Just [] → pure []
Just (a:as) -> (a:) <$> loop as Just (a:as) → (a:) <$> loop as