Advent of Code 2020 day 7

Day 7 was unusual in that I found part 1 harder than part 2. Also, the data structures in today's solution are a mess. (But see the addendum below.)

Fundamentally, today was about walking across a directed acyclic graph. (At least, I assumed the input was acyclic: I didn't check, and things could have gone very wrong if there were cycles.)

Parsing

This was another outing for Attoparsec, with nothing particularly special. The end result is a Map of bag names to the set of bags it contains. (There are also a couple of declarations needed for part 1.)

data QuantifiedBag = QuantifiedBag Integer String
    deriving (Show, Eq, Ord)

qName (QuantifiedBag _ n) = n
qCount (QuantifiedBag n _) = n

type Bags = S.Set String
type QBags = S.Set QuantifiedBag
type BagRules = M.Map String QBags
type InvertBags = M.Map String Bags

A bag name is a bunch of characters, up to but not including " bag" or " bags". The contents of a bag are either empty or a list of bags separated by commas.

bagNameP = manyTill anyChar ((string " bags") <|> (string " bag"))

quantifiedBagP = QuantifiedBag <$> decimal <* space <*> bagNameP

emptyBagListP = "no other bags" *> pure S.empty

bagListP = S.fromList <$> sepBy quantifiedBagP (string ", ")

bagContentsP = emptyBagListP <|> bagListP

ruleP = (,) <$> bagNameP <* " contain " <*> bagContentsP <* "."

rulesP = M.fromList <$> sepBy ruleP endOfLine

A couple of things to note:

the the use of pure to return a particular value when there's an empty bag list
the inclusion of full stops at the end of each line means the parser can treat each line individually (rather than wondering if there's an extra 's' after finding 'bag')

Part 1

Given a graph of bags of the form "this bag contains that bag", I had to find all the "this bags" for a given "that bag", and the transitive closure of that relation. Given I'm storing the rules in a Map, that involves finding the keys for a particular value. Rather than searching through the whole Map every time, I decided to pre-process the rules and invert them. That would give me a Map with rules of the form "this bag is contained in that bag". From there, finding all the containing bags would be fairly easy.

Because one bag could be contained in many others, I had to break apart the rules into their atomic 1:1 connections, invert them, and use that to rebuild the inverted bag Map.

invertBags :: BagRules -> InvertBags
invertBags bags = foldr addInvert M.empty $ concatMap swapPair $ M.assocs bags 
    where swapPair (a, bs) = [(qName b, a) | b <- S.toList bs]

addInvert :: (String, String) -> InvertBags -> InvertBags
addInvert (k, v) m = M.insert k v' m
    where v' = S.insert v (M.findWithDefault S.empty k m)

From there, it's an exhaustive search across that graph, in something like a breadth-first manner. The agenda is the bags to find containers for, the results are the bags found already. At each step, remove a bag from the agenda, add it to the results. If it's not already in the results, look up the containing bags and add them to the agenda.

part1 bags = S.size $ S.delete "shiny gold" containers
    where containers = bagsContaining (invertBags bags) 
                         (S.singleton "shiny gold") S.empty

bagsContaining :: InvertBags -> Bags -> Bags -> Bags
bagsContaining iBags agenda result 
    | S.null agenda = result
    | otherwise = bagsContaining iBags agenda'' (S.insert thisColour result)
    where thisColour = S.findMin agenda
          agenda' = S.delete thisColour agenda
          agenda'' = if thisColour `S.member` result
                     then agenda'
                     else S.union (M.findWithDefault S.empty thisColour iBags) agenda'

Part 2

After the headaches of part 1, part 2 was positively straightforward! A brute-force recursive solution was more than adequate. The number of bags contained in a bag is 1 + the number of bags contained in all its contents.

nContainedBags :: BagRules -> String -> Integer
nContainedBags bags thisBag = 1 + (sum $ map subCount others)
    where others = S.toList $ bags!thisBag
          subCount b = (qCount b) * (nContainedBags bags (qName b))

Addendum: using a graph library

The structure of bag containments is a graph, so it would make sense to take advantage of an existing library for handling graphs.

Hackage includes several graph libraries, such containers, fgl, graphs, graph-wrapper, and graphite. Most of them, such as the graphs in containers, are restricted in the data they can store in the graph, often labelling vertexes as Int and having edges without weights. Graphite, however, does allow arbitrary values for vertexes and labelled edges. It also has some very good, comprehensive documentation.

The library doesn't do much reexporting, so there are more imports that you'd think.

A BagGraph has vertexes of type String (the bag name) and arcs annotated with type Int (the number of bags).

To build a graph from the rules, I add all the arcs for each rule in turn; to add the arcs from a rule, I add the arcs for each contained bag in turn; to add an arc, I just insertArc it. The vertexes are automatically created in the graph as needed.

import qualified Data.Graph.DGraph as D
import qualified Data.Graph.Types as G
import qualified Data.Graph.Traversal as T

type BagGraph = D.DGraph String Int

buildGraph :: BagRules -> BagGraph
buildGraph rules = M.foldrWithKey addRule G.empty rules

addRule :: String -> QBags -> BagGraph -> BagGraph
addRule source dests graph = S.foldr (addArc source) graph dests

addArc :: String -> QuantifiedBag -> BagGraph -> BagGraph
addArc source (QuantifiedBag quantity destination) graph = D.insertArc arc graph
  where arc = G.Arc source destination quantity

Part 1 is now just a case of transposing the graph (reversing the direction of each arc) and finding the number of vertexes from the god bag. Part 2 is an exhaustive graph search, where the results of a sub-search are multiplied by the edge weight.

part1 graph = length (T.bfsVertices (D.transpose graph) "shiny gold") - 1

part2 graph = (bfsCount graph "shiny gold") - 1

bfsCount :: BagGraph -> String -> Int
bfsCount graph thisBag = 1 + (sum $ map subCount others)
    where others = D.outboundingArcs graph thisBag
          subCount a = (G.attribute a) * (bfsCount graph $ G.destinationVertex a)

Code

You can find the code here or on Gitlab.