Day 19: Graph Deja Vu
A problem so nice they did it twice. And by "nice" I mean quite difficult. This problem was very similar in some respects to Day 16. It's a graph problem where we're trying to collect a series of rewards in a limited amount of time. However, we have to use different tricks to explore the search space efficiently.
Subscribe to Monday Morning Haskell!
Problem Overview
We're trying to mine geodes. To build geode mining robots, we need ore and obsidian. To mine obsidian, we need to make different robots out of ore and clay. And to mine clay, we need robots made out of ore. Luckily, we start with one ore-mining robot, and can make more of these if we choose. It's all a matter of balancing our resources.
We have a number of different blueprints with which we can configure our robot factory. These blueprints tell us how many resources are required to make each robot. The factory can produce one robot every minute if we have the proper materials. Each robot mines one of its mineral per minute. In part 1, we want to mine as many geodes as we can in 24 minutes with each blueprint. In part 2, we'll only consider 3 blueprints, but try to mine for 32 minutes.
Solution Approach and Insights
As with Day 16, we can model this as a graph problem, but the search space is very large. So we'll need some way to prune that space. First, we'll exclude any scenario where we make so many robots of one type that we produce more resources that we could use in a turn. We can only produce one robot each turn anyway, so there's no point in, for example, having more clay robots than it takes clay to produce an obsidian robot. Second, we'll exclude states we've seen before. Third, we'll track the maximum number of geodes we've gotten as a result so far, and exclude any state that cannot reach that number.
This final criterion forces us to use a depth-first search, rather than a breadth-first search or Dijkstra's algorithm. Both of these latter algorithms will need to explore virtually the whole search space before coming up with a single solution. However, with DFS, we can get early solutions and use those to prune later searches.
Parsing the Input
We receive input where each line is a full blueprint, specifying how much ore is required to build another ore robot, how much is needed for a clay robot, and so on:
Blueprint 1: Each ore robot costs 4 ore. Each clay robot costs 2 ore. Each obsidian robot costs 3 ore and 14 clay. Each geode robot costs 2 ore and 7 obsidian.
Blueprint 2: Each ore robot costs 2 ore. Each clay robot costs 3 ore. Each obsidian robot costs 3 ore and 8 clay. Each geode robot costs 3 ore and 12 obsidian.Let's start with a data type for a blueprint. It needs an ID number (we'll multiply the final answer by this in Part 1), as well as the costs for each robot. Obsidian robots require ore and clay, and then geode robots require ore and obsidian.
type InputType = [LineType]
type LineType = BluePrint
data BluePrint = BluePrint
{ idNumber :: Int
, oreRobotCost :: Int
, clayRobotCost :: Int
, obsidianRobotCost :: (Int, Int)
, geodeRobotCost :: (Int, Int)
} deriving (Show)We're fortunate here in that there are no issues with plurals and grammar in the input (unlike Day 16). So we can write a fairly tedious but straightforward parser for each line:
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
string "Blueprint "
bpNum <- parsePositiveNumber
string ": Each ore robot costs "
oreCost <- parsePositiveNumber
string " ore. Each clay robot costs "
clayCost <- parsePositiveNumber
string " ore. Each obsidian robot costs "
obsOreCost <- parsePositiveNumber
string " ore and "
obsClayCost <- parsePositiveNumber
string " clay. Each geode robot costs "
geodeOreCost <- parsePositiveNumber
string " ore and "
geodeObsCost <- parsePositiveNumber
string " obsidian."
return $ BluePrint bpNum oreCost clayCost (obsOreCost, obsClayCost) (geodeOreCost, geodeObsCost)
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eolDepth First Search
The core of this problem is our depth-first search. We start with a type to capture the current search state. This has the number of each type of robot, the number of each resource we have, and the current time step.
data SearchState = SearchState
{ numOreRobots :: Int
, numClayRobots :: Int
, numObsidianRobots :: Int
, numGeodeRobots :: Int
, ore :: Int
, clay :: Int
, obsidian :: Int
, geodes :: Int
, time :: Int
} deriving (Eq, Ord, Show)Now we need to write a "neighbors" function. This tells us the possible "next states" that we can go to from our current state. This will take several additional parameters: the blueprint we're using, the maximum number of geodes we've seen so far, and the maximum time (since this changes from part 1 to part 2).
neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) = ...First, let's calculate the maximum reachable geodes from this state in the best possible case. Let's suppose we take our current geodes, plus all the geodes our current robots make, plus the number of geodes if we make a new geode robot every turn. If this optimistic number is still smaller than the largest we've seen, we'll return no possible moves:
neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
if maxGeodes < prevMax
then return []
else ...
where
maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]Now we'll start considering hypothetical moves. One move is to build nothing. We call this stepTime, since we allow time to move forward and we just accumulate more resources. This is always an option for us.
neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
if maxGeodes < prevMax
then return []
else ...
where
maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)Now let's think about making a geode robot. We can only do this if we have enough resources. So this expression will result in a Maybe value. The resulting state uses stepTime as its base, because it takes a minute to build the robot. The changes we'll make are to increment the geode robot count, and then subtract the resources we used based on the blueprint.
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
if maxGeodes < prevMax
then return []
else ...
where
maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)
tryMakeGeode = if ore' >= geoOre && obsidian' >= geoObs
then Just $ stepTime {numGeodeRobots = geoRobots + 1, ore = ore stepTime - geoOre, obsidian = obsidian stepTime - geoObs}
else NothingWe'll do the same for building an obsidian-collecting robot, but with one exception. We'll also enforce obsRobots < geoObs. That is, if we already have enough obsidian robots to afford the obsidian for a geode robot every minute, we won't make any more obsidian robots.
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
if maxGeodes < prevMax
then return []
else ...
where
maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)
tryMakeGeode = if ore' >= geoOre && obsidian' >= geoObs
then Just $ stepTime {numGeodeRobots = geoRobots + 1, ore = ore stepTime - geoOre, obsidian = obsidian stepTime - geoObs}
else Nothing
tryMakeObsidian = if ore' >= obsOre && clay' >= obsClay && obsRobots < geoObs
then Just $ stepTime {numObsidianRobots = obsRobots + 1, ore = ore stepTime - obsOre, clay = clay stepTime - obsClay}
else NothingAnd we do the same for constructing ore-collecting and clay-collecting robots.
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
if maxGeodes < prevMax
then return []
else ...
where
maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)
tryMakeGeode = if ore' >= geoOre && obsidian' >= geoObs
then Just $ stepTime {numGeodeRobots = geoRobots + 1, ore = ore stepTime - geoOre, obsidian = obsidian stepTime - geoObs}
else Nothing
tryMakeObsidian = if ore' >= obsOre && clay' >= obsClay && obsRobots < geoObs
then Just $ stepTime {numObsidianRobots = obsRobots + 1, ore = ore stepTime - obsOre, clay = clay stepTime - obsClay}
else Nothing
tryMakeOre = if ore' >= o && oRobots < maximum [o, c, obsOre, geoOre]
then Just $ stepTime {numOreRobots = oRobots + 1, ore = ore stepTime - o}
else Nothing
tryMakeClay = if ore' >= c && cRobots < obsClay
then Just $ stepTime {numClayRobots = cRobots + 1, ore = ore stepTime - c}
else NothingNow to get all our options, we'll use catMaybes with the building moves, and also include stepTime. I reversed the options so that attempting to make the higher-level robots takes priority in the search. With this heuristic, we're likely to get to higher yields earlier in the search, which will improve performance.
neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
(BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
if maxGeodes < prevMax
then return []
else do
let (results :: [SearchState]) = reverse (stepTime : catMaybes [tryMakeOre, tryMakeClay, tryMakeObsidian, tryMakeGeode])
return results
where
maxGeodes = ...
stepTime = ...
tryMakeOre = ...
tryMakeClay = ...
tryMakeObsidian = ...
tryMakeGeode = ...Now we need to write the search function itself. It will have two constant parameters - the blueprint and the maximum time. We'll also take variable values for the maximum number of geodes we've found, and the set of visited states. These will be our return values as well so other search branches can be informed of our results. Finally, we take a list of search states representing the "stack" for our depth-first search.
dfs :: (MonadLogger m) => Int -> BluePrint -> (Int, Set.Set SearchState) -> [SearchState] -> m (Int, Set.Set SearchState)First we need a base case. If our search stack is empty, we'll return our previous values.
dfs maxTime bp (mostGeodes, visited) stack = case stack of
[] -> return (mostGeodes, visited)
...Next we have a second base case. If the top element of our stack has reached the maximum time, we'll compare its number of geodes to the previous value and return the larger one. We'll add the state to the visited set (though it probably already lives there).
dfs maxTime bp (mostGeodes, visited) stack = case stack of
[] -> return (mostGeodes, visited)
(top : rest) -> if time top >= maxTime
then return (max mostGeodes (geodes top), Set.insert top visited)
else ...Now in the normal case, we'll get our neighboring states, filter them with the visited set, and add the remainder to the visited set.
dfs maxTime bp (mostGeodes, visited) stack = case stack of
[] -> return (mostGeodes, visited)
(top : rest) -> if time top >= maxTime
then return (max mostGeodes (geodes top), Set.insert top visited)
else do
next <- neighbors maxTime mostGeodes bp top
let next' = filter (\st -> not (st `Set.member` visited)) next
newVisited = foldl (flip Set.insert) visited next'
...Now you may have noticed that our function is set up for a fold after we remove the constant parameters:
(Int, Set.Set SearchState) -> [SearchState] -> m (Int, Set.Set SearchState)To accomplish this, we'll have to make a sub-helper though, which we'll just call f. It will "accumulate" the maximum value by comparing to our previous max, starting with the input mostGeodes.
dfs maxTime bp (mostGeodes, visited) stack = case stack of
[] -> return (mostGeodes, visited)
(top : rest) -> if time top >= maxTime
then return (max mostGeodes (geodes top), Set.insert top visited)
else do
next <- neighbors maxTime mostGeodes bp top
let next' = filter (\st -> not (st `Set.member` visited)) next
newVisited = foldl (flip Set.insert) visited next'
foldM f (mostGeodes, newVisited) next'
where
f (prevMax, newVisited) st = do
(resultVal, visited') <- dfs maxTime bp (prevMax, newVisited) (st : stack)
return (max resultVal prevMax, visited')This is all we need for our search! Now we just have to fill in a couple details to answer the question.
Answering the Question
For part 1, we'll write a fold wrapper that loops through each blueprint, gets its result, and then adds this to an accumulated value. We multiply each "quality" value (the maximum number of geodes) by the ID number for the blueprint. Note we use 24 as the maximum time.
type FoldType = Int
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prev blueprint = do
quality <- fst <$> dfs 24 blueprint (0, Set.empty) [initialState]
return $ prev + (idNumber blueprint * quality)
where
initialState = SearchState 1 0 0 0 0 0 0 0 0Then we glue all this together to get our part 1 solution.
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy = foldM foldLine 0
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy inputFor part 2, we do mostly the same thing. All that's different is that we only take the first 3 blueprints, we run them for 32 steps, and then we multiply those results.
type HardSolutionType = EasySolutionType
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard blueprints = foldM foldLineHard 1 (take 3 blueprints)
foldLineHard :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLineHard prev blueprint = do
quality <- fst <$> dfs 32 blueprint (0, Set.empty) [initialState]
return $ prev * quality
where
initialState = SearchState 1 0 0 0 0 0 0 0 0
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd this gives us our answer! It takes a few minutes for each part, but isn't intractable. Perhaps I'll look for optimizations later.
Video
Coming eventually. I'm on vacation now so videos aren't a top priority.