From: Neil Smith Date: Thu, 16 Dec 2021 12:00:37 +0000 (+0000) Subject: Faster version of day 15 X-Git-Url: https://git.njae.me.uk/?a=commitdiff_plain;h=513138024a69ef9f5ade5031cd945567b6510689;p=advent-of-code-21.git Faster version of day 15 --- diff --git a/advent-of-code21.cabal b/advent-of-code21.cabal index 050473f..2ef838c 100644 --- a/advent-of-code21.cabal +++ b/advent-of-code21.cabal @@ -1,11 +1,11 @@ -cabal-version: 3.6 --- Initial package description 'advent-of-code21.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - -name: advent-of-code21 -version: 0.1.0.0 -synopsis: Advent of Code 21 solutions + cabal-version: 3.6 + -- Initial package description 'advent-of-code21.cabal' generated by 'cabal + -- init'. For further documentation, see + -- http://haskell.org/cabal/users-guide/ + + name: advent-of-code21 + version: 0.1.0.0 + synopsis: Advent of Code 21 solutions -- description: -- bug-reports: license: MIT @@ -159,3 +159,20 @@ executable advent15 import: common-extensions, build-directives main-is: advent15/Main.hs build-depends: text, containers, linear, array, pqueue, mtl, lens + +executable advent15slow + import: common-extensions, build-directives + main-is: advent15/MainSlow.hs + build-depends: text, containers, linear, array, pqueue, mtl, lens + +executable advent15prof + import: common-extensions, build-directives + main-is: advent15/Main.hs + build-depends: text, containers, linear, array, pqueue, mtl, lens + profiling: True + library-profiling: True + profiling-detail: toplevel-functions + ghc-options: -O2 + -Wall + -threaded + -rtsopts "-with-rtsopts=-N -p -s -hT" diff --git a/advent15/Main.hs b/advent15/Main.hs index 1186a52..227f160 100644 --- a/advent15/Main.hs +++ b/advent15/Main.hs @@ -18,6 +18,7 @@ import Control.Lens hiding ((<|), (|>), (:>), (:<)) import Data.Maybe (fromMaybe) import Linear (V2(..), (^+^), (^-^), (*^), (^*)) import Data.Array.IArray +-- import Data.List pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty @@ -43,6 +44,7 @@ type CaveContext = Reader Cave data Agendum s = Agendum { _current :: s , _trail :: Q.Seq s + , _trailCost :: Int , _cost :: Int } deriving (Show, Eq) makeLenses ''Agendum @@ -130,16 +132,13 @@ instance SearchState TiledPosition where let (tileR, gridR) = r `divMod` (maxR + 1) let (tileC, gridC) = c `divMod` (maxC + 1) let gridCost = grid ! (V2 gridR gridC) - let cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1 + let !cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1 return cost tileScale :: BasePosition -> BasePosition tileScale (V2 r c) = V2 (ts r) (ts c) where ts n = (n + 1) * 5 - 1 --- enTilePosition :: Position -> TiledPosition --- enTilePosition (V2 a b) = V2 a b - ------------------------------ main :: IO () @@ -160,20 +159,13 @@ mkCave text = Cave { _grid = grid, _goal = V2 r c } part1 :: Cave -> Int --- part1 :: Maze -> Maybe (Agendum Portal) part1 cave = maybe 0 _cost result where result = runReader searchCave cave :: Maybe (Agendum Position) part2 :: Cave -> Int --- part1 :: Maze -> Maybe (Agendum Portal) part2 cave = maybe 0 _cost result where result = runReader searchCave cave :: Maybe (Agendum TiledPosition) --- part2 :: Maze -> Int --- -- part2 :: Maze -> Maybe (Agendum LevelledSearchState) --- part2 maze = maybe 0 _cost result --- where result = runReader searchMaze maze :: Maybe (Agendum LevelledSearchState) - searchCave :: SearchState s => CaveContext (Maybe (Agendum s)) searchCave = @@ -184,7 +176,7 @@ initAgenda :: SearchState s => CaveContext (Agenda s) initAgenda = do let ss = emptySearchState c <- estimateCost ss - return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _cost = c} + return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _trailCost = 0, _cost = c} aStar :: SearchState s => Agenda s -> ExploredStates s -> CaveContext (Maybe (Agendum s)) @@ -209,21 +201,22 @@ candidates :: SearchState s => Agendum s -> ExploredStates s -> CaveContext (Q. candidates agendum closed = do let candidate = agendum ^. current let previous = agendum ^. trail - -- let prevCost = agendum ^. cost + let prevCost = agendum ^. trailCost succs <- successors candidate let nonloops = Q.filter (\s -> s `S.notMember` closed) succs - mapM (makeAgendum previous) nonloops + mapM (makeAgendum previous prevCost) nonloops + -makeAgendum :: SearchState s => (Q.Seq s) -> s -> CaveContext (Agendum s) -makeAgendum previous newPosition = +makeAgendum :: SearchState s => (Q.Seq s) -> Int -> s -> CaveContext (Agendum s) +makeAgendum previous prevCost newPosition = do predicted <- estimateCost newPosition grid <- asks _grid let newTrail = previous |> newPosition - let _ :< entered = newTrail - -- let incurred = foldr (+) 0 $ mapM entryCost entered - incurredQ <- mapM entryCost newTrail - let incurred = foldr (+) 0 incurredQ + newPositionCost <- entryCost newPosition + let incurred = prevCost + newPositionCost return Agendum { _current = newPosition , _trail = newTrail + , _trailCost = incurred , _cost = incurred + predicted } + \ No newline at end of file diff --git a/advent15/MainSlow.hs b/advent15/MainSlow.hs new file mode 100644 index 0000000..3a77a02 --- /dev/null +++ b/advent15/MainSlow.hs @@ -0,0 +1,231 @@ +-- Writeup at https://work.njae.me.uk/2021/12/13/advent-of-code-2021-day-13/ + + +import Debug.Trace + +-- import qualified Data.Text.IO as TIO + +-- import qualified Data.Map.Strict as M +-- import Data.Map.Strict ((!)) +import qualified Data.PQueue.Prio.Min as P +import qualified Data.Set as S +import qualified Data.Sequence as Q +import Data.Sequence ((<|), (|>), (><)) --, ViewR( (:>) ), ViewL( (:<) )) +import Data.Foldable (foldl', sum) -- (toList, foldr', foldl', all) +import Data.Char +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>), (:>), (:<)) +import Data.Maybe (fromMaybe) +import Linear (V2(..), (^+^), (^-^), (*^), (^*)) +import Data.Array.IArray +-- import Data.List + + +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 BasePosition = V2 Int -- r, c +newtype Position = Position BasePosition -- r, c + deriving (Eq, Ord, Show) +newtype TiledPosition = TiledPosition BasePosition -- r, c + deriving (Eq, Ord, Show) +type Grid = Array BasePosition Int + +data Cave = Cave + { _grid :: Grid + , _goal :: BasePosition + } deriving (Eq, Ord, Show) +makeLenses ''Cave + +type CaveContext = Reader Cave + + +data Agendum s = + Agendum { _current :: s + , _trail :: Q.Seq s + , _cost :: Int + } deriving (Show, Eq) +makeLenses ''Agendum + +type Agenda s = P.MinPQueue Int (Agendum s) + +type ExploredStates s = S.Set s + +class (Eq s, Ord s, Show s) => SearchState s where + unwrapPos :: s -> BasePosition + successors :: s -> CaveContext (Q.Seq s) + estimateCost :: s -> CaveContext Int + emptySearchState :: s + isGoal :: s -> CaveContext Bool + entryCost :: s -> CaveContext Int + + +instance SearchState Position where + + unwrapPos (Position p) = p + + emptySearchState = Position (V2 0 0) + + -- successors :: Position -> CaveContext (Q.Seq Position) + successors here = + do grid <- asks _grid + let neighbours = + filter (inRange (bounds grid)) + [ (unwrapPos here) ^+^ delta + | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1] + ] + let succs = Q.fromList $ map Position neighbours + return succs + + -- estimateCost :: Position -> CaveContext Int + estimateCost here = + do goal <- asks _goal + let (V2 dr dc) = (unwrapPos here) ^-^ goal + return $ (abs dr) + (abs dc) + + -- isGoal :: here -> CaveContext Bool + isGoal here = + do goal <- asks _goal + return $ (unwrapPos here) == goal + + entryCost here = + do grid <- asks _grid + return $ grid ! (unwrapPos here) + +instance SearchState TiledPosition where + + emptySearchState = TiledPosition (V2 0 0) + + unwrapPos (TiledPosition p) = p + + -- successors :: Position -> CaveContext (Q.Seq Position) + successors (TiledPosition here) = + do grid <- asks _grid + let (lowBound, highBound) = bounds grid + let extendedBounds = ( lowBound + , tileScale highBound + ) + let neighbours = + filter (inRange extendedBounds) + [ here ^+^ delta + | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1] + ] + let succs = Q.fromList $ map TiledPosition neighbours + return succs + + -- estimateCost :: Position -> CaveContext Int + estimateCost (TiledPosition here) = + do goal <- asks _goal + let (V2 dr dc) = here ^-^ (tileScale goal) + return $ (abs dr) + (abs dc) + + -- isGoal :: here -> CaveContext Bool + isGoal (TiledPosition here) = + do goal <- asks _goal + return $ here == (tileScale goal) + + entryCost (TiledPosition (V2 r c)) = + do grid <- asks _grid + let (_, V2 maxR maxC) = bounds grid + let (tileR, gridR) = r `divMod` (maxR + 1) + let (tileC, gridC) = c `divMod` (maxC + 1) + let gridCost = grid ! (V2 gridR gridC) + let !cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1 + return cost + +tileScale :: BasePosition -> BasePosition +tileScale (V2 r c) = V2 (ts r) (ts c) + where ts n = (n + 1) * 5 - 1 + +------------------------------ + +main :: IO () +main = + do text <- readFile "data/advent15.txt" + let cave = mkCave text + print $ part1 cave + print $ part2 cave + -- print $ part2 grid + +mkCave :: String -> Cave +mkCave text = Cave { _grid = grid, _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 mkCell $ concat rows + mkCell e = digitToInt e + + +part1 :: Cave -> Int +part1 cave = maybe 0 _cost result + where result = runReader searchCave cave :: Maybe (Agendum Position) + +part2 :: Cave -> Int +part2 cave = maybe 0 _cost result + where result = runReader searchCave cave :: Maybe (Agendum TiledPosition) + + +searchCave :: SearchState s => CaveContext (Maybe (Agendum s)) +searchCave = + do agenda <- initAgenda + aStar agenda S.empty + +initAgenda :: SearchState s => CaveContext (Agenda s) +initAgenda = + do let ss = emptySearchState + c <- estimateCost ss + return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _cost = c} + + +aStar :: SearchState s => Agenda s -> ExploredStates s -> CaveContext (Maybe (Agendum s)) +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 + | 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 :: SearchState s => Agendum s -> ExploredStates s -> CaveContext (Q.Seq (Agendum s)) +candidates agendum closed = + do let candidate = agendum ^. current + let previous = agendum ^. trail + let prevCost = agendum ^. cost + succs <- successors candidate + let nonloops = Q.filter (\s -> s `S.notMember` closed) succs + mapM (makeAgendum previous) nonloops + -- mapM (makeAgendum previous prevCost) nonloops + +makeAgendum :: SearchState s => (Q.Seq s) -> s -> CaveContext (Agendum s) +makeAgendum previous newPosition = + do predicted <- estimateCost newPosition + grid <- asks _grid + let newTrail = previous |> newPosition + incurredQ <- mapM entryCost newTrail + let !incurred = foldr (+) 0 incurredQ + return Agendum { _current = newPosition + , _trail = newTrail + , _cost = incurred + predicted + } +-- makeAgendum :: SearchState s => (Q.Seq s) -> Int -> s -> CaveContext (Agendum s) +-- makeAgendum previous prevCost newPosition = +-- do predicted <- estimateCost newPosition +-- grid <- asks _grid +-- let newTrail = previous |> newPosition +-- newPositionCost <- entryCost newPosition +-- let incurred = prevCost + newPositionCost +-- return Agendum { _current = newPosition +-- , _trail = newTrail +-- , _cost = incurred + predicted +-- } +-- \ No newline at end of file