advent14/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2022/12/15/advent-of-code-2022-day-14/
   2
   3 import AoC
   4 import Data.Text (Text)
   5 import qualified Data.Text.IO as TIO
   6 import Data.Attoparsec.Text hiding (take, D)
   7 import Data.List
   8 import Data.Ix
   9 import Data.Maybe
  10 import qualified Data.Set as S
  11 import Linear -- hiding (Trace, trace, distance)
  12 import Control.Lens
  13
  14 type Position = V2 Int -- x, y, y increasing down.
  15
  16 type Cave = S.Set Position
  17
  18 data Sand = Falling Position | Blocked Position | Escaped
  19   deriving (Eq, Show)
  20
  21 -- open floor: sand escapes below given level
  22 -- closed floor: sand blocked by floor with this y
  23 data Floor = Open Int | Closed Int deriving (Eq, Show)
  24
  25 main :: IO ()
  26 main =
  27   do  dataFileName <- getDataFileName
  28       text <- TIO.readFile dataFileName
  29       let corners = successfulParse text
  30       let stone = mkCave corners
  31       let floorY = fromJust $ maximumOf (folded . _y) stone
  32       print $ part1 stone floorY
  33       print $ part2 stone floorY
  34
  35 part1, part2 :: Cave -> Int -> Int
  36 part1 stone floorY = sandQty
  37   where filledCave = dropManySand stone (Open floorY)
  38         sandQty = (S.size filledCave) - (S.size stone)
  39 part2 stone floorY = sandQty
  40   where filledCave = dropManySand stone (Closed (floorY + 2))
  41         sandQty = (S.size filledCave) - (S.size stone)
  42
  43 mkCave :: [[Position]] -> Cave
  44 mkCave walls = foldl' addWall S.empty walls
  45
  46 addWall :: Cave -> [Position] -> Cave
  47 addWall cave wall = foldl' addSegment cave segments
  48   where segments = zip wall $ tail wall
  49
  50 addSegment :: Cave -> (Position, Position) -> Cave
  51 addSegment cave segment = S.union cave segments
  52   where segments = S.fromList $ range (uncurry min segment, uncurry max segment)
  53
  54 fallDirections :: [Position]
  55 fallDirections = [V2 0 1, V2 -1 1, V2 1 1]
  56
  57 sandOrigin :: Position
  58 sandOrigin = V2 500 0
  59
  60 fallStep :: Sand -> Cave -> Floor -> Sand
  61 fallStep (Blocked here) _ _ = Blocked here
  62 fallStep Escaped _ _ = Escaped
  63 fallStep (Falling here) cave (Open floorY)
  64   | here ^. _y > floorY = Escaped
  65   | otherwise = maybe (Blocked here) Falling $ find vacant
  66                                              $ fmap (here ^+^) fallDirections
  67   where vacant there = there `S.notMember` cave
  68 fallStep (Falling here) cave (Closed floorY) =
  69   maybe (Blocked here) Falling $ find vacant $ fmap (here ^+^) fallDirections
  70   where vacant there = (there ^. _y < floorY) && (there `S.notMember` cave)
  71
  72 fallsTo :: Sand -> Cave -> Floor -> Sand
  73 fallsTo here cave floorY =
  74   case fallStep here cave floorY of
  75     Escaped -> Escaped
  76     Blocked there -> Blocked there
  77     Falling there -> fallsTo (Falling there) cave floorY
  78
  79 dropManySand :: Cave -> Floor -> Cave
  80 dropManySand cave floorY
  81   | sandOrigin `S.member` cave = cave
  82   | otherwise = case dropOneSand cave floorY of
  83                   Nothing -> cave
  84                   Just cave' -> dropManySand cave' floorY
  85
  86 dropOneSand :: Cave -> Floor -> Maybe Cave
  87 dropOneSand cave floorY =
  88   case (fallsTo (Falling sandOrigin) cave floorY) of
  89     Escaped -> Nothing
  90     Blocked there -> Just (S.insert there cave)
  91     Falling _ -> error "sand still falling"
  92
  93 -- Parse the input file
  94
  95 wallsP :: Parser [[Position]]
  96 wallP :: Parser [Position]
  97 cornerP :: Parser Position
  98
  99 wallsP = wallP `sepBy` endOfLine
 100 wallP = cornerP `sepBy` " -> "
 101 cornerP = V2 <$> (decimal <* ",") <*> decimal
 102
 103 successfulParse :: Text -> [[Position]]
 104 successfulParse input =
 105   case parseOnly wallsP input of
 106     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 107     Right corners -> corners