From 295e2d7671d5ef002d741100fef25bbcf55f808d Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Thu, 21 Dec 2023 11:56:39 +0000 Subject: [PATCH] Done day 17 part 2 --- advent17/Main.hs | 229 +++++++++++++++++++++++------------------- advent17/MainSteps.hs | 176 ++++++++++++++++++++++++++++++++ 2 files changed, 299 insertions(+), 106 deletions(-) create mode 100644 advent17/MainSteps.hs 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 diff --git a/advent17/MainSteps.hs b/advent17/MainSteps.hs new file mode 100644 index 0000000..1197c20 --- /dev/null +++ b/advent17/MainSteps.hs @@ -0,0 +1,176 @@ +-- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-12/ + +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.Char +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) +import Linear (V2(..), (^+^), (^-^), _x, _y) +import Data.Array.IArray + +type Position = V2 Int -- r, c +_r :: Lens' (V2 Int) Int +_r = _x +_c :: Lens' (V2 Int) Int +_c = _y + +type Trail = Q.Seq Position + +type Grid = Array Position Int + +data City = City + { _grid :: Grid + , _start :: Position + , _goal :: Position + } deriving (Eq, Ord, Show) +makeLenses ''City + +type CityContext = Reader City + +data Agendum = + Agendum { _current :: Trail + , _trail :: Trail + , _trailCost :: Int + , _cost :: Int + } deriving (Show, Eq) +makeLenses ''Agendum + +type Agenda = P.MinPQueue Int Agendum + +type ExploredStates = S.Set Trail + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let city = mkCity text + -- print city + print $ part1 city + -- print $ part2 city + +-- 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 + + +mkCity :: String -> City +mkCity text = City { _grid = grid, _start = (V2 0 0), _goal = (V2 r c) } + where rows = lines text + r = length rows - 1 + c = (length $ head rows) - 1 + grid = listArray ((V2 0 0), (V2 r c)) $ map digitToInt $ concat rows + +searchCity :: Position -> CityContext (Maybe Agendum) +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 = + do let candidate = agendum ^. current + 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) = + 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) + + +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 -- 2.34.1