Day 12: Hot Springs

README.md

@@ -16,3 +16,4 @@ Development occurs in language-specific directories:
 |[Day9.hs](hs/src/Day9.hs)|[Day9.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day9.kt)|[day9.py](py/aoc2023/day9.py)|[day9.rs](rs/src/day9.rs)|
 |[Day10.hs](hs/src/Day10.hs)|[Day10.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day10.kt)|[day10.py](py/aoc2023/day10.py)|[day10.rs](rs/src/day10.rs)|
 |[Day11.hs](hs/src/Day11.hs)|[Day11.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day11.kt)|[day11.py](py/aoc2023/day11.py)|[day11.rs](rs/src/day11.rs)|
+|[Day12.hs](hs/src/Day12.hs)||||

hs/aoc2023.cabal

@@ -31,7 +31,8 @@ library
         Day8,
         Day9,
         Day10,
-        Day11
+        Day11,
+        Day12
 
     -- Modules included in this library but not exported.
     other-modules:

hs/app/Main.hs

@@ -12,6 +12,7 @@ import qualified Day8 (part1, part2)
 import qualified Day9 (part1, part2)
 import qualified Day10 (solve)
 import qualified Day11 (solve)
+import qualified Day12 (part1, part2)
 
 import Control.Monad (ap, when)
 import Data.Foldable (find)
@@ -53,3 +54,4 @@ main = do
     run 9 (either fail print) [Day9.part1, Day9.part2]
     run 10 (maybe (fail "error") $ uncurry ((>>) `on` print)) [Day10.solve]
     run 11 print [Day11.solve 2, Day11.solve 1000000]
+    run 12 print [Day12.part1, Day12.part2]

hs/bench/Main.hs

@@ -17,6 +17,7 @@ import qualified Day8 (part1, part2)
 import qualified Day9 (part1, part2)
 import qualified Day10 (solve)
 import qualified Day11 (solve)
+import qualified Day12 (part1, part2)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath (combine)
 
@@ -69,13 +70,17 @@ main = defaultMain
       [ bench "part 1" $ nf Day9.part1 input
       , bench "part 2" $ nf Day9.part2 input
       ]
-  , envWithCleanup ((,) <$> getDayInput 10 <*> setTrace "0")
-        (unsetTrace . snd) $ fst >>> \input -> bgroup "Day 10"
-          [ bench "part 1" $ nf (fmap fst . Day10.solve) input
-          , bench "part 2" $ nf (fmap snd . Day10.solve) input
+  , env (getDayInput 10) $ \input -> bgroup "Day 10"
+      [ bench "part 1" $ nf (fmap fst . Day10.solve) input
+      , bench "part 2" $ nf (fmap snd . Day10.solve) input
       ]
   , env (getDayInput 11) $ \input -> bgroup "Day 11"
       [ bench "part 1" $ nf (Day11.solve 2) input
       , bench "part 2" $ nf (Day11.solve 1000000) input
       ]
+  , envWithCleanup ((,) <$> getDayInput 12 <*> setTrace "0")
+        (unsetTrace . snd) $ fst >>> \input -> bgroup "Day 10"
+          [ bench "part 1" $ nf Day12.part1 input
+          , bench "part 2" $ nf Day12.part2 input
+      ]
   ]

hs/src/Day12.hs

