Day 14 - Crushed by Sand?
Subscribe to Monday Morning Haskell!
Problem Overview
We're in a cave and sand is pouring on top of us! Not so great. Because sand is rough, and coarse, and irritating, and it gets everywhere.
But as long as we can calculate how many grains of sand will actually pour into the cave, I guess it's all right. Here's a diagram of the empty cave, with rock lines (#) that can catch grains of sand. The sand is falling in from the + position, with coordinates (500, 0). Note that y values increase as we go down into the cave.
4 5 5
9 0 0
4 0 3
0 ......+...
1 ..........
2 ..........
3 ..........
4 ....#...##
5 ....#...#.
6 ..###...#.
7 ........#.
8 ........#.
9 #########.As the sand pours in, it eventually falls into an abyss off the edge (at least in part 1).
.......+...
.......~...
......~o...
.....~ooo..
....~#ooo##
...~o#ooo#.
..~###ooo#.
..~..oooo#.
.~o.ooooo#.
~#########.
~..........
~..........
~..........Parsing the Input
Our actual puzzle input (not the diagram) is laid out line-by-line, where each line has a variable number of coordinates:
498,4 -> 498,6 -> 496,6
503,4 -> 502,4 -> 502,9 -> 494,9These coordinates give us the locations of the "rock lines" in the cave, denoted by # in the images above. The spaces between each input coordinate are filled out.
Parsing this isn't too hard. We use sepBy1 and a parser for the arrow in between, and then parse two comma separated numbers. Easy stuff with Megaparsec:
parseLine :: Monad m => ParsecT Void Text m [Coord2]
parseLine = sepBy1 parseNumbers (string " -> ")
where
parseNumbers = do
i <- parsePositiveNumber
char ','
j <- parsePositiveNumber
return (i, j)Getting all these lines line-by-line isn't a challenge. What's a little tricky is taking the coordinates and building out our initial set of all the coordinates covered by rocks. This should take a nested list of coordinates and return our final set.
type InputType = HS.HashSet Coord2
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
coordLines <- sepEndBy1 parseLine eol
lift $ buildInitialMap coordLines
buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
...How does this function work? Well first we need a function that will take two coordinates and fill in the missing coordinates between them. We have the horizontal and vertical cases. List comprehensions are our friend here (and tuple sections!). We just need to get the direction right so the comprehension goes the correct direction. We'll have one error case if the line isn't perfectly horizontal or vertical.
makeLine :: (MonadLogger m) => Coord2 -> Coord2 -> m [Coord2]
makeLine a@(a1, a2) b@(b1, b2)
| a1 == b1 = return $ map (a1,) (if a2 >= b2 then [b2,(b2+1)..a2] else [a2,(a2+1)..b2])
| a2 == b2 = return $ map (,b2) (if a1 >= b1 then [b1,(b1+1)..a1] else [a1,(a1+1)..b1])
| otherwise = logErrorN ("Line is neither horizontal nor vertical: " <> (pack . show $ (a, b))) >> return []Now the rest of buildInitialMap requires a loop. We'll go through each coordinate list, but use recursion in such a way that we're always considering the front two elements of the list. So length 0 and length 1 are base cases.
buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
buildInitialMap = foldM f HS.empty
where
f :: (MonadLogger m) => HS.HashSet Coord2 -> [Coord2] -> m (HS.HashSet Coord2)
f prevSet [] = return prevSet
f prevSet [_] = return prevSet
f prevSet (firstCoord : secondCoord : rest) = ...And the recursive case isn't too hard either. We'll get the new coordinates with makeLine and then use another fold to insert them into the set. Then we'll recurse without removing the second coordinate.
buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
buildInitialMap = foldM f HS.empty
where
f :: (MonadLogger m) => HS.HashSet Coord2 -> [Coord2] -> m (HS.HashSet Coord2)
f prevSet [] = return prevSet
f prevSet [_] = return prevSet
f prevSet (firstCoord : secondCoord : rest) = do
newCoords <- makeLine firstCoord secondCoord
f (foldl (flip HS.insert) prevSet newCoords) (secondCoord : rest)So now we've got a hash set with all the "blocked" coordinates. How do we solve the problem?
Getting the Solution
The key to this problem is writing a function to drop a single grain of sand and take that to its logical conclusion. We need to determine if it either comes to rest (adding a new location to our hash set) or if it falls into the abyss (telling us that we're done).
This is easy as long as we can wrap our heads around the different cases. Most importantly, there's the end condition. When do we stop counting? Well once a grain falls below the maximum y-value of our walls, there will be nothing to stop it. So let's imagine we're taking this maxY value as a parameter.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces = ...Now there are several cases here that we'll evaluate in order:
- Grain is past maximum y
- Space below the grain is empty
- Space below and left of the grain is empty
- Space below and right of the grain is empty
- All three spaces are blocked.
We can describe all these cases using guards:
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = ...
| not (HS.member (x, y + 1) filledSpaces) = ...
| not (HS.member (x - 1, y + 1) filledSpaces) = ...
| not (HS.member (x + 1, y + 1) filledSpaces) = ...
| otherwise = ...The first case is our base case. We'll return False without inserting anything.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = return (filledSpaces, False)
...In the next three cases, we'll recurse, imagining this grain falling to the coordinate in question.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = return (filledSpaces, False)
| not (HS.member (x, y + 1) filledSpaces) = dropSand maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand maxY (x + 1, y + 1) filledSpaces
...In the final case, we'll insert the coordinate into the set, and return True.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = return (filledSpaces, False)
| not (HS.member (x, y + 1) filledSpaces) = dropSand maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand maxY (x + 1, y + 1) filledSpaces
| otherwise = return (HS.insert (x, y) filledSpaces, True)Now we just need to call this function in a recursive loop. We drop a grain of sand from the starting position. If it lands, we recurse with the updated set and add 1 to our count. If it doesn't land, we return the number of grains we've stored.
evolveState :: (MonadLogger m) => Int -> (HS.HashSet Coord2, Int) -> m Int
evolveState maxY (filledSpaces, prevSands) = do
(newSet, landed) <- dropSand maxY (500, 0) filledSpaces
if landed
then evolveState maxY (newSet, prevSands + 1)
else return prevSandsAnd all that's left is to call this with an initial value, including grabbing the maxY parameter from our initial hash set:
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputWalls = do
let maxY = maximum $ snd <$> HS.toList inputWalls
evolveState maxY (inputWalls, 0)Part 2
Part 2 is not too different. Instead of imagining the sand falling into the abyss, we actually have to imagine there's an infinite horizontal line two levels below the maximum y-value.
...........+........
....................
....................
....................
.........#...##.....
.........#...#......
.......###...#......
.............#......
.............#......
.....#########......
....................
<-- etc #################### etc -->This means the sand will eventually stop flowing once we have three grains below our starting location. We'll place one final grain at the start location, and then we'll be done.
............o............
...........ooo...........
..........ooooo..........
.........ooooooo.........
........oo#ooo##o........
.......ooo#ooo#ooo.......
......oo###ooo#oooo......
.....oooo.oooo#ooooo.....
....oooooooooo#oooooo....
...ooo#########ooooooo...
..ooooo.......ooooooooo..
#########################The approach stays mostly the same, so we'll make a copy of our dropSand function, except with an apostrophe to differentiate it (dropSand'). We just have to tweak the end conditions in this function a little bit.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)Our first condition of y > maxY should now work the same as the previous otherwise case, because all grains should come to rest once they hit maxY + 1. We'll insert the coordinate into our set and return True.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
| y > maxY = return (HS.insert (x, y) filledSpaces, True)
...The middle conditions don't change at all.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
| y > maxY = return (HS.insert (x, y) filledSpaces, True)
| not (HS.member (x, y + 1) filledSpaces) = dropSand' maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand' maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand' maxY (x + 1, y + 1) filledSpaces
...Now we need our otherwise case. In this case, we've determined that our grain is blocked on all three spaces below it. Generally, we still want to insert it into our set. However, if the location we're inserting is the start location (500, 0), then we should return False to indicate it's time to stop recursing! Otherwise we return True as before.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
| y > maxY = return (HS.insert (x, y) filledSpaces, True)
| not (HS.member (x, y + 1) filledSpaces) = dropSand' maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand' maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand' maxY (x + 1, y + 1) filledSpaces
| otherwise = return (HS.insert (x, y) filledSpaces, (x, y) /= (500, 0))The rest of the code for part 2 stays basically the same!
evolveState' :: (MonadLogger m) => Int -> StateType -> m Int
evolveState' maxY (filledSpaces, prevSands) = do
(newSet, landed) <- dropSand' maxY (500, 0) filledSpaces
if landed
then evolveState' maxY (newSet, prevSands + 1)
else return (prevSands + 1)
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputWalls = do
let maxY = maximum $ snd <$> HS.toList inputWalls
evolveState' maxY (inputWalls, 0)Answering the Question
And now we're able to solve both parts by combining our code.
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputThis gives us our final answer, so we're done! This is another case where some better abstracting could save us from copying code. But when trying to write a solution as quickly as possible, copying old code is often the faster approach!
