Day 24: Blizzard Basin

README.md

@@ -29,3 +29,4 @@ Development occurs in language-specific directories:
 |[Day21.hs](hs/src/Day21.hs)|[Day21.kt](kt/src/commonMain/kotlin/com/github/ephemient/aoc2022/Day21.kt)|[day21.py](py/aoc2022/day21.py)|[day21.rs](rs/src/day21.rs)|
 |[Day22.hs](hs/src/Day22.hs)|[Day22.kt](kt/src/commonMain/kotlin/com/github/ephemient/aoc2022/Day22.kt)|[day22.py](py/aoc2022/day22.py)|[day22.rs](rs/src/day22.rs)|
 |[Day23.hs](hs/src/Day23.hs)|[Day23.kt](kt/src/commonMain/kotlin/com/github/ephemient/aoc2022/Day23.kt)|[day23.py](py/aoc2022/day23.py)|[day23.rs](rs/src/day23.rs)|
+|[Day24.hs](hs/src/Day24.hs)|

hs/aoc2022.cabal

@@ -34,6 +34,7 @@ data-files:
   , day21.txt
   , day22.txt
   , day23.txt
+  , day24.txt
 
 extra-source-files:
     README.md
@@ -64,6 +65,7 @@ library
       , Day21
       , Day22
       , Day23
+      , Day24
     build-depends:
         array ^>=0.5.4.0
       , base ^>=4.16.0.0
@@ -129,6 +131,7 @@ test-suite aoc2022-test
       , Day21Spec
       , Day22Spec
       , Day23Spec
+      , Day24Spec
     hs-source-dirs:   test
     default-language: GHC2021
     build-tool-depends:

hs/app/Main.hs

@@ -25,6 +25,7 @@ import Day20 (day20a, day20b)
 import Day21 (day21a, day21b)
 import Day22 (day22a, day22b)
 import Day23 (day23a, day23b)
+import Day24 (day24a, day24b)
 
 import Control.Monad ((<=<), ap, when)
 import Data.Function (on)
@@ -77,3 +78,4 @@ main = do
     run 21 (either (fail . errorBundlePretty) print) [day21a, day21b]
     run 22 print [day22a, day22b]
     run 23 print [day23a, day23b]
+    run 24 (maybe (fail "(⊥)") print) [day24a, day24b]

hs/bench/Main.hs

@@ -28,6 +28,7 @@ import Day20 (day20a, day20b)
 import Day21 (day21a, day21b)
 import Day22 (day22a, day22b)
 import Day23 (day23a, day23b)
+import Day24 (day24a, day24b)
 import Paths_aoc2022 (getDataFileName)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 
@@ -136,4 +137,8 @@ main = defaultMain
       [ bench "part 1" $ nf day23a input
       , bench "part 2" $ nf day23b input
       ]
+  , env (getDayInput 24) $ \input -> bgroup "Day 24"
+      [ bench "part 1" $ nf day24a input
+      , bench "part 2" $ nf day24b input
+      ]
   ]

hs/src/Day24.hs

