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.
Part 1: A* Search
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.
Profiling
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.
Code
You can get the code from my locally-hosed Git repo, or from Gitlab.