Done day 14

[advent-of-code-22.git] / advent14 / Main.hs

diff --git a/advent14/Main.hs b/advent14/Main.hs
new file mode 100644 (file)
index 0000000..0ded02b
--- /dev/null
+++ b/advent14/Main.hs
@@ -0,0 +1,108 @@
+-- Writeup at https://work.njae.me.uk/2022/12/15/advent-of-code-2022-day-14/
+
+import AoC
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+import Data.Attoparsec.Text hiding (take, D)
+import Control.Applicative
+import Data.List
+import Data.Ix
+import Data.Maybe
+import qualified Data.Set as S
+import Linear -- hiding (Trace, trace, distance)
+import Control.Lens
+
+type Position = V2 Int -- x, y, y increasing down.
+
+type Cave = S.Set Position
+
+data Sand = Falling Position | Blocked Position | Escaped
+  deriving (Eq, Show)
+
+-- open floor: sand escapes below given level
+-- closed floor: sand blocked by floor with this y
+data Floor = Open Int | Closed Int deriving (Eq, Show)
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- TIO.readFile dataFileName
+      let corners = successfulParse text
+      let stone = mkCave corners
+      let floorY = fromJust $ maximumOf (folded . _y) stone 
+      print $ part1 stone floorY 
+      print $ part2 stone floorY 
+
+part1, part2 :: Cave -> Int -> Int
+part1 stone floorY = sandQty
+  where filledCave = dropManySand stone (Open floorY)
+        sandQty = (S.size filledCave) - (S.size stone)
+part2 stone floorY = sandQty
+  where filledCave = dropManySand stone (Closed (floorY + 2))
+        sandQty = (S.size filledCave) - (S.size stone)
+
+mkCave :: [[Position]] -> Cave
+mkCave walls = foldl' addWall S.empty walls
+
+addWall :: Cave -> [Position] -> Cave
+addWall cave wall = foldl' addSegment cave segments
+  where segments = zip wall $ tail wall
+
+addSegment :: Cave -> (Position, Position) -> Cave
+addSegment cave segment = S.union cave segments
+  where segments = S.fromList $ range (uncurry min segment, uncurry max segment)
+
+fallDirections :: [Position]
+fallDirections = [V2 0 1, V2 -1 1, V2 1 1]
+
+sandOrigin :: Position
+sandOrigin = V2 500 0
+
+fallStep :: Sand -> Cave -> Floor -> Sand
+fallStep (Blocked here) _ _ = Blocked here
+fallStep Escaped _ _ = Escaped
+fallStep (Falling here) cave (Open floorY)
+  | here ^. _y > floorY = Escaped
+  | otherwise = maybe (Blocked here) Falling $ find vacant 
+                                             $ fmap (here ^+^) fallDirections  
+  where vacant there = there `S.notMember` cave
+fallStep (Falling here) cave (Closed floorY) = 
+  maybe (Blocked here) Falling $ find vacant $ fmap (here ^+^) fallDirections
+  where vacant there = (there ^. _y < floorY) && (there `S.notMember` cave)
+
+fallsTo :: Sand -> Cave -> Floor -> Sand
+fallsTo here cave floorY =
+  case fallStep here cave floorY of
+    Escaped -> Escaped
+    Blocked there -> Blocked there
+    Falling there -> fallsTo (Falling there) cave floorY
+
+dropManySand :: Cave -> Floor -> Cave
+dropManySand cave floorY 
+  | sandOrigin `S.member` cave = cave
+  | otherwise = case dropOneSand cave floorY of
+                  Nothing -> cave
+                  Just cave' -> dropManySand cave' floorY
+
+dropOneSand :: Cave -> Floor -> Maybe Cave
+dropOneSand cave floorY = 
+  case (fallsTo (Falling sandOrigin) cave floorY) of
+    Escaped -> Nothing
+    Blocked there -> Just (S.insert there cave)
+    Falling _ -> error "sand still falling"
+
+-- Parse the input file
+
+wallsP :: Parser [[Position]]
+wallP :: Parser [Position]
+cornerP :: Parser Position
+
+wallsP = wallP `sepBy` endOfLine
+wallP = cornerP `sepBy` " -> "
+cornerP = V2 <$> (decimal <* ",") <*> decimal
+
+successfulParse :: Text -> [[Position]]
+successfulParse input = 
+  case parseOnly wallsP input of
+    Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
+    Right corners -> corners