3 January 2020 ; tagged in: advent of code , haskell

Advent of Code 2019 day 18

Preprocessing and branching factors.

Advent of Code 2019 day 18

Day 18 was a complicated beast, made a bit more complicated than it need be by the incursion of Christmas celebrations in the time it took me to complete it!

It's also a complicated task, with lots of thinking involved in solving it, so this post is longer than most.

Data structures, 1

The first decision was how to represent the cave. I started by taking a direct approach: the cave was a Set of Positions; the locations of keys and doors were represented as a Map from the position to the label of the key or door; and I used a CaveComplex record to contain the layout of the cave and the positions of the keys and doors.

type Position = (Integer, Integer) -- r, c

type PointOfInterest = M.Map Position Char

type Cave = S.Set Position
data CaveComplex = CaveComplex { _cave :: Cave
                               , _keys :: PointOfInterest
                               , _doors :: PointOfInterest
                               } deriving (Eq, Ord, Show)
type CaveContext = Reader CaveComplex

Building the cave complex was relatively straightforward. Starting with an empty CaveComplex, I fold over each row in the text file, updating the CaveComplex as I go. Similarly, each row is processed as a fold over the characters in the row.

buildCaveCell has the logic of how to interpret each character in the map, making sure to include doors, keys, and the explorer as possible spaces in the cave.

buildCaveComplex text = foldl' buildCaveRow (cc0, explorer0) $ zip [0..] rows
    where cc0 = CaveComplex {_cave = S.empty, _keys = M.empty, _doors = M.empty}
          explorer0 = emptyExplorer -- Explorer { _position = (0, 0), _keysHeld = S.empty }
          rows = lines text

buildCaveRow (cc, explorer) (r, row) = foldl' (buildCaveCell r) (cc, explorer) $ zip [0..] row

buildCaveCell r (cc, explorer) (c, char) 
    | char == '.' = (cc', explorer)
    | char == '@' = (cc', explorer { _position1 = here })
    | isLower char  = (cc' { _keys = M.insert here char $ _keys cc'}, explorer)
    | isUpper char  = (cc' { _doors = M.insert here char $ _doors cc'}, explorer)
    | otherwise = (cc, explorer)
    where cc' = cc { _cave = S.insert here $ _cave cc }
          here = (r, c)

Part 1

I started by using a standard A* search to find the solution. To simplify the code, I used a Reader monad to contain the state of the cave complex, to avoid passing it around as a parameter throughout the various parts of the code. (Things changed a lot for part 2, so here is the code for part 1.)

The search revolves around an agenda of partial results to search from. Each partial result contains the position of the explorer and the keys its picked up so far. The agenda is stored as a priority queue, ordered so that the smallest predicted cost of completing the task is the first agendum in the queue.

Here's the core of the search algorithm. The closed set contains explorer states that have already been processed: if the search visits these states again, they're not added to the agenda.

aStar :: Agenda -> ExploredStates -> CaveContext (Maybe Agendum)
aStar agenda closed 
    | P.null agenda = return Nothing
    | otherwise = 
        do  let (_, currentAgendum) = P.findMin agenda
            let reached = _current currentAgendum
            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)

These are the extra data structures it needs.

data Explorer = Explorer { _position :: Position
                         , _keysHeld :: Keys
                         } deriving (Eq, Ord, Show)
type ExploredStates = S.Set Explorer

data Agendum = Agendum { _current :: Explorer
                       , _trail :: Q.Seq Explorer
                       , _cost :: Int} deriving (Show, Eq)
type Agenda = P.MinPQueue Int Agendum 

The candidates are the new explorer states to consider. The nonloops check is mainly to prevent the search stepping back to where it just came from, but it can catch other duplicate candidates too. Note that the important check of the closed set occurs in the main aStar function. successors is the main domain-dependent function here. It finds the cave locations adjacent to the current position, checks that the explorer has the right key for any doors, and picks up any keys at the current location.

candidates :: Agendum -> ExploredStates -> CaveContext (Q.Seq Agendum)
candidates agendum closed = 
    do  let candidate = _current agendum
        let previous = _trail agendum
        succs <- successors candidate
        let nonloops = Q.filter (\s -> not $ s `S.member` closed) succs
        mapM (makeAgendum candidate previous) nonloops

makeAgendum :: Explorer -> (Q.Seq Explorer) -> Explorer -> CaveContext Agendum
makeAgendum candidate previous new = 
    do cost <- estimateCost new
       return Agendum { _current = new
                      , _trail = candidate <| previous
                      , _cost = cost + (Q.length previous)
                      }

