Discussion on: Advent of Code 2019 Solution Megathread - Day 14: Space Stoichiometry

[Neil Gall]

Ok it's the weekend so I had some fun in Haskell. The input data has a more complex structure today so I whipped out my trusty parser combinator toolkit. But I've got this far with very few external libraries so let's write our own!

data ParseResult input value
  = Ok value input
  | Err String input
  deriving (Eq, Show)

instance Functor (ParseResult input) where
  fmap f (Ok value rest) = Ok (f value) rest
  fmap f (Err expected actual) = Err expected actual

newtype Parser input value = Parser (input -> ParseResult input value)

instance Functor (Parser input) where
  fmap f (Parser p) = Parser (\input -> fmap f (p input))

instance Applicative (Parser input) where
  pure x = Parser (\input -> Ok x input)
  (Parser p) <*> (Parser q) = Parser $ \input ->
    case p input of
      Ok r rest -> fmap r (q rest)
      Err e a -> Err e a

parse :: Parser input value -> input -> ParseResult input value
parse (Parser p) input = p input

parseWith :: (Char -> Bool) -> (String -> a) -> String -> Parser String a
parseWith match convert expected = Parser $ \input ->
  let
    matching = takeWhile match input
    rest = dropWhile match input
  in
    if null matching 
      then Err expected input
      else Ok (convert matching) rest

literal :: String -> Parser String ()
literal s = Parser $ \input -> 
  case stripPrefix s input of
    Nothing -> Err ("'" ++ s ++ "'") input
    (Just rest) -> Ok () rest

integer :: Parser String Int
integer = parseWith isDigit read "an integer"

chemical :: Parser String String
chemical = parseWith isAsciiUpper id "a chemical symbol"

whitespace :: Parser String ()
whitespace = Parser $ \input -> Ok () (dropWhile isSpace input)

before :: Parser i x -> Parser i a -> Parser i a
x `before` p = fmap snd $ pure (,) <*> x <*> p

followedBy :: Parser i a -> Parser i x -> Parser i a
p `followedBy` x = fmap fst $ pure (,) <*> p <*> x

sepBy :: Parser i a -> Parser i s -> Parser i [a]
sepBy (Parser p) (Parser q) = Parser sepBy'
  where
    sepBy' input = case p input of
      Err _ _ -> Ok [] input
      Ok v rest -> case q rest of
        Err _ _ -> Ok [v] rest
        Ok _ rest' -> fmap (\vs -> v:vs) (sepBy' rest')

That was fun, and lets me write really simple code for parsing the input data:

type Name = String

data Material = Material Int Name

data Reaction = Reaction [Material] Material

material :: Parser String Material
material = Material <$> (integer `followedBy` whitespace) <*> chemical

reaction :: Parser String Reaction
reaction = Reaction <$> inputs <*> output
  where
    inputs = material `sepBy` literal ", "
    output = literal " => " `before` material

reactions :: Parser String [Reaction]
reactions = reaction `sepBy` whitespace

Ok on to the problem. We've had topological sort problems before in AoC so I recognised the general form of the problem pretty quickly. If you sort the chemicals by dependency then you can walk that list in order knowing when you reach a chemical you've already dealt with everything that has a demand on it.

data Edge = Edge Name Name

findEdges :: [Reaction] -> [Edge]
findEdges [] = []
findEdges ((Reaction inputs output):rs) = (map toEdge inputs) ++ (findEdges rs)
  where
    edgeOutput = (\(Material _ o) -> o) output
    toEdge (Material _ i) = Edge i edgeOutput


topoSort :: [Reaction] -> [Name]
topoSort rs = reverse $ topoSort' (findEdges rs) ["FUEL"] []
  where
    input (Edge i _) = i
    output (Edge _ o) = o
    from x e = input e == x
    to x e = output e == x
    noneFrom es e = not (any (from (input e)) es)

    topoSort' :: [Edge] -> [Name] -> [Name] -> [Name]
    topoSort' _ [] result = result
    topoSort' edges (here:stack) result =
      let
        (incoming, edges') = partition (to here) edges
        next = map input $ filter (noneFrom edges') incoming
        stack' = stack ++ next
      in
        topoSort' edges' stack' (here:result)

The next bit was tricky. First I reorganised the reaction data into a map from chemical name to its requirements and quantity produced:

requirements :: [Reaction] -> M.Map Name (Int, [Material])
requirements [] = M.empty
requirements ((Reaction inputs (Material quantity name)):rs) = 
  M.insert name (quantity, inputs) (requirements rs)

Then the quantity needed is found by walking the topologically sorted list of chemicals and building a map of the amount of each needed. For each chemical look up the inputs and add the appropriately scaled amount to each input's requirements.

quantitiesNeeded :: [Reaction] -> Int -> M.Map String Int
quantitiesNeeded rs fuel = foldl quantityNeeded (M.fromList [("FUEL", fuel)]) (topoSort rs)
  where
    add q Nothing = Just q
    add q (Just q') = Just (q' + q)
    reqs = requirements rs

    quantityNeeded :: M.Map String Int -> String -> M.Map String Int
    quantityNeeded neededByName name =
      case M.lookup name reqs of
        Nothing -> neededByName
        Just (makesQuantity, inputs) -> foldl addNeeded neededByName' inputs
          where
            Just needQuantity = M.lookup name neededByName
            scale = (needQuantity `div` makesQuantity) + (if needQuantity `mod` makesQuantity > 0 then 1 else 0)
            neededByName' = M.alter (add needQuantity) name neededByName
            addNeeded n (Material q m) = M.alter (add (scale * q)) m n

The final answer is waiting the in the map at the end

oreNeededForFuel :: [Reaction] -> Int -> Int
oreNeededForFuel rs fuel = fromMaybe 0 $ M.lookup "ORE" $ quantitiesNeeded rs fuel

At first I thought part 2 was going to reverse the search order so we started from ORE but I quickly realised the search space explodes once you can use an input for multiple outputs. It turned out much simpler - starting with an estimate of the quantity of ORE divided by the ORE needed for 1 FUEL, it's just a binary search to find the maximum amount of FUEL we can make.

maxFuelProduced :: [Reaction] -> Int -> Int
maxFuelProduced reactions quantityOfOre = binarySearch estimateLow estimateHigh
  where
    estimateLow = quantityOfOre `div` (oreNeededForFuel reactions 1)
    estimateHigh = estimateLow * 2
    binarySearch min max = if min == max || min + 1 == max then min
      else let 
        mid = (min + max) `div` 2
      in
        if oreNeededForFuel reactions mid > quantityOfOre
          then binarySearch min mid
          else binarySearch mid max

Full source with unit tests.