Advent of Code 2021 day 15

    Day 15 was a standard graph search, so I reused some old code from day 20 of the 2019 Advent of Code. There are some advantages to doing lots of these!

    This program uses several "non-beginner" tools in the code which are worth mentioning.

    One is the use of the lens library to tidy up some of the record manipulation steps, such as candidate = agendum ^. current to pull out the current field from the agendum record. It's probably overkill, and I'd probably use Record Wildcards if I were writing this now.

    Another is the use of the Reader monad to tidy up the code. Everything in the program depends on the detail of the grid being explored. That means I need to feed that in at the root of the function call tree, but it's only used in a few functions at the leaves of the call tree. Using the Reader allows me to hide some of the plumbing of many functions receiving a grid parameter only to pass it unchanged to the functions it calls.

    The feature I exploit the most here is type classes. The two parts of today's puzzle differ in how the starting grid and current position are interpreted (with the part 2 grid being several duplicates of the grid in part 1). I could have done that by just building a larger grid and reusing the same code in part 1, or I could use the information in the original to create a "virtual grid" for part 2. Type classes allowed me to do the latter.

    I won't describe the A* search algorithm here, just show how I implemented it.

    I represent the map as an Array of positions, each with an Int cost. There are three flavours of Position used. BasePosition is the position used when reading the input and for locations in the Grid data structures. A Position is the same, but used in part 1. A TiledPosition is a position in the larger, tiled, version of the map. A TiledPosition can be anywhere in the larger, virtual, version of the map. But more on that in a bit. Finally, a Cave is a grid and an explicit goal location and it has a context for the Reader.

    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

    The search is controlled by each current solution candidate being an Agendum, and the whole search controlled by the Agenda, a priority queue of Agendums. I also have a closed set of ExploredStates. Note how these take a type parameter, the type of the current states. In this case, that's either a Position or a TiledPosition.

    data Agendum s = 
        Agendum { _current :: s
                , _trail :: Q.Seq s
                , _trailCost :: Int
                , _cost :: Int
                } deriving (Show, Eq)
    makeLenses ''Agendum                       
    type Agenda s = P.MinPQueue Int (Agendum s)
    type ExploredStates s = S.Set s

    The search algorithm is pretty standard. runReader sets off searchCave in the context of a cave. aStar does the search as described, including checking for reaching the goal, checking for membership of the closed set, and updating the agenda. candidates finds the possible next steps from an Agendum, and makeAgendum converts each candidate into an Agendum.

    part1 :: Cave -> Int
    part1 cave = maybe 0 _cost result
        where result = runReader searchCave cave :: Maybe (Agendum Position)
    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, _trailCost = 0, _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 ^. trailCost
            succs <- successors candidate
            let nonloops = Q.filter (\s -> s `S.notMember` closed) succs
            mapM (makeAgendum previous prevCost) nonloops
    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
                          , _trailCost = incurred
                          , _cost = incurred + predicted

    You'll notice that these functions don't look at any specifics of the grid itself, using functions like successors and entryCost to do that.

    Part 2: Polymorphism

    Those grid-specific details are handled by functions in the SearchState class.

    class (Eq s, Ord s, Show s) => SearchState s where
        unwrapPos :: s -> BasePosition
        emptySearchState :: s
        successors :: s -> CaveContext (Q.Seq s)
        estimateCost :: s -> CaveContext Int
        isGoal :: s -> CaveContext Bool
        entryCost :: s -> CaveContext Int
    instance SearchState Position where
    instance SearchState TiledPosition where

    Each SeachState type, Position and TiledPosition, has its own version of these functions. Haskell uses the concrete type to determine which function to use.

    When I solved part 2, I kept the underlying grid the same, but mapped the position in the tiled version of the map to the correct position in the underlying grid. For instance, the entryCost function returns the cost to enter a position.

    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

    This function works out which tile the position is in, and where in that tile, and uses that to calculate the updated cost.


    The last thing to cover is the profiling. My original version of the code for part 2 took about two minutes to run.

    I profiled the runtime of the program and found that entryCost was taking about 50% of the runtime, with another 40% in makeAgendum. A little bit of thinking showed why. My original version of the Agendum record was this:

    data Agendum s = 
        Agendum { _current :: s
                , _trail :: Q.Seq s
                , _cost :: Int
                } deriving (Show, Eq)

    where _cost is the estimated total cost and the incurred cost was recalculated from the _trail every time a new Agendum was created. That led to a lot of lookups in the grid! A small change to Agendum (to retain the incurred trail cost) and suddenly the runtime dropped from two minutes to under five seconds.

    You can see the original version as advent15/src/MainSlow.hs.


    You can get the code from my locally-hosed Git repo, or from Gitlab.

    Neil Smith

    Read more posts by this author.