Phew! I struggled with this one. A lot of the code here is from my original approach, which cuts down the search space to plausible positions for each group. Unfortunately, that was still way too slow…
It took an embarrassingly long time to try memoizing the search (which made precomputing valid points far less important). Anyway, here it is!
Solution{-# LANGUAGE LambdaCase #-} import Control.Monad import Control.Monad.State import Data.List import Data.List.Split import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe readInput :: String -> ([Maybe Bool], [Int]) readInput s = let [a, b] = words s in ( map (case ‘#’ -> Just True; ‘.’ -> Just False; ‘?’ -> Nothing) a, map read $ splitOn “,” b ) arrangements :: ([Maybe Bool], [Int]) -> Int arrangements (pat, gs) = evalState (searchMemo 0 groups) Map.empty where len = length pat groups = zipWith startPoints gs $ zip minStarts maxStarts where minStarts = scanl (a g -> a + g + 1) 0 $ init gs maxStarts = map (len -) $ scanr1 (g a -> a + g + 1) gs startPoints g (a, b) = let ps = do (i, pat’) <- zip [a … b] $ tails $ drop a pat guard $ all ((p, x) -> maybe True (== x) p) $ zip pat’ $ replicate g True ++ [False] return i in (g, ps) clearableFrom i = fmap snd $ listToMaybe $ takeWhile ((<= i) . fst) $ dropWhile ((< i) . snd) clearableRegions where clearableRegions = let go i [] = [] go i pat = let (a, a’) = span (/= Just True) pat (b, c) = span (== Just True) a’ in (i, i + length a - 1) : go (i + length a + length b) c in go 0 pat searchMemo :: Int -> [(Int, [Int])] -> State (Map (Int, Int) Int) Int searchMemo i gs = do let k = (i, length gs) cached <- gets (Map.!? k) case cached of Just x -> return x Nothing -> do x <- search i gs modify (Map.insert k x) return x search i gs | i >= len = return $ if null gs then 1 else 0 search i [] = return $ case clearableFrom i of Just b | b == len - 1 -> 1 _ -> 0 search i ((g, ps) : gs) = do let maxP = maybe i (1 +) $ clearableFrom i ps’ = takeWhile (<= maxP) $ dropWhile (< i) ps sum <$> mapM (p -> let i’ = p + g + 1 in searchMemo i’ gs) ps’ expand (pat, gs) = (intercalate [Nothing] $ replicate 5 pat, concat $ replicate 5 gs) main = do input <- map readInput . lines <$> readFile “input12” print $ sum $ map arrangements input print $ sum $ map (arrangements . expand) input