From 7cffb3be30625eceba08119787413758f58ad03e Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Wed, 20 Dec 2023 13:52:02 +0000 Subject: [PATCH] Done day 17 part 1 --- advent-of-code23.cabal | 5 ++ advent17/Main.hs | 176 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 181 insertions(+) create mode 100644 advent17/Main.hs diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index dbddc05..39f88e1 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -196,3 +196,8 @@ executable advent16 import: common-extensions, build-directives main-is: advent16/Main.hs build-depends: linear, array, containers + +executable advent17 + import: common-extensions, build-directives + main-is: advent17/Main.hs + build-depends: containers, linear, array, pqueue, mtl, lens diff --git a/advent17/Main.hs b/advent17/Main.hs new file mode 100644 index 0000000..1197c20 --- /dev/null +++ b/advent17/Main.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