Smash the Code contest -- Final version
This commit is contained in:
parent
5546d1bc17
commit
4404a00a78
|
|
@ -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
|
matches = sum . map (^2) . filter (> 1) . map length $ colorGroups
|
||||||
nonSkulls = length $ filter (/= Skull) $ A.elems grid
|
colorCells = filter (isColor . snd) $ A.assocs grid
|
||||||
levels = length $ takeWhile emptyLevel [0..11]
|
colorGroups = connectedGroups adjacentMatch colorCells
|
||||||
matches = sum . map (^2) . filter (> 1) . map length $ colorGroups
|
neighbours (c,r) = map (id &&& (grid!))
|
||||||
emptyLevel r = all (\c → grid!(c,r) == Empty) [0..5]
|
$ filter (A.inRange (A.bounds grid))
|
||||||
colorCells = filter (isColor . snd) $ A.assocs grid
|
$ [(c-1,r), (c+1,r), (c,r-1), (c,r+1)]
|
||||||
colorGroups = connectedGroups adjacentMatch colorCells
|
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
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue