Smash the Code contest -- Gold league, rank 5/11

SmashTheCode/SmashTheCode.hs

@@ -12,7 +12,7 @@ import Data.Monoid
 import Data.Array (Array, (!), (//))
 import Data.Set (Set)
 import System.IO
-import System.Timeout
+import System.Time
 
 import qualified Data.Array       as A
 import qualified Data.Foldable    as F
@@ -38,13 +38,22 @@ main = do
    flip evalStateT initState $ forever $ do
       blocks ← liftIO (replicateM 8 getBlock)
 
+      start <- liftIO getClockTime
+
       myGrid ← liftIO getGrid
       opGrid ← liftIO getGrid
 
       ((col, rot), debug) ← runWriterT (step blocks myGrid)
+      liftIO $ mapM_ (hPutStrLn stderr) debug
 
-      --liftIO $ mapM_ (hPutStrLn stderr) debug
-      liftIO $ putStrLn $ unwords $ map show [col, rot]
+      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
 
 getBlock :: IO Block
 getBlock = do
@@ -71,14 +80,13 @@ step blocks myGrid = fst <$> step' 0 blocks myGrid
 step' :: (Applicative m, MonadState StepState m, MonadWriter [String] m)
       ⇒ Int → [Block] → Grid → m ((Column, Rotation), Int)
 step' depth (block:blocks) myGrid = do
-   let try grid bl c rot = do
-         result ← simulate grid bl c rot
+   let try c rot = do
+         result ← simulate myGrid block c rot
          pure (score result, (result, (c, rot)))
-
-   let candidates = catMaybes $ try myGrid block <$> [0..5] <*> [0..3]
+   let candidates = catMaybes $ try <$> [3,2,4,1,5,0] <*> [1,3,0,2]
    let best = sortBy (flip compare `on` fst) candidates
 
-   let limit = [5,2,1,1,1,1,0] !! depth
+   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) $
@@ -96,16 +104,21 @@ step' depth (block:blocks) myGrid = do
       ((score1, (_, move1)):_) → pure (move1, score1)
 
 score :: (Grid, Int) → Int
-score (grid, points) = 1000*points + 5*nonSkulls + sum groups
+score (grid, points) = 1000*points + 5*nonSkulls + matches
    where
       free      = length $ filter (== Empty) $ A.elems grid
       nonSkulls = length $ filter (/= Skull) $ A.elems grid
       levels    = length $ takeWhile emptyLevel [0..11]
       emptyLevel r = all (\c → grid!(c,r) == Empty) [0..5]
-      colorCells = filter (isColor . snd) $ A.assocs grid
-      groups = map (\g -> (S.size g - 1)^2)
-             $ connectedGroups adjacentMatch
-             $ S.fromList colorCells
+      matches = sum (map (matchingNeighbours grid) (A.indices grid))
+
+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 (colorA, colorB) col rot