advent21/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/29/advent-of-code-2023-day-21/
   2
   3 import AoC
   4 import Linear (V2(..), (^+^))
   5 import qualified Data.Set as S
   6 import Data.Ix
   7 import Data.List
   8 import Data.List.Split
   9
  10 type Position = V2 Int -- r, c
  11 type Grid = S.Set Position
  12
  13 main :: IO ()
  14 main =
  15   do  dataFileName <- getDataFileName
  16       text <- readFile dataFileName
  17       let (rocks, bounds) = mkGrid text
  18       let start = findStart text
  19       -- print rocks
  20       -- print bounds
  21       -- print start
  22       print $ part1 rocks bounds start
  23       -- print $ part2Quadratic rocks bounds start
  24       print $ part2 rocks bounds start -- ((26501365 - 65) `div` (131 * 2))
  25
  26 part1, part2, part2Quadratic :: Grid -> (Position, Position) -> Grid -> Int
  27 part1 rocks bounds start = S.size $ (!! 64) $ iterate (takeSteps rocks bounds) start
  28
  29 part2Quadratic rocks bounds start = a * x ^ 2 + b * x + c -- (p, q, r, a * x ^ 2 + b * x + c)
  30   where ps = (!! 65) $ iterate (takeSteps rocks bounds) start
  31         qs = (!! 131) $ iterate (takeSteps rocks bounds) ps
  32         rs = (!! 131) $ iterate (takeSteps rocks bounds) qs
  33         p = S.size ps
  34         q = S.size qs
  35         r = S.size rs
  36         c = p
  37         b = (4*q - 3*p - r) `div` 2
  38         a = q - p - b
  39         s = 26501365
  40         x = (s - 65) `div` 131
  41
  42 part2 rocks bounds start =
  43   nEvenFilled + nOddFilled + nEdges + upperPoint + lowerPoint + rCap + lCap
  44   where (V2 minR _, V2 maxR _) = bounds
  45         tileWidth = maxR - minR + 1
  46         (doubleTileSteps, extraSteps) = divMod 26501365 (tileWidth * 2)
  47         positions = (!! (tileWidth * 2 + extraSteps)) $ iterate (takeSteps rocks bounds) start
  48
  49         evenFilled = countInRange bounds (V2 0 0) positions
  50         oddFilled = countInRange bounds (V2 tileWidth 0) positions
  51         upperPoint = countInRange bounds (V2 (tileWidth * -2) 0) positions
  52         lowerPoint = countInRange bounds (V2 (tileWidth *  2) 0) positions
  53         urEdge = countInRange bounds (V2 (- tileWidth)        tileWidth) positions +
  54                  countInRange bounds (V2 (- tileWidth * 2)    tileWidth) positions
  55         lrEdge = countInRange bounds (V2    tileWidth         tileWidth) positions +
  56                  countInRange bounds (V2 (  tileWidth * 2)    tileWidth) positions
  57         ulEdge = countInRange bounds (V2 (- tileWidth)     (- tileWidth)) positions +
  58                  countInRange bounds (V2 (- tileWidth * 2) (- tileWidth)) positions
  59         llEdge = countInRange bounds (V2    tileWidth      (- tileWidth)) positions +
  60                  countInRange bounds (V2 (  tileWidth * 2) (- tileWidth)) positions
  61         rCap =   countInRange bounds (V2 (- tileWidth)     (  tileWidth * 2)) positions +
  62                  countInRange bounds (V2    0              (  tileWidth * 2)) positions +
  63                  countInRange bounds (V2    tileWidth      (  tileWidth * 2)) positions
  64         lCap =   countInRange bounds (V2 (- tileWidth)     (- tileWidth * 2)) positions +
  65                  countInRange bounds (V2    0              (- tileWidth * 2)) positions +
  66                  countInRange bounds (V2    tileWidth      (- tileWidth * 2)) positions
  67         edges = urEdge + lrEdge + ulEdge + llEdge
  68
  69         nEvenFilled = (doubleTileSteps * 2 - 1) ^ 2 * evenFilled
  70         nOddFilled = (doubleTileSteps * 2) ^ 2 * oddFilled
  71         nEdges = (doubleTileSteps * 2 - 1) * edges
  72
  73
  74 countInRange :: (Position, Position) -> Position -> Grid -> Int
  75 countInRange bounds delta cells =
  76   S.size $ S.filter (inRange (shiftBounds bounds delta)) cells
  77
  78 shiftBounds :: (Position, Position) -> Position -> (Position, Position)
  79 shiftBounds (a, b) d = (a ^+^ d, b ^+^ d)
  80
  81 takeSteps :: Grid -> (Position, Position) -> Grid -> Grid
  82 takeSteps rocks bounds places =
  83   S.filter (notAtRock rocks bounds) $ S.unions $ S.map adjacents places
  84
  85 notAtRock :: Grid -> (Position, Position) -> Position -> Bool
  86 notAtRock rocks (_, V2 maxR maxC) (V2 r c) = here' `S.notMember` rocks
  87   where here' = V2 (r `mod` (maxR + 1)) (c `mod` (maxC + 1))
  88
  89 adjacents :: Position -> Grid
  90 adjacents here = S.map (here ^+^) $ S.fromList [ V2 0 1, V2 1 0, V2 0 (-1), V2 (-1) 0 ]
  91
  92
  93 showGrid :: Grid -> (Position, Position) -> Grid -> String
  94 showGrid rocks bounds cells = unlines $ intercalate [" "] $ chunksOf 7 $ fmap (showRow rocks bounds cells) [-28..34]
  95   where showRow rocks bounds cells r = intercalate " " $ chunksOf 7 $ fmap ((showCell rocks bounds cells) . V2 r) [-28..34]
  96         showCell rocks bounds cells here
  97           | not $ notAtRock rocks bounds here = '#'
  98           | here `S.member` cells = 'O'
  99           | otherwise = '.'
 100 -- showCell :: Grid -> (Position, Position) -> Grid -> Position -> Char
 101
 102 -- reading the map
 103
 104 mkGrid :: String -> (Grid, (Position, Position))
 105 mkGrid text = ( S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
 106                            , rows !! r !! c == '#'
 107                            ]
 108               , (V2 0 0, V2 maxR maxC)
 109               )
 110   where rows = lines text
 111         maxR = length rows - 1
 112         maxC = (length $ head rows) - 1
 113
 114 findStart :: String -> Grid
 115 findStart text = S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
 116                             , rows !! r !! c == 'S'
 117                             ]
 118   where rows = lines text
 119         maxR = length rows - 1
 120         maxC = (length $ head rows) - 1
 121