Merge pull request #40 from ephemient/hs/day5

README.md

@@ -9,3 +9,4 @@ Development occurs in language-specific directories:
 |[Day2.hs](hs/src/Day2.hs)|[Day2.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day2.kt)|[day2.py](py/aoc2024/day2.py)|[day2.rs](rs/src/day2.rs)|
 |[Day3.hs](hs/src/Day3.hs)|[Day3.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day3.kt)|[day3.py](py/aoc2024/day3.py)|[day3.rs](rs/src/day3.rs)|
 |[Day4.hs](hs/src/Day4.hs)|[Day4.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day4.kt)|[day4.py](py/aoc2024/day4.py)|[day4.rs](rs/src/day4.rs)|
+|[Day5.hs](hs/src/Day5.hs)||||

hs/aoc2024.cabal

@@ -25,13 +25,15 @@ library
     Day2
     Day3
     Day4
+    Day5
 
   other-modules:
     Common
 
   build-depends:
     base ^>=4.20.0.0,
     containers ^>=0.7,
+    megaparsec ^>=9.7.0,
     text ^>=2.1.2,
 
   ghc-options: -Wall
@@ -64,6 +66,7 @@ test-suite aoc2024-test
     Day2Spec
     Day3Spec
     Day4Spec
+    Day5Spec
 
   build-depends:
     aoc2024,

hs/app/Main.hs

@@ -11,8 +11,10 @@ import Day1 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
+import Day5 qualified (part1, part2)
 import System.Environment (getArgs, lookupEnv)
 import System.FilePath (combine)
+import Text.Megaparsec (errorBundlePretty)
 
 getDayInput :: Int -> IO Text
 getDayInput i = do
@@ -37,3 +39,4 @@ main = do
   run 2 (either fail print) [Day2.part1, Day2.part2]
   run 3 print [Day3.part1, Day3.part2]
   run 4 print [Day4.part1, Day4.part2]
+  run 5 (either (fail . errorBundlePretty) print) [Day5.part1, Day5.part2]

hs/bench/Main.hs

@@ -10,6 +10,7 @@ import Day1 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
+import Day5 qualified (part1, part2)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath (combine)
 
@@ -50,5 +51,11 @@ main =
           "Day 4"
           [ bench "part 1" $ nf Day4.part1 input,
             bench "part 2" $ nf Day4.part2 input
+          ],
+      env (getDayInput 5) $ \input ->
+        bgroup
+          "Day 5"
+          [ bench "part 1" $ nf Day5.part1 input,
+            bench "part 2" $ nf Day5.part2 input
           ]
     ]

hs/src/Day5.hs

@@ -0,0 +1,58 @@
+-- |
+-- Module:         Day5
+-- Description:    <https://adventofcode.com/2024/day/5 Day 5: Print Queue>
+module Day5 (part1, part2) where
+
+import Control.Arrow (second)
+import Data.IntMap qualified as IntMap (findWithDefault, fromList, (!?))
+import Data.IntMap.Strict qualified as IntMap (fromListWith)
+import Data.IntSet qualified as IntSet (empty, member, singleton, toList, union)
+import Data.List (sortBy)
+import Data.Maybe (fromJust, fromMaybe)
+import Data.String (IsString)
+import Data.Text (Text)
+import Data.Void (Void)
+import Text.Megaparsec (MonadParsec, ParseErrorBundle, Stream (Token, Tokens), parse, sepEndBy, sepEndBy1, skipMany)
+import Text.Megaparsec.Char (char, newline)
+import Text.Megaparsec.Char.Lexer (decimal)
+
+parser :: (MonadParsec e s m, IsString (Tokens s), Token s ~ Char, Num a) => m ([(a, a)], [[a]])
+parser =
+  (,)
+    <$> ((,) <$> decimal <* char '|' <*> decimal) `sepEndBy` newline
+    <* skipMany newline
+    <*> (decimal `sepEndBy1` char ',') `sepEndBy` newline
+
+part1 :: Text -> Either (ParseErrorBundle Text Void) Int
+part1 input = do
+  (deps, updates) <- parse parser "" input
+  pure $
+    sum
+      [ update !! (length update `div` 2)
+      | update <- updates,
+        let order = IntMap.fromList @Int $ zip update [0 ..],
+        and
+          [ fromMaybe True $ (<) <$> order IntMap.!? a <*> order IntMap.!? b
+          | (a, b) <- deps
+          ]
+      ]
+
+part2 :: Text -> Either (ParseErrorBundle Text Void) Int
+part2 input = do
+  (deps, updates) <- parse parser "" input
+  let deps' = IntMap.fromListWith IntSet.union $ second IntSet.singleton <$> deps
+      tryCompare a b
+        | a == b = Just EQ
+        | b `IntSet.member` (IntMap.findWithDefault IntSet.empty a deps') = Just LT
+        | a `IntSet.member` (IntMap.findWithDefault IntSet.empty b deps') = Just GT
+        | otherwise =
+            mconcat (tryCompare a <$> maybe [] IntSet.toList (deps' IntMap.!? b))
+              <> fmap (compare EQ) (mconcat (tryCompare b <$> maybe [] IntSet.toList (deps' IntMap.!? a)))
+      compare' a b = fromJust $ tryCompare a b
+  pure $
+    sum
+      [ update' !! (length update `div` 2)
+      | update <- updates,
+        let update' = sortBy compare' update,
+        update /= update'
+      ]

hs/test/Day5Spec.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day5Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day5 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example =
+  T.unlines
+    [ "47|53",
+      "97|13",
+      "97|61",
+      "97|47",
+      "75|29",
+      "61|13",
+      "75|53",
+      "29|13",
+      "97|29",
+      "53|29",
+      "61|53",
+      "97|53",
+      "61|29",
+      "47|13",
+      "75|47",
+      "97|75",
+      "47|61",
+      "75|61",
+      "47|29",
+      "75|13",
+      "53|13",
+      "",
+      "75,47,61,53,29",
+      "97,61,53,29,13",
+      "75,29,13",
+      "75,97,47,61,53",
+      "61,13,29",
+      "97,13,75,29,47"
+    ]
+
+spec :: Spec
+spec = do
+  describe "part 1" $ do
+    it "examples" $ do
+      part1 example `shouldBe` Right 143
+  describe "part 2" $ do
+    it "examples" $ do
+      part2 example `shouldBe` Right 123