Day 19: Parallelize and direct array access

Author: ephemient

hs/app/Main.hs

@@ -76,7 +76,7 @@ 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]
+  run 19 (maybe (fail "error") $ uncurry (>>) . bimap print print) [Day19.solve]
   run 20 print [Day20.solve 2 100, Day20.solve 20 100]
   run 21 print [Day21.solve 2, Day21.solve 25]
   run 22 (either fail print) [Day22.part1, Day22.part2]

hs/src/Day19.hs

@@ -1,26 +1,34 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- Module:         Day19
 -- Description:    <https://adventofcode.com/2024/day/19 Day 19: Linen Layout>
 module Day19 (solve) where
 
-import Data.Bifunctor (bimap)
+import Control.Parallel.Strategies
 import Data.Foldable (foldMap')
-import Data.Monoid (Sum (Sum, getSum))
+import Data.Monoid (Sum (Sum))
 import Data.Text (Text)
-import Data.Text qualified as T (isSuffixOf, length, lines, null, splitOn, take)
+import Data.Text qualified as T (lines, null, splitOn)
+import Data.Text.Array qualified as A (equal)
+import Data.Text.Internal (Text (Text))
+import Data.Text.Unsafe qualified as T (lengthWord8)
 import Data.Vector qualified as V (generate, (!))
 
 count :: [Text] -> Text -> Int
-count keys target = getCount $ T.length target
+count keys target = getCount $ T.lengthWord8 target
   where
-    counts = V.generate (T.length target) getCount
+    counts = V.generate (T.lengthWord8 target) getCount
     getCount 0 = 1
-    getCount i = sum [counts V.! (i - T.length key) | key <- keys, key `T.isSuffixOf` T.take i target]
+    getCount i = sum [counts V.! (i - T.lengthWord8 key) | key <- keys, key `isSuffixOfAt` i $ target]
 
-solve :: Text -> (Int, Int)
-solve input
-  | keys : rest <- T.lines input =
-      bimap getSum getSum . foldMap' ((Sum 1,) . Sum) . filter (> 0) $ count (T.splitOn ", " keys) <$> filter (not . T.null) rest
-  | otherwise = (0, 0)
+isSuffixOfAt :: Text -> Int -> Text -> Bool
+isSuffixOfAt (Text a aoff alen) n (Text b boff blen) =
+  alen <= n && n <= blen && A.equal a aoff b (boff + n - alen) alen
+
+solve :: Text -> Maybe (Int, Int)
+solve (T.lines -> (T.splitOn ", " -> keys) : rest) | not $ any T.null keys = Just (part1, part2)
+  where
+    (Sum part1, Sum part2) = foldMap' ((Sum 1,) . Sum) . filter (> 0) . parMap rseq (count keys) $ filter (not . T.null) rest
+solve _ = Nothing

hs/test/Day19Spec.hs

@@ -26,4 +26,4 @@ spec :: Spec
 spec = do
   describe "solve" $ do
     it "examples" $ do
-      solve example `shouldBe` (6, 16)
+      solve example `shouldBe` Just (6, 16)