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