successors :: Explorer -> CaveContext (Q.Seq Explorer)
successors explorer = 
    do  let here = _position explorer
        let locations0 = possibleNeighbours here
        cave <- asks _cave
        keys <- asks _keys
        doors <- asks _doors
        let keysHeld = _keysHeld explorer
        let locations1 = Q.filter (`S.member` cave) locations0
        let locations2 = Q.filter (hasKeyFor doors keysHeld) locations1
        return $ fmap (\l -> explorer { _position = l, _keysHeld = pickupKey keys keysHeld l}) locations2

possibleNeighbours :: Position -> Q.Seq Position
possibleNeighbours (r, c) = [(r + 1, c), (r - 1, c), (r, c + 1), (r, c - 1)]

Finally, the search is guided by the estimatedCost heuristic. This provides an estimate of the remaining work to be done in finding a solution. In order to ensure the algorithm is optimal, the heuristic has be to admissible: it cannot result in an overestimate of the amount of work remaining.

My first attempt at a heuristic was to sum the manhattan distances to all remaining keys. However, this wasn't admissible as it would often overestimate the work needed. If there were two keys along the same tunnel in the maze, the work to pick up both keys would be the same as the work to pick up just the furthest one (the explorer would pick up the nearest one on the way). This wrong heuristic led to some wrong answers for the sample problems!

A better heuristic was to find the maximum and minimum values for the row and column of the unfound keys, and then estimate the distance from the explorer to these rows and columns.

estimateCost :: Explorer -> CaveContext Int
estimateCost explorer = -- return 0
    do keys <- asks _keys
       let (r, c) = _position explorer
       let unfoundKeys = M.filter (`S.notMember` (_keysHeld explorer)) keys
       let minR = minimum $ map fst $ M.keys unfoundKeys
       let minC = minimum $ map snd $ M.keys unfoundKeys
       let maxR = maximum $ map fst $ M.keys unfoundKeys
       let maxC = maximum $ map snd $ M.keys unfoundKeys
       let spanR = spanV r minR maxR
       let spanC = spanV c minC maxC
       if M.null unfoundKeys
       then return 0
       else return $ fromIntegral (spanR + spanC)

spanV this minV maxV 
    | this < minV = maxV - this
    | this > maxV = this - minV
    | otherwise = (this - minV) + (maxV - this) 

This all worked fine, and got the right solution. But it managed to do it rather slowly.

Thinking about Part 2

Unfortunately, this direct approach didn't work for part 2, where there are four explorers moving around the cavern. The key reason for this lies in something termed the branching factor of the search.

Each state on the path to the solution is determined by the positions of each of the four explorers, and the set of all the keys collected between them. The solution to part 2 requires just over 2000 steps. For each of those steps, the search algorithm has to consider up to three successor positions, and do so for each of the four explorers. That means that each state in the search tree can have up to twelve successors that need exploring. The number of successors of each state is termed the branching factor.

Let's say that the average number of successor nodes for each explorer is n, and that there are d steps in the solution. That means there are 4n successors of the first state, 4n × 4n successors after two steps, 4n× 4n × 4n successors after three states, and eventually (4n)d = 4d×nd states after all d steps have been explored.

Most of the time, there's only one successor for each explorer, as the explorer is moving down a corridor. That means that n is small, say about 1.1 or 1.2. But even so, the fact that there are four explorers makes the size of the search space explode.

The cause of the problem is that we need to track the separate movement of each explorer, even if they're essentially independent. Consider the simple example cavern below, with two explorers. We don't really care which explorer moves first or second, so long as the leftmost explorer ends up one the a key, opening the door for the rightmost explorer.

#######################
#.B.a...@..#..@...A.b.#
#######################

There are a couple of ways of solving this problem. One is to drop the constraint on looking at all orderings of explorer movement. The other is somehow to shorten the path length.

Dropping the constraint on ordering is commonly seen in partial-order planning systems. The idea is to record both the steps taken by each explorer, and the constraints between which steps can be taken when. In this case, that's the constraints on when keys have been collected, allowing doors to be opened. That would allow me to construct the plan for each explorer separately, and then combine those separate plans into one plan overall. For this problem, there are no real interactions between the different explorers (the different explorers are held separate from each other) and the total length of the path is just the sum of the lengths of the separate plans for each explorer.

But I wanted a solution that was more generally true. The partial-order search idea would require a lot of work to sort out the general case of how to constrain the interleaving of the steps in the separate plans. It could also be the case that one explorer needs to take the long way round to get a key early, allowing other explorer to follow much shorter routes, meaning that combining the sub-plans would need to take account of these possible interactions. That left the other choice, that of shortening the path length of the solution.

