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.


    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 = (\n -> (n, edge')) nbrs
              neighboursD = (\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:


    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 $ _distance unfoundEdges
           return $ max 0 $ furthest + (S.size unfound) - 1


    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))


    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.


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

    Neil Smith

    Read more posts by this author.