From 37f5b0276e3c8858847f51290f15de169de82201 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sat, 24 Dec 2022 14:47:33 +0000 Subject: [PATCH] Done day 24 --- advent-of-code22.cabal | 6 +- advent24/Main.hs | 224 ++++++++++++++++++++++++++ data/advent24.txt | 27 ++++ data/advent24a.txt | 6 + problems/day24.html | 349 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 611 insertions(+), 1 deletion(-) create mode 100644 advent24/Main.hs create mode 100644 data/advent24.txt create mode 100644 data/advent24a.txt create mode 100644 problems/day24.html diff --git a/advent-of-code22.cabal b/advent-of-code22.cabal index 20d4771..532085c 100644 --- a/advent-of-code22.cabal +++ b/advent-of-code22.cabal @@ -224,4 +224,8 @@ executable advent23prof -Wall -threaded -rtsopts "-with-rtsopts=-N -p -s -hT" - \ No newline at end of file + +executable advent24 + import: common-extensions, build-directives + main-is: advent24/Main.hs + build-depends: containers, pqueue, mtl, lens, linear, array diff --git a/advent24/Main.hs b/advent24/Main.hs new file mode 100644 index 0000000..c3e1469 --- /dev/null +++ b/advent24/Main.hs @@ -0,0 +1,224 @@ +-- Writeup at https://work.njae.me.uk/2022/12/24/advent-of-code-2022-day-24/ + +-- import Debug.Trace + +import AoC +import qualified Data.PQueue.Prio.Min as P +import qualified Data.Set as S +import qualified Data.IntMap.Strict as M +import qualified Data.Sequence as Q +-- import Data.Sequence ((<|), (|>), (><)) +import Data.Sequence ((|>)) +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) +import Linear (V2(..), (^+^), (^-^)) +import Data.Array.IArray +-- import Data.Ix +import Data.List +import Data.Maybe + +-- pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty +-- pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|) +-- pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>) + +type Position = V2 Int -- x, y + +data Blizzard = Blizzard { _positionB :: Position, _headingB :: Position} + deriving (Eq, Ord, Show) +makeLenses ''Blizzard + +type SafeValley = Array Position Bool +type TimedValley = M.IntMap SafeValley + +data Valley = Valley + { blizzardStates :: TimedValley + , start :: Position + , goal :: Position + } deriving (Eq, Ord, Show) + +type ValleyContext = Reader Valley + +data Explorer = Explorer + { _currentPosition :: Position + , _currentTime :: Int + }deriving (Eq, Ord, Show) +makeLenses ''Explorer + +data Agendum = + Agendum { _current :: Explorer + , _trail :: Q.Seq Explorer + , _trailCost :: Int + , _cost :: Int + } deriving (Show, Eq) +makeLenses ''Agendum + +type Agenda = P.MinPQueue Int Agendum + +type ExploredStates = S.Set Explorer + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let (blizzards, bnds) = mkInitialMap text + let valley = makeValley bnds blizzards 1000 + print $ part1 valley + print $ part2 valley + +part1, part2 :: Valley -> Int +part1 valley = _currentTime $ _current $ fromJust result + where result = runSearch valley 0 + +part2 valley = trip3End + where reverseValley = valley {start = (goal valley), goal = (start valley)} + trip1End = _currentTime $ _current $ fromJust $ runSearch valley 0 + trip2End = _currentTime $ _current $ fromJust $ runSearch reverseValley trip1End + trip3End = _currentTime $ _current $ fromJust $ runSearch valley trip2End + +makeValley :: (Position, Position) -> S.Set Blizzard -> Int -> Valley +makeValley bds blizzards n = Valley + { blizzardStates = bStates + , start = V2 (minX + 1) maxY + , goal = V2 (maxX - 1) minY + } + where bStates = simulateBlizzards bds blizzards n + (V2 minX minY, V2 maxX maxY) = bounds $ bStates M.! 0 + +runSearch :: Valley -> Int -> Maybe Agendum +runSearch valley t = result + where result = runReader (searchValley t) valley + +searchValley :: Int -> ValleyContext (Maybe Agendum) +searchValley t = + do agenda <- initAgenda t + aStar agenda S.empty + +initAgenda :: Int -> ValleyContext Agenda +initAgenda t = + do pos <- asks start + let explorer = Explorer pos t + c <- estimateCost explorer + return $ P.singleton c Agendum { _current = explorer, _trail = Q.empty, _trailCost = 0, _cost = c} + +aStar :: Agenda -> ExploredStates -> ValleyContext (Maybe Agendum) +aStar agenda closed + -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined + -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMin agenda) ) False = undefined + -- | trace ("Peeping " ++ (show $ snd $ P.findMin agenda) ) False = undefined + | P.null agenda = return Nothing + | otherwise = + do let (_, currentAgendum) = P.findMin agenda + let reached = currentAgendum ^. current + nexts <- candidates currentAgendum closed + let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts + reachedGoal <- isGoal reached + if reachedGoal + then return (Just currentAgendum) + else if reached `S.member` closed + then aStar (P.deleteMin agenda) closed + else aStar newAgenda (S.insert reached closed) + +candidates :: Agendum -> ExploredStates -> ValleyContext (Q.Seq Agendum) +candidates agendum closed = + do let candidate = agendum ^. current + let previous = agendum ^. trail + let prevCost = agendum ^. trailCost + succs <- successors candidate + let nonloops = Q.filter (\s -> s `S.notMember` closed) succs + mapM (makeAgendum previous prevCost) nonloops + +makeAgendum :: Q.Seq Explorer -> Int -> Explorer -> ValleyContext Agendum +makeAgendum previous prevCost newExplorer = + do predicted <- estimateCost newExplorer + let newTrail = previous |> newExplorer + let incurred = prevCost + 1 + return Agendum { _current = newExplorer + , _trail = newTrail + , _trailCost = incurred + , _cost = incurred + predicted + } + +isGoal :: Explorer -> ValleyContext Bool +isGoal here = + do goal <- asks goal + return $ (here ^. currentPosition) == goal + +successors :: Explorer -> ValleyContext (Q.Seq Explorer) +successors here = + do allBlizzards <- asks blizzardStates + let nextTime = (here ^. currentTime) + 1 + let blizzards = allBlizzards M.! nextTime + let bds = bounds blizzards + let pos = here ^. currentPosition + let neighbours = + filter (\p -> (blizzards ! p)) $ + filter (inRange bds) + [ pos ^+^ delta + | delta <- [V2 0 0, V2 -1 0, V2 1 0, V2 0 -1, V2 0 1] + ] + let succs = Q.fromList + $ fmap (\nbr -> here & currentTime .~ nextTime + & currentPosition .~ nbr ) + neighbours + return succs + +estimateCost :: Explorer -> ValleyContext Int +estimateCost here = + do goal <- asks goal + let (V2 dx dy) = (here ^. currentPosition) ^-^ goal + return $ (abs dx) + (abs dy) + + +mkInitialMap :: String -> (S.Set Blizzard, (Position, Position)) +mkInitialMap text = + ( S.fromList [ Blizzard (V2 (x - 1) (y - 1)) (deltaOfArrow $ charAt x y) + | x <- [0..maxX] + , y <- [0..maxY] + , isBlizzard x y + ] + , (V2 0 0, V2 (maxX - 1) (maxY - 1)) + ) + where rows = reverse $ lines text + maxY = length rows - 1 + maxX = (length $ head rows) - 1 + charAt x y = ((rows !! y) !! x) + isBlizzard x y = (charAt x y) `elem` ("^<>v" :: String) + +deltaOfArrow :: Char -> Position +deltaOfArrow '^' = V2 0 1 +deltaOfArrow '>' = V2 1 0 +deltaOfArrow 'v' = V2 0 -1 +deltaOfArrow '<' = V2 -1 0 +deltaOfArrow _ = V2 0 0 + +advanceBlizzard :: (Position, Position) -> S.Set Blizzard -> S.Set Blizzard +advanceBlizzard bnds blizzards = S.map (advanceOneBlizzard bnds) blizzards + +advanceOneBlizzard :: (Position, Position) -> Blizzard -> Blizzard +advanceOneBlizzard (_, V2 maxX maxY) blizzard = blizzard' & positionB %~ wrap + where wrap (V2 x0 y0) = V2 (x0 `mod` maxX) (y0 `mod` maxY) + blizzard' = blizzard & positionB %~ (^+^ (blizzard ^. headingB)) + +toSafe :: (Position, Position) -> S.Set Blizzard -> SafeValley +toSafe (_, V2 maxX maxY) blizzards = accumArray (\_ _ -> False) True bnds' unsafeElements + where unsafeElements = fmap (\i -> (i, False)) $ blizzardLocations ++ walls + blizzardLocations = fmap (^+^ (V2 1 1)) $ fmap (^. positionB) $ S.toList blizzards + walls = left ++ right ++ top ++ bottom + left = range (V2 0 0 , V2 0 (maxY + 1)) + right = range (V2 (maxX + 1) 0 , V2 (maxX + 1) (maxY + 1)) + top = range (V2 2 (maxY + 1), V2 (maxX + 1) (maxY + 1)) + bottom = range (V2 0 0 , V2 (maxX - 1) 0 ) + bnds' = (V2 0 0, V2 (maxX + 1) (maxY + 1)) + +simulateBlizzards :: (Position, Position) -> S.Set Blizzard -> Int -> TimedValley +simulateBlizzards bnds blizzards n = + M.fromList $ take n + $ zip [0..] + $ fmap (toSafe bnds) + $ iterate (advanceBlizzard bnds) blizzards + +showSafe :: SafeValley -> String +showSafe valley = unlines $ reverse rows + where (V2 minX minY, V2 maxX maxY) = bounds valley + rows = [mkRow y | y <- [minY..maxY]] + mkRow y = [if valley ! (V2 x y) then '.' else '#' | x <- [minX..maxX]] diff --git a/data/advent24.txt b/data/advent24.txt new file mode 100644 index 0000000..7bd0678 --- /dev/null +++ b/data/advent24.txt @@ -0,0 +1,27 @@ +#.######################################################################################################################## +#.><<<^v<>^<^vv.^<^^^<^v><>vvv.^><..vv>>>>>>^<^>^>vv<^>>^v^.<.<<>^<<>^>>^>.><>.^>.v^<<><<^vvv<# +#>.v<>v>vv^.<>^^v.><<^>^v^<>v^>>>><<^<^vv>v>><^>v.^v<<^v<.<>v>>^><>>^>^<>v<><<>.v.^<.<<>vvv<^v.<>v>^^vv^^^<>^^<<<^># +#><.<.vvv<><^<>v<.v>v.<>^>^v>^<<>><^^^v^>^..<<^<.>^^v.<vv><<>^v><>><>^<^^^^v^<>><.vvvv.<># +#>v>^v>>vvv<>.><>.>>v>vvv^>>><<>>><.vvv.<>.<>^<>v><v>.>^^v^.^><^<^<<<^^^>v><>^v^.<<>v># +#<^>v>vvv>v.>v^<..^.^<..^>>^vv^<>><^v><>>vv.v<^.v^<>v.>^<.^v>><<>v>vv>><<^>>># +#<^v<>vv^>><<^<^>^^<.<<^^.v<^<>>v^<^^>v>v>>v^<<.^<<^>>><^v<>^^<>v>><>.v>v.^>><>.^<># +#<.<.>vvv^^.^.^<<<.<>>>v^><.v>v.>^^<^>^>>>^>v.v<>.^^^^.^^>v.<^>>^vv^^vv>>v><^^.><>>.># +#><>v<<^v^v^^>>v^>>.v<>>>>.><^>>>.vv^>>vv>.v>v^v>>><<<>v.vv.^vvv^vv>^v..<^^^^^v^>v<<.^^<>.vv.^^>><# +#>.v^^.vv^<>.<><^^.v.^^>^>v<^<.<<>.v^.>v<>>^>vvv<^^^v<<<^>>v^vvv^vvv>v>^<>># +#><^<^<^v.>>^<>^>><<<<<^..^^<<^>v>.vvv^vv^>>v^v^^v<.<.v^<>v^<<><^vv><>>^v.v.^>>^>^><>v<<<^<><<><.<<>>>>>^v^>^..v>^<>.<<.>v>v<>.<<>.v<.v>^<>><<>>v<>>^><.vvv.><^<><^v>v<^v>^v<>>^.v.<># +#<>><^.^^v^v><^^<.>v<>^><>v^.v>vv^>>>><^vvv>>.>.<>vv>^>v<.^>^v>^v>^v>v^^vv.<<>^<..^v<>v<>vv<<<^v<^v>^^v>># +#><.<^v><>v>>vvvv^vvv.^.v>v^^.>vvv^^<>vvv>vv>>>>^>v.>.>^><>^^.>>.^.vv^><>><^>^<<<.<<.>.v<^># +#><vvvv<^>^.>^.<<..^^>.v<>^v>^^>^vvv<<>.^v^v<<>v^..v^^<>><<>v^vv<^.^.><# +#<.v><.>v^vv..<><.v>^>^^^^^>v^v><^>v<v<^v>^.v.>>>^^>.^^<>v>>^^.v>vv^<^>v^>>^<# +#<^<^><>>v<.>^>v>v<>^^<>v>v<>v>><^><>>v.v^v^^^v^^vv<^>><<<>^^^>^<<<>.^<>>>.>v.v^..^<^>>>>.^>^^.>>^>^<^<.^<># +#>><^v><>v><.^^>.^v>^v^v.vv<^.><^^.^<>vv>>>.>v^.<^<^v>^v.<<vv>.^v^v>^<.<<.^v^>^^<>>.^^v<># +#>.^v^>v<..v^.<>^.>^<^v.^><>^>^><^>>^<.>.^.<>>^.v.^v>v<>v>v>v>>^^v>v<>^^^v<<# +#v><<>>v<^>v^v>.>v>><^v>v^>....v<<^^^^vv<>><^<^^v^>>^<<^^>^<.^^<>vv^<^<<>v^vv^^.^>^.^>>.<>^>.v^<>^.<.<^^.<# +#>vv<^^>^^v^v<<^^v<><^v.<><.>^.^^^..v<>>^>..><<<.v<^<>^<>>^^<^.^>^<>>v<.>^<<<<>v^^.^<..<># +#<^^vvv^<.^<>.^^.<^<<>.>^vv^.v<>.<.>.><<^>.v<>.vv>vv<<<<>.>^v>>^<>.^>>^>v>.v^<# +#<<^>^^>v>>v><>>>>>v>v><^^^vv<>.v<<<><.v.<><><><^.^v<<^>.v^vv><^>^^>v>>v<^.<.<^^<>^^v<><<># +#<^>>^<.>><>>v.^.>^^>>^<<>v<>>^v<>^>.^v<^^^>.<>v><>^<^vv<><<^^<.^^v<^^<<^<^<<^^>^^^<^^v<<>>>v^.vv<.v^><># +#>.>>>.<>^.v^^<<^^>vv^>>>>>v^v>vv^>.vv<.vv.<.^.>.><<^<.vv.vv>.^^>vv>><<<.><>v..><^<<>.v<.>><><.^<<<<^>>v^.^>>.<.<<^vvv^.^vv^<>^^<.^<^<.^<<>^<^># +########################################################################################################################.# \ No newline at end of file diff --git a/data/advent24a.txt b/data/advent24a.txt new file mode 100644 index 0000000..6b9b892 --- /dev/null +++ b/data/advent24a.txt @@ -0,0 +1,6 @@ +#.###### +#>>.<^<# +#.<..<<# +#>v.><># +#<^v^^># +######.# \ No newline at end of file diff --git a/problems/day24.html b/problems/day24.html new file mode 100644 index 0000000..099c45c --- /dev/null +++ b/problems/day24.html @@ -0,0 +1,349 @@ + + + + +Day 24 - Advent of Code 2022 + + + + + + + + +
+ + + +
+

