Day 12 had some fiddly bits, so things ended up fairly complex. In essence, the problem is an exhaustive search for paths on a graph, but the rules on revisiting nodes makes for complex code. In addition, the extension task for part 2 was such that it ended up easier to solve part 2 first, then extract just the solutions that were valid for part 1.

As with all search-type tasks, I find it easier to think about the problem as having an agenda of partial paths, with the agenda being updated as the search progresses.

In this case, an agendum was represented as a Path containing the current cave, the history of all caves visited, the closed set of small caves visited, and an optional record of a small cave that was visited twice.

data Path = Path String         -- current cave
                 [String]       -- caves visited
                 (S.Set String) -- closed set of small caves visited
                 (Maybe String) -- the small cave we've visited twice
  deriving (Eq, Ord, Show)

The allPaths function finds all the paths in the cave complex. It takes as input the graph (the cave complex), a Set of partial Paths, and a Set of the completed routes found so far. It extracts an arbitrary element of the agenda, extends it if possible, then adds the extended paths back into the agenda. If the path ends at the end cave, the path is added to the set of results.

allPaths :: Graph -> PathSet -> PathSet -> PathSet
allPaths graph agenda results
  | S.null agenda = results
  | otherwise = allPaths graph agenda'' results'
  where (current, agenda') = S.deleteFindMin agenda
        newPaths = extendPath graph current
        agenda'' = S.union agenda' newPaths
        results' = S.union results $ recordResult current

recordResult :: Path -> PathSet
recordResult path@(Path current _ _ _)
  | current == "end" = S.singleton path
  | otherwise = S.empty

All the tricky details are handled in extendPath. It's given a Path and returns a Set of new Paths that lead on from it. There are a lot of things to check, so the logic here needs some explanation.

1. If the path gets as far as "end", there are no extensions.
2. If the path has returned to "start" (the current cave is "start" and "start" is in the visited set), there are no extensions.
3. Othewise, there are extensions.

There are two types of extension:

1. Visting a cave not in the visited closed set
2. Visiting a cave in the visited set, but we've not revisited a small cave yet.

To handle the first case, I find all the neighbours of the current cave, remove all the ones in visited, and create a new Path for each.

To handle the second case, I check that we've not already used our "return to a small cave" exemption (returned == Nothing), then extend the path for every reachable small cave we've already visited.

In both cases, I update visited if I'm currently in a small cave.

It's a fiddly mess.

extendPath :: Graph -> Path -> PathSet
extendPath graph (Path current trail visited returned) 
  | current == "end" = S.empty
  | (current == "start") && (current `S.member` visited) = S.empty
  | otherwise = S.union (S.map newPathNovel visitableNovel) 
                        (S.map newPathReturning visitableReturning)
  where neighbours = graph ! current
        visited' = if isSmall current then S.insert current visited else visited
        trail' = (current:trail)
        visitableNovel = neighbours \\ visited -- if we're not returning to a small cave
        visitableReturning = if returned == Nothing 
          then (S.filter isSmall neighbours) `S.intersection` visited -- returning to a small cave already visited
          else S.empty
        newPathNovel next = Path next trail' visited' returned
        newPathReturning next = Path next trail' visited' (Just next)

That's the solution to part 2. The solution to part 1 is the same, only without the paths that take advantage of the "revisit a small cave" allowance.

main :: IO ()
main = 
  do  text <- TIO.readFile "data/advent12.txt"
      let edges = successfulParse text
      let graph = mkGraph edges
      let paths = allPaths graph (S.singleton (Path "start" [] S.empty Nothing)) S.empty
      print $ part1 paths
      print $ part2 paths

mkGraph :: [(String, String)] -> Graph
mkGraph edges = foldr mkEdge pass1 $ map swap edges
  where pass1 = foldr mkEdge M.empty edges
        mkEdge (here, there) = M.insertWith (S.union) here (S.singleton there)

part1 :: PathSet -> Int
part1 paths = S.size $ S.filter nonReturning paths

part2 :: PathSet -> Int
part2 paths = S.size paths


nonReturning :: Path -> Bool
nonReturning (Path _ _ _ Nothing) = True
nonReturning (Path _ _ _ (Just _)) = False

Code

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