X-Git-Url: https://git.njae.me.uk/?p=advent-of-code-22.git;a=blobdiff_plain;f=advent24%2FMain.hs;fp=advent24%2FMain.hs;h=c3e146983cd1f88724c87c1e1b90ba66c5d7eae4;hp=0000000000000000000000000000000000000000;hb=37f5b0276e3c8858847f51290f15de169de82201;hpb=7778be60c8e0c4c95201560d4b2d1ff250c7241b 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]]