--- Day 24: Blizzard Basin ---

With everything replanted for next year (and with elephants and monkeys to tend the grove), you and the Elves leave for the extraction point.

+

Partway up the mountain that shields the grove is a flat, open area that serves as the extraction point. It's a bit of a climb, but nothing the expedition can't handle.

+

At least, that would normally be true; now that the mountain is covered in snow, things have become more difficult than the Elves are used to.

+

As the expedition reaches a valley that must be traversed to reach the extraction site, you find that strong, turbulent winds are pushing small blizzards of snow and sharp ice around the valley. It's a good thing everyone packed warm clothes! To make it across safely, you'll need to find a way to avoid them.

+

Fortunately, it's easy to see all of this from the entrance to the valley, so you make a map of the valley and the blizzards (your puzzle input). For example:

+
#.#####
+#.....#
+#>....#
+#.....#
+#...v.#
+#.....#
+#####.#
+
+

The walls of the valley are drawn as #; everything else is ground. Clear ground - where there is currently no blizzard - is drawn as .. Otherwise, blizzards are drawn with an arrow indicating their direction of motion: up (^), down (v), left (<), or right (>).

+

The above map includes two blizzards, one moving right (>) and one moving down (v). In one minute, each blizzard moves one position in the direction it is pointing:

+
#.#####
+#.....#
+#.>...#
+#.....#
+#.....#
+#...v.#
+#####.#
+
+

