246 lines
8.9 KiB
Haskell
246 lines
8.9 KiB
Haskell
{-# 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
|
|
import Data.Function
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Data.Array (Array, (!), (//))
|
|
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
|
|
|
|
{-# ANN module "HLint: ignore Use if" #-}
|
|
{-# ANN module "HLint: ignore Redundant $" #-}
|
|
{-# ANN module "HLint: ignore Redundant do" #-}
|
|
|
|
type Color = Int
|
|
type Rotation = Int
|
|
type Block = (Color, Color)
|
|
type Column = Int
|
|
type Row = Int
|
|
data Cell = Empty | Skull | Color Color deriving (Eq, Ord, Show)
|
|
type Grid = Array (Column, Row) Cell
|
|
|
|
main ∷ IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
|
|
threadDelay =<< randomRIO (0,800000)
|
|
|
|
forever $ do
|
|
blocks ← liftIO (replicateM 8 getBlock)
|
|
|
|
start ← liftIO getClockTime
|
|
|
|
myGrid ← liftIO getGrid
|
|
opGrid ← liftIO getGrid
|
|
|
|
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 $ hPutStrLn stderr $ show ms ++ "ms"
|
|
liftIO $ putStrLn $ unwords [show col, show rot]
|
|
|
|
getBlock ∷ IO Block
|
|
getBlock = do
|
|
[colorA, colorB] ← map read . words <$> getLine
|
|
pure (colorA, colorB)
|
|
|
|
getGrid ∷ IO Grid
|
|
getGrid = fmap (A.array ((0,0),(5,11)) . concat) $
|
|
forM [0..11] $ \row → do
|
|
line ← getLine
|
|
pure [ ((col, row), cell ch) | (col, ch) ← zip [0..] line ]
|
|
where
|
|
cell '.' = Empty
|
|
cell '0' = Skull
|
|
cell ch = Color (read [ch])
|
|
|
|
newtype Candidates = Candidates [(Int, ((Column, Rotation), Candidates))]
|
|
|
|
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)
|
|
|
|
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
|
|
|
|
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]
|
|
colorCells = filter (isColor . snd) $ A.assocs grid
|
|
colorGroups = connectedGroups adjacentMatch colorCells
|
|
|
|
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) ||
|
|
grid!crA /= Empty || grid!crB /= Empty = Nothing
|
|
| otherwise = Just . second getSum . runWriter $ simFall startGrid 1
|
|
where
|
|
(crA, crB) = case rot of
|
|
0 → ((col,0), (col+1,0))
|
|
1 → ((col,1), (col, 0))
|
|
2 → ((col,0), (col-1,0))
|
|
3 → ((col,0), (col, 1))
|
|
startGrid = grid // [ (crB, Color colorB), (crA, Color colorA) ]
|
|
|
|
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]
|
|
$ (++ repeat Empty)
|
|
$ filter (/= Empty)
|
|
$ 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 grid stage = case null erased of
|
|
True → pure grid
|
|
False → do
|
|
tell . Sum $ 10 * blocksCleared * scale
|
|
simFall erasedGrid (stage + 1)
|
|
where
|
|
colorCells = filter (isColor . snd) $ A.assocs grid
|
|
skullCells = filter ((== Skull) . snd) $ A.assocs grid
|
|
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
|
|
blocksCleared = length erasedColors
|
|
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 . length) largeGroups)
|
|
perGroupBonus n = if n >= 11 then 8 else n - 4
|
|
scale = max 1 $ min 999 $ chainPower + colorBonus + groupBonus
|
|
|
|
isColor ∷ Cell → Bool
|
|
isColor Empty = False
|
|
isColor Skull = False
|
|
isColor (Color _) = True
|
|
|
|
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 (cr1,x1) (cr2,x2) = x1 == x2 && adjacent cr1 cr2
|
|
|
|
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
|