The important part of the "length" is the number of choices made by the search algorithm, not the number of steps taken by the explorer. Most of the time, the explorer is constrained to move along a corridor. I can contract the map of the cavern into a graph that is just the keys and how they are connected. This will reduce the map from being one that contains over 3000 possible steps to one that contains just 75 connections.

Contracting the map

First, I need to define some data structures to hold the contracted cavern. A CaveEdge holds everything important to remember about moving around the cavern: the keys connected by this edge, the keys required to move along this edge, and the distance travelled by the robot.

type Connection = (Char, Char)
data CaveEdge = CaveEdge { _connections :: Connection
                         , _keysRequired :: S.Set Char
                         , _distance :: Int
                         } deriving (Eq, Ord, Show)
makeLenses ''CaveEdge   

type Cave = S.Set CaveEdge

I also renamed the CaveComplex to ExpandedCaveComplex; a CaveComplex is now the container for the contracted version.

Contracting the cave is a breadth-first search from each key (and robot starting position) outwards. contractCave creates the whole graph with a fold. contractFrom finds all the edges that start at a particular key (or starting position). reachableFrom does the breadth-first search, using a boundary list of positions to explore.

The four alternative clauses in reachableFrom handle the four cases.

  1. If the current position has already been processed (and is in the closed set), drop the position and carry on.
  2. If the current position is a key, record the new edge in the cave and continue searching the rest of the boundary.
  3. If the current position is a door, record that this key is needed for wherever this edge ends up, then continue as case 4.
  4. Otherwise, find the neighbours of the position, add them to the boundary, and move on.
contractCave :: ExpandedCaveComplex -> [Position] -> CaveComplex
contractCave expanded startPositions = cavern
    where explorers = M.fromList $ zip startPositions $ map intToDigit [0..]
          starts = M.union explorers (expanded ^. keysE)
          cavern0 = CaveComplex {_cave = S.empty, _keys = S.fromList $ M.elems (expanded ^. keysE)}
          cavern = M.foldrWithKey (contractFrom expanded) cavern0 starts

contractFrom :: ExpandedCaveComplex -> Position -> Char -> CaveComplex -> CaveComplex
contractFrom expanded startPos startKey cc = cc { _cave = S.union (_cave cc) reachables }
    where reachables = reachableFrom [(startPos, edge0)] S.empty expanded' startKey
          edge0 = CaveEdge {_connections = ('0', '0'), _keysRequired = S.empty, _distance = 0}
          expanded' = expanded & keysE %~ (M.delete startPos)