Due to conservation of blizzard energy, as a blizzard reaches the wall of the valley, a new blizzard forms on the opposite side of the valley moving in the same direction. After another minute, the bottom downward-moving blizzard has been replaced with a new downward-moving blizzard at the top of the valley instead:

+
#.#####
+#...v.#
+#..>..#
+#.....#
+#.....#
+#.....#
+#####.#
+
+

Because blizzards are made of tiny snowflakes, they pass right through each other. After another minute, both blizzards temporarily occupy the same position, marked 2:

+
#.#####
+#.....#
+#...2.#
+#.....#
+#.....#
+#.....#
+#####.#
+
+

After another minute, the situation resolves itself, giving each blizzard back its personal space:

+
#.#####
+#.....#
+#....>#
+#...v.#
+#.....#
+#.....#
+#####.#
+
+

Finally, after yet another minute, the rightward-facing blizzard on the right is replaced with a new one on the left facing the same direction:

+
#.#####
+#.....#
+#>....#
+#.....#
+#...v.#
+#.....#
+#####.#
+
+

This process repeats at least as long as you are observing it, but probably forever.

+

Here is a more complex example:

+
#.######
+#>>.<^<#
+#.<..<<#
+#>v.><>#
+#<^v^^>#
+######.#
+
+

Your expedition begins in the only non-wall position in the top row and needs to reach the only non-wall position in the bottom row. On each minute, you can move up, down, left, or right, or you can wait in place. You and the blizzards act simultaneously, and you cannot share a position with a blizzard.

