X-Git-Url: https://git.njae.me.uk/?a=blobdiff_plain;f=advent17%2FMain.hs;fp=advent17%2FMain.hs;h=598a2dfceda37d99c29dc51f7e12ed0fe74d7f24;hb=295e2d7671d5ef002d741100fef25bbcf55f808d;hp=1197c20101d0ae9581931e12869e486dde287cd9;hpb=7cffb3be30625eceba08119787413758f58ad03e;p=advent-of-code-23.git diff --git a/advent17/Main.hs b/advent17/Main.hs index 1197c20..598a2df 100644 --- a/advent17/Main.hs +++ b/advent17/Main.hs @@ -1,18 +1,18 @@ --- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-12/ +-- Writeup at https://work.njae.me.uk/2023/12/21/advent-of-code-2023-day-17/ import AoC -import Debug.Trace - import qualified Data.PQueue.Prio.Min as P import qualified Data.Set as S import qualified Data.Sequence as Q -import Data.Sequence ((|>), Seq( (:|>) ) ) -import Data.Foldable (foldl', toList) +-- import Data.Sequence ((|>), (><), Seq( (:|>) ) ) +import Data.Sequence ((|>), (><)) +import Data.Foldable (foldl') import Data.Char import Control.Monad.Reader -import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) -import Linear (V2(..), (^+^), (^-^), _x, _y) +-- import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) +import Control.Lens hiding ((|>)) +import Linear (V2(..), (^+^), (^-^), (^*), _x, _y) import Data.Array.IArray type Position = V2 Int -- r, c @@ -21,10 +21,17 @@ _r = _x _c :: Lens' (V2 Int) Int _c = _y -type Trail = Q.Seq Position +data Direction = U | D | L | R deriving (Show, Eq, Ord) +data Move = Move Direction Int deriving (Show, Eq, Ord) + +type Trail = Q.Seq Move + +type DirectedPosition = (Direction, Position) type Grid = Array Position Int +type ExploredStates = S.Set DirectedPosition + data City = City { _grid :: Grid , _start :: Position @@ -34,17 +41,18 @@ makeLenses ''City type CityContext = Reader City -data Agendum = - Agendum { _current :: Trail +data Crucible +data UltraCrucible + +data Agendum a = + Agendum { _current :: DirectedPosition , _trail :: Trail , _trailCost :: Int , _cost :: Int } deriving (Show, Eq) makeLenses ''Agendum -type Agenda = P.MinPQueue Int Agendum - -type ExploredStates = S.Set Trail +type Agenda a = P.MinPQueue Int (Agendum a) main :: IO () main = @@ -53,22 +61,16 @@ main = let city = mkCity text -- print city print $ part1 city - -- print $ part2 city + print $ part2 city --- part1, part2 :: City -> Int +part1, part2 :: City -> Int part1 city = maybe 0 _cost result where s = city ^. start - result = runReader (searchCity s) city - --- part2 city = minimum results --- where starts = possibleStarts city --- results = fmap (runSearch city) starts - -runSearch :: City -> Position -> Int -runSearch city s = maybe maxCost _cost result - where result = runReader (searchCity s) city - maxCost = length $ indices $ city ^. grid + result = runReader (searchCity s) city :: (Maybe (Agendum Crucible)) +part2 city = maybe 0 _cost result + where s = city ^. start + result = runReader (searchCity s) city :: (Maybe (Agendum UltraCrucible)) mkCity :: String -> City mkCity text = City { _grid = grid, _start = (V2 0 0), _goal = (V2 r c) } @@ -77,100 +79,115 @@ mkCity text = City { _grid = grid, _start = (V2 0 0), _goal = (V2 r c) } c = (length $ head rows) - 1 grid = listArray ((V2 0 0), (V2 r c)) $ map digitToInt $ concat rows -searchCity :: Position -> CityContext (Maybe Agendum) -searchCity startPos = + +class Searchable a where + + searchCity :: Position -> CityContext (Maybe (Agendum a)) + searchCity startPos = do agenda <- initAgenda startPos aStar agenda S.empty -initAgenda :: Position -> CityContext Agenda -initAgenda pos = - do c <- estimateCost pos - -- return $ P.singleton c Agendum { _current = pos, _trail = Q.empty, _trailCost = 0, _cost = c} - return $ P.singleton c Agendum { _current = Q.singleton pos, _trail = Q.singleton pos, _trailCost = 0, _cost = c} - -aStar :: Agenda -> ExploredStates -> CityContext (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 - -- | trace ("Peeping " ++ (show 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 -> CityContext (Q.Seq Agendum) -candidates agendum closed = + initAgenda :: Position -> CityContext (Agenda a) + initAgenda pos = + do c <- estimateCost pos + let dAgendum = Agendum { _current = (D, pos), _trail = Q.empty, _trailCost = 0, _cost = c} + dNexts <- candidates dAgendum S.empty + let rAgendum = Agendum { _current = (R, pos), _trail = Q.empty, _trailCost = 0, _cost = c} + rNexts <- candidates rAgendum S.empty + let nexts = dNexts >< rNexts + let agenda = foldl' (\q a -> P.insert (_cost a) a q) P.empty nexts + return agenda + + aStar :: (Agenda a) -> ExploredStates -> CityContext (Maybe (Agendum a)) + 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 + -- | trace ("Peeping " ++ (show 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 a) -> ExploredStates -> CityContext (Q.Seq (Agendum a)) + candidates agendum closed = do let candidate = agendum ^. current + let (_, here) = candidate let previous = agendum ^. trail let prevCost = agendum ^. trailCost - succs <- successors candidate - let bent = Q.filter isBent succs - let nonloops = Q.filter (\s -> s `S.notMember` closed) bent - mapM (makeAgendum previous prevCost) nonloops - -isBent :: Trail -> Bool --- isBent previous (V2 row col) --- | Q.length previous <= 3 = True --- | otherwise = not $ --- all (\p -> p ^. _r == row) previous || all (\p -> p ^. _c == col) previous -isBent trail - | Q.length trail <= 4 = True - | otherwise = not $ all id $ toList $ Q.zipWith (==) diffs $ Q.drop 1 diffs - where diffs = Q.zipWith (^-^) trail $ Q.drop 1 trail - - -makeAgendum :: Trail -> Int -> Trail -> CityContext Agendum -makeAgendum previous prevCost newState = - do let (_ :|> newPosition) = newState - predicted <- estimateCost newPosition - grid <- asks _grid - let newTrail = previous |> newPosition - let incurred = prevCost + (grid ! newPosition) - return Agendum { _current = newState - , _trail = newTrail - , _trailCost = incurred - , _cost = incurred + predicted - } - -isGoal :: Trail -> CityContext Bool -isGoal (_ :|> here) = + succs <- successors agendum candidate + let nonloops = Q.filter (\s -> (endingDirPos here s) `S.notMember` closed) succs + mapM (makeAgendum previous prevCost here) nonloops + + successors :: (Agendum a) -> DirectedPosition -> CityContext (Q.Seq Move) + + makeAgendum :: Trail -> Int -> Position -> Move -> CityContext (Agendum a) + makeAgendum previous prevCost here move = + do let positions = toPositions here move + predicted <- estimateCost $ last positions + grid <- asks _grid + let newTrail = previous |> move + let incurred = prevCost + (sum $ fmap (grid !) positions) + return Agendum { _current = endingDirPos here move + , _trail = newTrail + , _trailCost = incurred + , _cost = incurred + predicted + } + + +instance Searchable Crucible where + successors _ = successorsWithRange (1, 3) + +instance Searchable UltraCrucible where + successors _ = successorsWithRange (4, 10) + +successorsWithRange :: (Int, Int) -> DirectedPosition -> CityContext (Q.Seq Move) +successorsWithRange rng (dir, here) = + do grid <- asks _grid + let moves = [ Move d n + | d <- turnDirections dir + , n <- range rng + ] + let validMoves = filter (allInBounds (bounds grid) here) moves + return $ Q.fromList validMoves + +isGoal :: DirectedPosition -> CityContext Bool +isGoal (_, here) = do goal <- asks _goal return $ here == goal -successors :: Trail -> CityContext (Q.Seq Trail) -successors trail@(ph :|> here) = - do grid <- asks _grid - let neighbours = - filter (inRange (bounds grid)) - [ here ^+^ delta - | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1] - ] - let neighbours' = if Q.null ph - then neighbours - else let (_ :|> ph') = ph - in filter (/= ph') neighbours - let prev = takeL 4 trail - let succs = Q.fromList $ fmap (prev :|>) neighbours' - return succs - estimateCost :: Position -> CityContext Int --- estimateCost _ = return 0 estimateCost here = do goal <- asks _goal let (V2 dr dc) = here ^-^ goal return $ (abs dr) + (abs dc) +delta :: Direction -> Position +delta U = V2 (-1) 0 +delta D = V2 1 0 +delta L = V2 0 (-1) +delta R = V2 0 1 + +turnDirections :: Direction -> [Direction] +turnDirections U = [L, R] +turnDirections D = [L, R] +turnDirections L = [U, D] +turnDirections R = [U, D] + +toPositions :: Position -> Move -> [Position] +toPositions here (Move dir n) = [ here ^+^ (d ^* i) | i <- [1..n] ] + where d = delta dir + +endingDirPos :: Position -> Move -> DirectedPosition +endingDirPos here move@(Move dir _) = (dir, last $ toPositions here move) -takeL :: Int -> Q.Seq a -> Q.Seq a -takeL _ Q.Empty = Q.empty -takeL 0 _ = Q.empty -takeL n (xs :|> x) = (takeL (n-1) xs) :|> x +allInBounds :: (Position, Position) -> Position -> Move -> Bool +allInBounds bounds here move = all (inRange bounds) $ toPositions here move