@@ -0,0 +1,76 @@
+{-|
+Module:         Day24
+Description:    <https://adventofcode.com/2022/day/24 Day 24: Blizzard Basin>
+-}
+{-# LANGUAGE NondecreasingIndentation, ViewPatterns #-}
+module Day24 (day24a, day24b) where
+
+import Control.Arrow ((&&&), second)
+import Data.Either (partitionEithers)
+import qualified Data.Heap as Heap (FstMinPolicy, insert, singleton, view)
+import Data.List (foldl', transpose)
+import qualified Data.Map as Map ((!), (!?), fromList, fromListWith)
+import Data.Maybe (maybeToList)
+import Data.Semigroup (Arg(Arg), Max(Max), Min(Min))
+import Data.Set (Set)
+import qualified Data.Set as Set (difference, empty, fromDistinctAscList, fromList, insert, lookupMax, lookupMin, member, notMember, toList)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, unpack)
+import Data.Tuple (swap)
+
+parse :: (Enum a, Num a, Ord a) => Text -> Maybe ((a, a), (a, a), [Set (a, a)])
+parse input = (,, spaces) <$> Set.lookupMin startingSpaces <*> Set.lookupMax startingSpaces where
+    deltas = Map.fromList [('^', decY), ('>', incX), ('v', incY), ('<', decX)]
+    (Set.fromDistinctAscList -> startingSpaces, blizzards) = partitionEithers $ do
+        (y, line) <- zip [0..] $ T.lines input
+        (x, char) <- zip [0..] $ T.unpack line
+        if char == '.' then pure $ Left (y, x) else Right <$> do
+        delta <- maybeToList $ deltas Map.!? char
+        pure ((y, x), delta)
+    potentialSpaces = startingSpaces <> Set.fromList (fst <$> blizzards)
+    xy = Map.fromListWith (<>) $ second (Min &&& Max) <$> Set.toList potentialSpaces
+    yx = Map.fromListWith (<>) $ second (Min &&& Max) . swap <$> Set.toList potentialSpaces
+    incX (y, x) | x >= maxX = (y, minX) | otherwise = (y, x + 1)
+      where (Min minX, Max maxX) = xy Map.! y
+    decX (y, x) | x <= minX = (y, maxX) | otherwise = (y, x - 1)
+      where (Min minX, Max maxX) = xy Map.! y
+    incY (y, x) | y >= maxY = (minY, x) | otherwise = (y + 1, x)
+      where (Min minY, Max maxY) = yx Map.! x
+    decY (y, x) | y <= minY = (maxY, x) | otherwise = (y - 1, x)
+      where (Min minY, Max maxY) = yx Map.! x
+    spaces = (potentialSpaces `Set.difference`) . Set.fromList <$> transpose
+        [iterate delta $ delta pos | (pos, delta) <- blizzards]
+
+search :: (Ord a, Ord b) => (a -> [(b, a)]) -> (b, a) -> [a]
+search next = search' Set.empty . Heap.singleton @Heap.FstMinPolicy where
+    search' seen (Heap.view -> Just ((b, a), heap))
+      | Set.member a seen = search' seen heap
+      | otherwise = a : search' seen' heap' where
+            seen' = Set.insert a seen
+            heap' = foldl' (flip Heap.insert) heap .
+                filter (flip Set.notMember seen' . snd) $ next a
+    search' _ _ = []
+
+search' :: (Int, Int) -> (Int, Int) -> [Set (Int, Int)] -> Maybe (Int, [Set (Int, Int)])
+search' start end@(endY, endX) spaces = do
+    Arg n spaces' <- lookup end $ search next (0, (start, Arg 0 spaces))
+    pure (n, spaces')
+  where
+    next ((y, x), Arg n (space:spaces')) =
+      [ (abs (y' - endY) + abs (x' - endX) + n, (pos, Arg (n + 1) spaces'))
+      | pos@(y', x') <- [(y - 1, x), (y, x - 1), (y, x), (y, x + 1), (y + 1, x)]
+      , pos `Set.member` space
+      ]
+
+day24a :: Text -> Maybe Int
+day24a input = do
+    (start, end, spaces) <- parse input
+    fst <$> search' start end spaces
+
+day24b :: Text -> Maybe Int
+day24b input = do
+    (start, end, spaces) <- parse input
+    (n1, spaces') <- search' start end spaces
+    (n2, spaces'') <- search' end start spaces'
+    (n3, _) <- search' start end spaces''
+    pure $ n1 + n2 + n3

hs/test/Day24Spec.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day24Spec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unlines)
+import Day24 (day24a, day24b)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example = T.unlines
+  [ "#.######"
+  , "#>>.<^<#"
+  , "#.<..<<#"
+  , "#>v.><>#"
+  , "#<^v^^>#"
+  , "######.#"
+  ]
+
+spec :: Spec
+spec = do
+    describe "part 1" $ do
+        it "examples" $ do
+            day24a example `shouldBe` Just 18
+    describe "part 2" $ do
+        it "examples" $ do
+            day24b example `shouldBe` Just 54