Merge pull request #124 from ephemient/hs/day19

Day 19: Linen Layout

README.md

@@ -23,3 +23,4 @@ Development occurs in language-specific directories:
 |[Day16.hs](hs/src/Day16.hs)|[Day16.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day16.kt)|[day16.py](py/aoc2024/day16.py)|[day16.rs](rs/src/day16.rs)|
 |[Day17.hs](hs/src/Day17.hs)|[Day17.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day17.kt)|[day17.py](py/aoc2024/day17.py)|[day17.rs](rs/src/day17.rs)|
 |[Day18.hs](hs/src/Day18.hs)|[Day18.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day18.kt)|[day18.py](py/aoc2024/day18.py)|[day18.rs](rs/src/day18.rs)|
+|[Day19.hs](hs/src/Day19.hs)||||

hs/aoc2024.cabal

@@ -31,6 +31,7 @@ library
     Day16
     Day17
     Day18
+    Day19
     Day2
     Day3
     Day4
@@ -89,6 +90,7 @@ test-suite aoc2024-test
     Day16Spec
     Day17Spec
     Day18Spec
+    Day19Spec
     Day1Spec
     Day2Spec
     Day3Spec

hs/app/Main.hs

@@ -3,6 +3,7 @@
 module Main (main) where
 
 import Control.Monad (ap, when)
+import Data.Bifunctor (bimap)
 import Data.Foldable (find)
 import Data.List (intercalate)
 import Data.Maybe (fromMaybe)
@@ -18,6 +19,7 @@ import Day15 qualified (part1, part2)
 import Day16 qualified (part1, part2)
 import Day17 qualified (part1, part2)
 import Day18 qualified (part1, part2)
+import Day19 qualified (solve)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -67,3 +69,4 @@ main = do
   run 16 (maybe (fail "error") print) [Day16.part1, Day16.part2]
   run 17 (either (fail . errorBundlePretty) $ putStrLn . intercalate "," . map show) [Day17.part1, fmap (: []) . Day17.part2]
   run 18 (either fail putStrLn) [fmap show . Day18.part1, fmap (uncurry $ (. (',' :) . show) . shows) . Day18.part2]
+  run 19 (uncurry (>>) . bimap print print) [Day19.solve]

hs/bench/Main.hs

@@ -16,6 +16,7 @@ import Day15 qualified (part1, part2)
 import Day16 qualified (part1, part2)
 import Day17 qualified (part1, part2)
 import Day18 qualified (part1, part2)
+import Day19 qualified (solve)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -148,5 +149,10 @@ main =
           "Day 18"
           [ bench "part 1" $ nf Day18.part1 input,
             bench "part 2" $ nf Day18.part2 input
+          ],
+      env (getDayInput 19) $ \input ->
+        bgroup
+          "Day 19"
+          [ bench "solve" $ nf Day19.solve input
           ]
     ]

hs/src/Day19.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:         Day19
+-- Description:    <https://adventofcode.com/2024/day/19 Day 19: Linen Layout>
+module Day19 (solve) where
+
+import Control.Arrow ((***))
+import Control.Monad.ST (runST)
+import Data.Foldable (foldMap')
+import Data.List (sort)
+import Data.Monoid (Sum (Sum, getSum))
+import Data.Text (Text)
+import Data.Text qualified as T (isPrefixOf, length, lines, null, splitOn, tails)
+import Data.Vector.Unboxed.Mutable qualified as MV (new, read, write)
+
+count :: [Text] -> Text -> (Sum Int, Sum Int)
+count keys target = runST $ do
+  acc <- MV.new $ T.length target + 1
+  MV.write acc 0 1
+  mapM_ (\(i, j) -> (+) <$> MV.read acc i <*> MV.read acc j >>= MV.write acc i) . sort $
+    [ (offset + T.length key, offset)
+    | key <- keys,
+      (offset, target') <- zip [0 ..] $ T.tails target,
+      key `T.isPrefixOf` target'
+    ]
+  n <- MV.read acc $ T.length target
+  pure (Sum $ if n == 0 then 0 else 1, Sum n)
+
+solve :: Text -> (Int, Int)
+solve input
+  | keys : rest <- T.lines input =
+      (getSum *** getSum) $ foldMap' (count $ T.splitOn ", " keys) $ filter (not . T.null) rest
+  | otherwise = (0, 0)

hs/test/Day19Spec.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day19Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day19 (solve)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example =
+  T.unlines
+    [ "r, wr, b, g, bwu, rb, gb, br",
+      "",
+      "brwrr",
+      "bggr",
+      "gbbr",
+      "rrbgbr",
+      "ubwu",
+      "bwurrg",
+      "brgr",
+      "bbrgwb"
+    ]
+
+spec :: Spec
+spec = do
+  describe "solve" $ do
+    it "examples" $ do
+      solve example `shouldBe` (6, 16)