reachableFrom :: [(Position, CaveEdge)] -> (S.Set Position) -> ExpandedCaveComplex -> Char -> Cave
reachableFrom [] _closed _expanded _startKey = S.empty
reachableFrom ((here, edge):boundary) closed expanded startKey
    | here `S.member` closed = reachableFrom boundary closed expanded startKey
    | here `M.member` ks = S.insert edgeK $ reachableFrom boundary closed' expanded startKey
    | here `M.member` drs = reachableFrom boundaryD closed' expanded startKey
    | otherwise = reachableFrom boundary' closed' expanded startKey
    where nbrs0 = S.intersection (expanded ^. caveE) $ possibleNeighbours here
          nbrs = S.difference nbrs0 closed
          closed' = S.insert here closed
          ks = expanded ^. keysE
          drs = expanded ^. doors
          edge' = edge & distance %~ (+1)
          edgeK = edge & connections .~ (mkConnection startKey (ks!here))
          edgeD = edge' & keysRequired %~ (S.insert (toLower (drs!here)))
          neighbours = S.map (\n -> (n, edge')) nbrs
          neighboursD = S.map (\n -> (n, edgeD)) nbrs
          boundary' = boundary ++ (S.toAscList neighbours)
          boundaryD = boundary ++ (S.toAscList neighboursD)

This uses a couple of utility functions for handling when edges touch each other.

mkConnection :: Char -> Char -> Connection
mkConnection a b = if a < b then (a, b) else (b, a)

edgeTouches :: Char -> CaveEdge -> Bool
edgeTouches x e
    | x == a = True
    | x == b = True
    | otherwise = False
    where (a, b) = e ^. connections

anyEdgeTouch :: Keys -> CaveEdge -> Bool
anyEdgeTouch xs e = S.foldl' (\t x -> t || (edgeTouches x e)) False xs

edgeOther :: Char -> CaveEdge -> Char
edgeOther x e 
    | x == a = b
    | otherwise = a
    where (a, b) = e ^. connections

Contraction results in much smaller representations of the cave. This example cave:

#############
#g#f.D#..h#l#
#F###e#E###.#
#dCba@#@BcIJ#
#############
#nK.L@#@G...#
#M###N#H###.#
#o#m..#i#jk.#
#############

becomes this graph of keys. Each node is a point of interest (a key or a starting position, represented by numbers). The label of each edge is the keys required to move along the edge, and the distance travelled.

Connections in the example cave

The contraction of the full problem is much more dramatic, with journeys of over 200 steps being compressed to a single edge in the graph.

Connections in the problem cave.

Solving part 2

Now I have a simpler representation of the problem, solving it becomes practical. The definition of Explorer has to change, as I need to track a Set of robots rather than just one. It also tracks the total distance travelled by all robots, rather than recalculating it from the set of edges used.

data Explorer = Explorer { _position :: S.Set Char
                         , _keysHeld :: Keys
                         , _travelled :: Int
                         } deriving (Show)
makeLenses ''Explorer

instance Eq Explorer where
    e1 == e2 = (_position e1 == _position e2) && (_keysHeld e1 == _keysHeld e2)

instance Ord Explorer where
    e1 `compare` e2 =
        if _position e1 == _position e2
        then (_keysHeld e1) `compare` (_keysHeld e2)
        else (_position e1) `compare` (_position e2)

After a digression into typeclasses, I adjusted the code for part 1 to use the same Explorer data structure, just using a Set of one robot rather than a Set of four.

Much of the A* search algorithm is the same. The successors function changes to deal with the new CaveComplex data structure

successors :: Explorer -> CaveContext (Q.Seq Explorer)
successors explorer = 
    do let heres = explorer ^. position
       cavern <- asks _cave
       let kH = explorer ^. keysHeld
       let locations0 = S.filter (\e -> anyEdgeTouch heres e) cavern
       let locations1 = S.filter (\e -> S.null ((e ^. keysRequired) `S.difference` kH)) locations0
       let succs = S.foldr' (\e q -> (extendExplorer explorer e) <| q) Q.empty locations1
       return succs

extendExplorer :: Explorer -> CaveEdge -> Explorer
extendExplorer explorer edge = 
    explorer & position .~ pos'
             & keysHeld .~ kH'
             & travelled .~ d'
    where here = S.findMin $ S.filter (\p -> edgeTouches p edge) (explorer ^. position)
          there = edgeOther here edge
          kH' = S.insert there (explorer ^. keysHeld)
          d' = (explorer ^. travelled) + (edge ^. distance)
          pos' = S.insert there $ S.delete here (explorer ^. position)

The cost estimation function also changes. I now use the furthest distance of any unfound key from any explorer robot, plus 1 for each other unfound key.

estimateCost :: Explorer -> CaveContext Int
estimateCost explorer = -- return 0
    do let heres = explorer ^. position
       ks <- asks _keys
       cavern <- asks _cave
       let kH = explorer ^. keysHeld
       let unfound = ks `S.difference` kH
       let unfoundEdges0 = S.filter (\e -> anyEdgeTouch heres e) cavern
       let unfoundEdges = S.filter (\e -> not $ anyEdgeTouch kH e) unfoundEdges0
       let furthest = S.findMax $ S.insert 0 $ S.map _distance unfoundEdges
       return $ max 0 $ furthest + (S.size unfound) - 1

Performance

Unfortunately, this still takes quite a while to run. Profiling it suggests that about 50% of the time is spent in the compare function for Explorer and about 10% is in anyEdgeTouch.

The Ord instance for Explorer started looking like this:

instance Ord Explorer where
    e1 `compare` e2 =
        if _position e1 == _position e2
        then (_keysHeld e1) `compare` (_keysHeld e2)
        else (_position e1) `compare` (_position e2)

I tried a couple of variations on this, and it make little difference. The only thing I discovered is that things go wrong if the Ord instance and Eq instance give different answers for when Explorers are equal!

But I did pick up one neat trick, using the fact that Ord is and instance of Monoid, so the instance can be more succinctly expressed like this.

instance Ord Explorer where
    e1 `compare` e2 = 
           ((_position e1) `compare` (_position e2)) 
        <> ((_keysHeld e1) `compare` (_keysHeld e2))

Lenses

I used lenses a bit more in this program, after my first forays. I think they're a bit neater, and perhaps clearer once you've got your eye in. Compare this update (with lenses)

(cc' & keysE %~ (M.insert here char), startPosition)

with this one (without lenses)

(cc' { _keysE = M.insert here char $ _keysE cc'}, startPosition)

Similarly, the use of a function in the over lens action makes the "increment" action clearer in this case.

edge' = edge & distance %~ (+1)

As before, I'm not using deeply nested structures, so the difference between using lenses and not isn't as large as it could be.

Code

You can see the code as at the end of part 1, and the final code (and final code on Github).