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         start1 = takeSteps rocks bounds start
  48         (_, positions) = (!! (tileWidth + (extraSteps `div` 2))) $ iterate (take2Steps rocks bounds) (start1, start1)
  49
  50         evenFilled = countInRange bounds (V2 0 0) positions
  51         oddFilled = countInRange bounds (V2 tileWidth 0) positions
  52         upperPoint = countInRange bounds (V2 (tileWidth * -2) 0) positions
  53         lowerPoint = countInRange bounds (V2 (tileWidth *  2) 0) positions
  54         urEdge = countInRange bounds (V2 (- tileWidth)        tileWidth) positions +
  55                  countInRange bounds (V2 (- tileWidth * 2)    tileWidth) positions
  56         lrEdge = countInRange bounds (V2    tileWidth         tileWidth) positions +
  57                  countInRange bounds (V2 (  tileWidth * 2)    tileWidth) positions
  58         ulEdge = countInRange bounds (V2 (- tileWidth)     (- tileWidth)) positions +
  59                  countInRange bounds (V2 (- tileWidth * 2) (- tileWidth)) positions
  60         llEdge = countInRange bounds (V2    tileWidth      (- tileWidth)) positions +
  61                  countInRange bounds (V2 (  tileWidth * 2) (- tileWidth)) positions
  62         rCap =   countInRange bounds (V2 (- tileWidth)     (  tileWidth * 2)) positions +
  63                  countInRange bounds (V2    0              (  tileWidth * 2)) positions +
  64                  countInRange bounds (V2    tileWidth      (  tileWidth * 2)) positions
  65         lCap =   countInRange bounds (V2 (- tileWidth)     (- tileWidth * 2)) positions +
  66                  countInRange bounds (V2    0              (- tileWidth * 2)) positions +
  67                  countInRange bounds (V2    tileWidth      (- tileWidth * 2)) positions
  68         edges = urEdge + lrEdge + ulEdge + llEdge
  69
  70         nEvenFilled = (doubleTileSteps * 2 - 1) ^ 2 * evenFilled
  71         nOddFilled = (doubleTileSteps * 2) ^ 2 * oddFilled
  72         nEdges = (doubleTileSteps * 2 - 1) * edges
  73
  74
  75 countInRange :: (Position, Position) -> Position -> Grid -> Int
  76 countInRange bounds delta cells =
  77   S.size $ S.filter (inRange (shiftBounds bounds delta)) cells
  78
  79 shiftBounds :: (Position, Position) -> Position -> (Position, Position)
  80 shiftBounds (a, b) d = (a ^+^ d, b ^+^ d)
  81
  82 take2Steps rocks bounds (boundary, old) = (boundary2 S.\\ old, new)
  83   where boundary1 = takeSteps rocks bounds boundary
  84         boundary2 = takeSteps rocks bounds boundary1
  85         new = S.union old boundary2
  86
  87 takeSteps :: Grid -> (Position, Position) -> Grid -> Grid
  88 takeSteps rocks bounds places =
  89   S.filter (notAtRock rocks bounds) $ S.unions $ S.map adjacents places
  90
  91 notAtRock :: Grid -> (Position, Position) -> Position -> Bool
  92 notAtRock rocks (_, V2 maxR maxC) (V2 r c) = here' `S.notMember` rocks
  93   where here' = V2 (r `mod` (maxR + 1)) (c `mod` (maxC + 1))
  94
  95 adjacents :: Position -> Grid
  96 adjacents here = S.map (here ^+^) $ S.fromList [ V2 0 1, V2 1 0, V2 0 (-1), V2 (-1) 0 ]
  97
  98
  99 showGrid :: Grid -> (Position, Position) -> Grid -> String
 100 showGrid rocks bounds cells = unlines $ intercalate [" "] $ chunksOf 7 $ fmap (showRow rocks bounds cells) [-28..34]
 101   where showRow rocks bounds cells r = intercalate " " $ chunksOf 7 $ fmap ((showCell rocks bounds cells) . V2 r) [-28..34]
 102         showCell rocks bounds cells here
 103           | not $ notAtRock rocks bounds here = '#'
 104           | here `S.member` cells = 'O'
 105           | otherwise = '.'
 106 -- showCell :: Grid -> (Position, Position) -> Grid -> Position -> Char
 107
 108 -- reading the map
 109
 110 mkGrid :: String -> (Grid, (Position, Position))
 111 mkGrid text = ( S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
 112                            , rows !! r !! c == '#'
 113                            ]
 114               , (V2 0 0, V2 maxR maxC)
 115               )
 116   where rows = lines text
 117         maxR = length rows - 1
 118         maxC = (length $ head rows) - 1
 119
 120 findStart :: String -> Grid
 121 findStart text = S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
 122                             , rows !! r !! c == 'S'
 123                             ]
 124   where rows = lines text
 125         maxR = length rows - 1
 126         maxC = (length $ head rows) - 1
 127