@@ -0,0 +1,94 @@
+{-|
+Module:         Day12
+Description:    <https://adventofcode.com/2023/day/12 Day 12: Hot Springs>
+-}
+{-# LANGUAGE OverloadedStrings, TransformListComp, ViewPatterns #-}
+module Day12 (part1, part2) where
+
+import Common (readEntire)
+import Data.List (foldl', maximumBy, inits, tails, scanl')
+import Data.Ord (comparing)
+import Data.Text (Text)
+import qualified Data.Text as T (all, any, breakOn, count, drop, dropAround, dropEnd, dropWhile, dropWhileEnd, head, index, intercalate, length, lines, null, split, splitOn, tail, take, unlines, unpack)
+import qualified Data.Text.Read as T (decimal)
+import Debug.Trace (trace)
+
+example :: Text
+example = T.unlines
+  [ "???.### 1,1,3"
+  , ".??..??...?##. 1,1,3"
+  , "?#?#?#?#?#?#?#? 1,3,1,6"
+  , "????.#...#... 4,1,1"
+  , "????.######..#####. 1,6,5"
+  , "?###???????? 3,2,1"
+  ]
+
+choose :: Int -> Int -> Int
+n `choose` r = foldl' f 1 $ zip [1..r] [n, n - 1..] where
+    f k (a, b) | (q, 0) <- (k * b) `divMod` a = q
+infix 1 `choose`
+
+solutions :: Text -> [Int] -> Int
+solutions (T.dropAround (== '.') -> s) xs
+  | T.count "#" s > m ||
+    m > T.length s - T.count "." s ||
+    m + length xs - 1 > T.length s
+  = 0
+  | T.null s || null xs = 1
+  | (leftS, rightS) <- T.breakOn "." s, not $ T.null rightS = sum
+      [ left * solutions rightS rightXs
+      | (leftXs, rightXs, acc) <- zip3 (inits xs) (tails xs) $ scanl' ((+) . succ) (-1) xs
+      , then takeWhile by acc <= T.length leftS
+      , let left = solutions leftS leftXs
+      , left /= 0
+      ]
+  | T.all (/= '#') s = T.length s - m + 1 `choose` length xs
+  | T.length maxRun > maximum xs = 0
+  | not $ T.null maxRun, (leftS, rightS) <- T.breakOn maxRun s = sum
+      [ left * solutions (T.drop (x' - dx + 1) rightS) rightXs
+      | (leftXs, x' : rightXs, acc) <- zip3 (inits xs) (tails xs) $ scanl' ((+) . succ) 0 xs
+      , dx <- [max 0 $ x' - T.length rightS..x' - T.length maxRun]
+      , then takeWhile by acc + dx <= T.length leftS
+      , dx + 1 > T.length leftS || leftS `T.index` (T.length leftS - dx - 1) /= '#'
+      , x' - dx >= T.length rightS || rightS `T.index` (x' - dx) /= '#'
+      , let left = solutions (T.dropEnd (dx + 1) leftS) leftXs
+      , left /= 0
+      ]
+  | otherwise =
+        (if x < T.length s && s `T.index` x == '#' then 0 else solutions (T.drop (x + 1) s) xs') +
+        (if T.head s == '#' then 0 else solutions (T.tail s) xs)
+  where
+    m = sum xs
+    x:xs' = xs
+    maxRun = maximumBy (comparing T.length) $ T.split (/= '#') s
+
+solutions' = solutions'' . T.dropWhile (== '.') where
+    solutions'' s xs
+      | T.count "#" s > m || T.length s' < n = 0
+      | T.all (== '?') s'
+      = T.length s' - m + 1 `choose` length xs
+      where
+        s' = T.dropWhileEnd (== '.') s
+        m = sum xs
+        n = m + length xs - 1
+    solutions'' _ [] = 1
+    solutions'' s xs@(x:xs') =
+        (if T.any (== '.') (T.take x s) || s `T.index` x == '#' then 0 else solutions' (T.drop (x + 1) s) xs') +
+        (if T.head s == '#' then 0 else solutions' (T.tail s) xs)
+
+part1 :: Text -> Int
+part1 = sum . map part1' . T.lines where
+    part1' line
+      | [lhs, rhs] <- T.splitOn " " line
+      , Right nums <- mapM (readEntire T.decimal) $ T.splitOn "," rhs
+      = solutions lhs nums
+      | otherwise = 0
+
+part2 :: Text -> Int
+part2 = sum . map part2' . T.lines where
+    part2' line
+      | [lhs, rhs] <- T.splitOn " " line
+      , Right nums <- mapM (readEntire T.decimal) $ T.splitOn "," rhs
+      = ((++ ('\t' : T.unpack line)) . show >>= trace) .
+        solutions (T.intercalate "?" $ replicate 5 lhs) . concat $ replicate 5 nums
+      | otherwise = 0

hs/test/Day12Spec.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day12Spec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unlines)
+import Day12 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example = T.unlines
+  [ "???.### 1,1,3"
+  , ".??..??...?##. 1,1,3"
+  , "?#?#?#?#?#?#?#? 1,3,1,6"
+  , "????.#...#... 4,1,1"
+  , "????.######..#####. 1,6,5"
+  , "?###???????? 3,2,1"
+  ]
+
+spec :: Spec
+spec = do
+    describe "part 1" $ do
+        it "examples" $ do
+            part1 example `shouldBe` 21
+    describe "part 2" $ do
+        it "examples" $ do
+            part2 example `shouldBe` 525152