From 90b3ebf93ed2f68154d78865bfcd46616ece44a2 Mon Sep 17 00:00:00 2001 From: Daniel Lin Date: Mon, 16 Dec 2024 09:31:59 -0500 Subject: [PATCH] Day 16: Reindeer Maze --- README.md | 1 + hs/aoc2024.cabal | 3 +++ hs/app/Main.hs | 2 ++ hs/bench/Main.hs | 7 ++++++ hs/src/Day16.hs | 58 ++++++++++++++++++++++++++++++++++++++++++ hs/test/Day16Spec.hs | 60 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 131 insertions(+) create mode 100644 hs/src/Day16.hs create mode 100644 hs/test/Day16Spec.hs diff --git a/README.md b/README.md index 2e5b1c21..2f517484 100644 --- a/README.md +++ b/README.md @@ -20,3 +20,4 @@ Development occurs in language-specific directories: |[Day13.hs](hs/src/Day13.hs)|[Day13.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day13.kt)|[day13.py](py/aoc2024/day13.py)|| |[Day14.hs](hs/src/Day14.hs)|[Day14.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day14.kt)||| |[Day15.hs](hs/src/Day15.hs)|||| +|[Day16.hs](hs/src/Day16.hs)|||| diff --git a/hs/aoc2024.cabal b/hs/aoc2024.cabal index 969e0a40..b8b140f2 100644 --- a/hs/aoc2024.cabal +++ b/hs/aoc2024.cabal @@ -28,6 +28,7 @@ library Day13 Day14 Day15 + Day16 Day2 Day3 Day4 @@ -44,6 +45,7 @@ library array ^>=0.5.7.0, base ^>=4.20.0.0, containers ^>=0.7, + heap ^>=1.0.4, megaparsec ^>=9.7.0, parallel ^>=3.2.2.0, split ^>=0.2.5, @@ -82,6 +84,7 @@ test-suite aoc2024-test Day13Spec Day14Spec Day15Spec + Day16Spec Day1Spec Day2Spec Day3Spec diff --git a/hs/app/Main.hs b/hs/app/Main.hs index 48ba5a10..b24c0942 100644 --- a/hs/app/Main.hs +++ b/hs/app/Main.hs @@ -14,6 +14,7 @@ import Day12 qualified (part1, part2) import Day13 qualified (part1, part2) import Day14 qualified (part1, part2) import Day15 qualified (part1, part2) +import Day16 qualified (part1, part2) import Day2 qualified (part1, part2) import Day3 qualified (part1, part2) import Day4 qualified (part1, part2) @@ -60,3 +61,4 @@ main = do run 13 (either (fail . errorBundlePretty) print) [Day13.part1, Day13.part2] run 14 (either (fail . errorBundlePretty) print) [Day14.part1, Day14.part2] run 15 (either fail print) [Day15.part1, Day15.part2] + run 16 (maybe (fail "error") print) [Day16.part1, Day16.part2] diff --git a/hs/bench/Main.hs b/hs/bench/Main.hs index cee98df5..8706b0b0 100644 --- a/hs/bench/Main.hs +++ b/hs/bench/Main.hs @@ -13,6 +13,7 @@ import Day12 qualified (part1, part2) import Day13 qualified (part1, part2) import Day14 qualified (part1, part2) import Day15 qualified (part1, part2) +import Day16 qualified (part1, part2) import Day2 qualified (part1, part2) import Day3 qualified (part1, part2) import Day4 qualified (part1, part2) @@ -127,5 +128,11 @@ main = "Day 15" [ bench "part 1" $ nf Day15.part1 input, bench "part 2" $ nf Day15.part2 input + ], + env (getDayInput 16) $ \input -> + bgroup + "Day 16" + [ bench "part 1" $ nf Day16.part1 input, + bench "part 2" $ nf Day16.part2 input ] ] diff --git a/hs/src/Day16.hs b/hs/src/Day16.hs new file mode 100644 index 00000000..32a2d3c5 --- /dev/null +++ b/hs/src/Day16.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Day16 +-- Description: +module Day16 (part1, part2) where + +import Control.Arrow (second) +import Control.Exception (assert) +import Data.Heap (FstMinPolicy) +import Data.Heap qualified as Heap (insert, singleton, view) +import Data.Map qualified as Map (empty, insert, (!?)) +import Data.Set (Set) +import Data.Set qualified as Set (empty, fromList, insert, member, notMember, size) +import Data.Text (Text) +import Data.Text qualified as T (foldl) + +parse :: Text -> Maybe (Set (Int, Int), (Int, Int), (Int, Int)) +parse input = case T.foldl parse' (0, 0, Set.empty, [], []) input of + (_, _, maze, [start], [end]) -> Just (maze, start, end) + _ -> Nothing + where + parse' (y, _, maze, start, end) '\n' = (y + 1, 0, maze, start, end) + parse' (y, x, maze, start, end) '#' = (y, x + 1, Set.insert (y, x) maze, start, end) + parse' (y, x, maze, start, end) 'S' = (y, x + 1, maze, (y, x) : start, end) + parse' (y, x, maze, start, end) 'E' = (y, x + 1, maze, start, (y, x) : end) + parse' (y, x, maze, start, end) _ = (y, x + 1, maze, start, end) + +part1 :: Text -> Maybe Int +part1 input = do + (maze, start, end) <- parse input + let go visited (Heap.view -> Just ((score, pv@(p@(y, x), v@(dy, dx))), queue')) + | p == end = Just score + | pv `Set.member` visited = go visited queue' + | otherwise = + go (Set.insert pv visited) . foldl' (flip Heap.insert) queue' $ + [(score + 1, (p', v)) | let p' = (y + dy, x + dx), p' `Set.notMember` maze] + ++ [(score + 1000, (p, (-dx, dy))), (score + 1000, (p, (dx, -dy)))] + go _ _ = Nothing + go Set.empty $ Heap.singleton @FstMinPolicy (0 :: Int, (start, (0, 1))) + +part2 :: Text -> Maybe Int +part2 input = do + (maze, start, end) <- parse input + best <- part1 input + let go acc visited (Heap.view -> Just ((score, (pv@(p@(y, x), v@(dy, dx)), path)), queue)) + | p == end = assert (score == best) $ go (acc <> Set.fromList (p : path)) visited' queue + | Just score' <- visited Map.!? pv, score' < score = go acc visited queue + | otherwise = + go acc visited' . foldl' (flip Heap.insert) queue . map (second (,path')) . filter ok $ + [(score + 1, (p', v)) | let p' = (y + dy, x + dx), p' `Set.notMember` maze] + ++ [(score + 1000, (p, (-dx, dy))), (score + 1000, (p, (dx, -dy)))] + where + visited' = Map.insert pv score visited + path' = p : path + ok (score', pv') = score' <= best && maybe True (>= score) (visited Map.!? pv') + go acc _ _ = Set.size acc + pure $ go Set.empty Map.empty $ Heap.singleton @FstMinPolicy (0 :: Int, ((start, (0, 1)), [])) diff --git a/hs/test/Day16Spec.hs b/hs/test/Day16Spec.hs new file mode 100644 index 00000000..3d73bc6b --- /dev/null +++ b/hs/test/Day16Spec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Day16Spec (spec) where + +import Data.Text (Text) +import Data.Text qualified as T (unlines) +import Day16 (part1, part2) +import Test.Hspec (Spec, describe, it, shouldBe) + +example1, example2 :: Text +example1 = + T.unlines + [ -- :r!pbpaste | sed 's/.*/ , "&"/;1s/,/ /' + "###############", + "#.......#....E#", + "#.#.###.#.###.#", + "#.....#.#...#.#", + "#.###.#####.#.#", + "#.#.#.......#.#", + "#.#.#####.###.#", + "#...........#.#", + "###.#.#####.#.#", + "#...#.....#.#.#", + "#.#.#.###.#.#.#", + "#.....#...#.#.#", + "#.###.#.#.#.#.#", + "#S..#.....#...#", + "###############" + ] +example2 = + T.unlines + [ "#################", + "#...#...#...#..E#", + "#.#.#.#.#.#.#.#.#", + "#.#.#.#...#...#.#", + "#.#.#.#.###.#.#.#", + "#...#.#.#.....#.#", + "#.#.#.#.#.#####.#", + "#.#...#.#.#.....#", + "#.#.#####.#.###.#", + "#.#.#.......#...#", + "#.#.###.#####.###", + "#.#.#...#.....#.#", + "#.#.#.#####.###.#", + "#.#.#.........#.#", + "#.#.#.#########.#", + "#S#.............#", + "#################" + ] + +spec :: Spec +spec = do + describe "part 1" $ do + it "examples" $ do + part1 example1 `shouldBe` Just 7036 + part1 example2 `shouldBe` Just 11048 + describe "part 2" $ do + it "examples" $ do + part2 example1 `shouldBe` Just 45 + part2 example2 `shouldBe` Just 64