--- /dev/null
+-- 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]]
projects / advent-of-code-22.git / blobdiff