diff --git a/SmashTheCode/SmashTheCode.hs b/SmashTheCode/SmashTheCode.hs index 0f1e04e..4f264db 100644 --- a/SmashTheCode/SmashTheCode.hs +++ b/SmashTheCode/SmashTheCode.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase, TupleSections, UnicodeSyntax, Rank2Types #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} + +module Main (main) where 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 @@ -13,18 +13,16 @@ import Data.Maybe import Data.Monoid import Data.Array (Array, (!), (//)) 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.Foldable as F -import qualified Data.Traversable as T +import qualified Data.Array as A {-# ANN module "HLint: ignore Use if" #-} +{-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant $" #-} {-# ANN module "HLint: ignore Redundant do" #-} @@ -40,24 +38,23 @@ main ∷ IO () main = do hSetBuffering stdout NoBuffering -- DO NOT REMOVE - threadDelay =<< randomRIO (0,800000) - forever $ do - blocks ← liftIO (replicateM 8 getBlock) + blocks ← replicateM 8 getBlock - start ← liftIO getClockTime + --start ← getClockTime - myGrid ← liftIO getGrid - opGrid ← liftIO getGrid + myGrid ← 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 - end ← col `seq` rot `seq` liftIO getClockTime - let ms = round ((end `diffSeconds` start) * 1000) + --end ← col `seq` rot `seq` getClockTime + --let ms = round ((end `diffSeconds` start) * 1000) - liftIO $ hPutStrLn stderr $ show ms ++ "ms" - liftIO $ putStrLn $ unwords [show col, show rot] + --hPutStrLn stderr $ show ms ++ "ms" + putStrLn $ unwords [show col, show rot] getBlock ∷ IO Block getBlock = do @@ -80,47 +77,54 @@ step ∷ Functor f ⇒ (∀a. [a] → f [a]) → [Block] → Grid → f (Column, 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) + stream = concatMap snd . drop 1 . takeWhile (not . null . snd) + . iterate deepen . (0,) + . take 40 . sortBy (flip compare `on` fst) + $ start + deepen (depth, cs0) = + {- trace (show depth ++ " " ++ show (fst (head cs))) $ -} + (depth+1, cs') + where + cs = sortBy (flip compare `on` fst) cs0 + cs' = map (first (`div` (depth + 3))) + . take 40 . sortBy (flip compare `on` fst) + $ 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 [] _ = Candidates [] -candidates (block:blocks) grid = Candidates best +candidates [] _ = Candidates [] +candidates (block:blocks) grid0 = Candidates cs where - try c rot = do - (grid', points) ← simulate grid block c rot - let score1 = score grid' points - let adjust (score2, (mv', cs')) = + try col rot = do + (grid1, points1) ← simulate grid0 block col rot + let score1 = score grid1 points1 + let Candidates cs1 = candidates blocks grid1 + let adjust (score2, (mv2, Candidates cs2)) = 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))) + in (score1 + score2, ((col, rot), Candidates (map adjust cs2))) + pure $! score1 `seq` (score1, ((col, rot), Candidates (map adjust cs1))) 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 + cs = catMaybes $ try <$> columns <*> rotations score ∷ Grid → Int → Int -score grid points = 10*points + matches -- + 50*nonSkulls +score grid points = 100 * points + 10 * matches + emptyNeighbours 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 + matches = sum . map (^2) . filter (> 1) . map length $ colorGroups + colorCells = filter (isColor . snd) $ A.assocs grid + 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 (colorA, colorB) col rot @@ -135,7 +139,7 @@ simulate grid (colorA, colorB) col rot 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 @@ -145,7 +149,7 @@ addSkulls nskulls grid = newGrid $ 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 @@ -201,45 +205,23 @@ connectedGroups p rem = case rem of 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 ∷ 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) $ + 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) + [] → pure [] + (a:as) → pure $! a `seq` (a:as) case r of - Nothing -> pure [] - Just [] -> pure [] - Just (a:as) -> (a:) <$> loop as + Nothing → pure [] + Just [] → pure [] + Just (a:as) → (a:) <$> loop as