+

In the above example, the fastest way to reach your goal requires 18 steps. Drawing the position of the expedition as E, one way to achieve this is:

+
Initial state:
+#E######
+#>>.<^<#
+#.<..<<#
+#>v.><>#
+#<^v^^>#
+######.#
+
+Minute 1, move down:
+#.######
+#E>3.<.#
+#<..<<.#
+#>2.22.#
+#>v..^<#
+######.#
+
+Minute 2, move down:
+#.######
+#.2>2..#
+#E^22^<#
+#.>2.^>#
+#.>..<.#
+######.#
+
+Minute 3, wait:
+#.######
+#<^<22.#
+#E2<.2.#
+#><2>..#
+#..><..#
+######.#
+
+Minute 4, move up:
+#.######
+#E<..22#
+#<<.<..#
+#<2.>>.#
+#.^22^.#
+######.#
+
+Minute 5, move right:
+#.######
+#2Ev.<>#
+#<.<..<#
+#.^>^22#
+#.2..2.#
+######.#
+
+Minute 6, move right:
+#.######
+#>2E<.<#
+#.2v^2<#
+#>..>2>#
+#<....>#
+######.#
+
+Minute 7, move down:
+#.######
+#.22^2.#
+#<vE<2.#
+#>>v<>.#
+#>....<#
+######.#
+
+Minute 8, move left:
+#.######
+#.<>2^.#
+#.E<<.<#
+#.22..>#
+#.2v^2.#
+######.#
+
+Minute 9, move up:
+#.######
+#<E2>>.#
+#.<<.<.#
+#>2>2^.#
+#.v><^.#
+######.#
+
+Minute 10, move right:
+#.######
+#.2E.>2#
+#<2v2^.#
+#<>.>2.#
+#..<>..#
+######.#
+
+Minute 11, wait:
+#.######
+#2^E^2>#
+#<v<.^<#
+#..2.>2#
+#.<..>.#
+######.#
+
+Minute 12, move down:
+#.######
+#>>.<^<#
+#.<E.<<#
+#>v.><>#
+#<^v^^>#
+######.#
+
+Minute 13, move down:
+#.######
+#.>3.<.#
+#<..<<.#
+#>2E22.#
+#>v..^<#
+######.#
+
+Minute 14, move right:
+#.######
+#.2>2..#
+#.^22^<#
+#.>2E^>#
+#.>..<.#
+######.#
+
+Minute 15, move right:
+#.######
+#<^<22.#
+#.2<.2.#
+#><2>E.#
+#..><..#
+######.#
+
+Minute 16, move right:
+#.######
+#.<..22#
+#<<.<..#
+#<2.>>E#
+#.^22^.#
+######.#
+
+Minute 17, move down:
+#.######
+#2.v.<>#
+#<.<..<#
+#.^>^22#
+#.2..2E#
+######.#
+
+Minute 18, move down:
+#.######
+#>2.<.<#
+#.2v^2<#
+#>..>2>#
+#<....>#
+######E#
+
+

What is the fewest number of minutes required to avoid the blizzards and reach the goal?

+
+

Your puzzle answer was 288.

--- Part Two ---

As the expedition reaches the far side of the valley, one of the Elves looks especially dismayed:

+

He forgot his snacks at the entrance to the valley!

+

Since you're so good at dodging blizzards, the Elves humbly request that you go back for his snacks. From the same initial conditions, how quickly can you make it from the start to the goal, then back to the start, then back to the goal?

+

In the above example, the first trip to the goal takes 18 minutes, the trip back to the start takes 23 minutes, and the trip back to the goal again takes 13 minutes, for a total time of 54 minutes.

+

What is the fewest number of minutes required to reach the goal, go back to the start, then reach the goal again?

+
+

Your puzzle answer was 861.

Both parts of this puzzle are complete! They provide two gold stars: **

+

At this point, you should return to your Advent calendar and try another puzzle.

+

If you still want to see it, you can get your puzzle input.

+

You can also this puzzle.

+
+ + + + + + \ No newline at end of file -- 2.34.1