Skip Navigation

šŸŽ - 2023 DAY 12 SOLUTIONS -šŸŽ

Day 12: Hot Springs

Megathread guidelines

  • Keep top level comments as only solutions, if you want to say something other than a solution put it in a new post. (replies to comments can be whatever)
  • Code block support is not fully rolled out yet but likely will be in the middle of the event. Try to share solutions as both code blocks and using something such as https://topaz.github.io/paste/ , pastebin, or github (code blocks to future proof it for when 0.19 comes out and since code blocks currently function in some apps and some instances as well if they are running a 0.19 beta)

FAQ


šŸ”’ Thread is locked until there's at least 100 2 star entries on the global leaderboard

šŸ”“ Unlocked after 25 mins

14

You're viewing a single thread.

14 comments
  • Haskell

    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
    
14 comments