advent14/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/15/advent-of-code-2023-day-13/
   2
   3 import AoC
   4 import Data.List
   5 import Data.Semigroup
   6 import Data.Monoid
   7 import qualified Data.Map.Strict as M
   8
   9 data Element = Empty | Cube | Round deriving (Show, Eq, Ord)
  10 type Grid = [[Element]]
  11
  12 type Cache = M.Map Grid Int
  13
  14
  15 main :: IO ()
  16 main =
  17   do  dataFileName <- getDataFileName
  18       text <- readFile dataFileName
  19       let grid = transpose $ fmap (fmap readElem) $ lines text
  20       -- print grid
  21       -- print $ rollGrid $ transpose grid
  22       -- let r1 = rollToCompletion grid
  23       -- print r1
  24       -- putStrLn $ showGrid r1
  25       -- print $ transpose $ fmap reverse r1
  26       print $ part1 grid
  27       -- print $ rollCycle grid
  28       -- putStrLn $ showGrid $ rollCycle grid
  29       -- putStrLn $ showGrid $ rollCycle $ rollCycle grid
  30       -- putStrLn $ showGrid $ rollCycle $ rollCycle $ rollCycle grid
  31       -- print $ findRepeat grid
  32
  33
  34
  35       print $ part2 grid
  36       -- print $ part2 patts
  37
  38 part1 :: Grid -> Int
  39 part1 grid = scoreGrid grid'
  40   where grid' = rollToCompletion grid
  41
  42 part2 grid = scoreGrid finalGrid
  43   where (grid', cache, i) = findRepeat grid
  44         repeatStart = cache M.! grid'
  45         repeatLen = i - repeatStart
  46         finalIndex = (1e9 - repeatStart - 1) `mod` repeatLen
  47         (finalGrid, _) = M.findMin $ M.filter (== finalIndex) cache
  48
  49 readElem :: Char -> Element
  50 readElem '.' = Empty
  51 readElem '#' = Cube
  52 readElem 'O' = Round
  53
  54 rollToCompletion :: Grid -> Grid
  55 rollToCompletion grid = fst $ head $ dropWhile (uncurry (/=)) $ zip states $ tail states
  56   where states = iterate rollGrid grid
  57
  58 rollGrid :: Grid -> Grid
  59 rollGrid = fmap roll
  60
  61 roll :: [Element] -> [Element]
  62 roll [] = []
  63 roll (l:ls) = rs ++ [r]
  64   where (rs, r) = foldl' rollStep ([], l) ls
  65
  66 rollStep :: ([Element], Element) -> Element -> ([Element], Element)
  67 rollStep (handled, Empty) Round = (handled ++ [Round], Empty)
  68 rollStep (handled, target) source = (handled ++ [target], source)
  69
  70 scoreGrid :: Grid -> Int
  71 scoreGrid grid = sum $ fmap scoreRow indexedGrid
  72   where indexedGrid = zip [1..] $ reverse $ transpose grid
  73         scoreRow (i, r) = i * (length $ filter (== Round) r)
  74
  75 rotate1 :: Grid -> Grid
  76 rotate1 = transpose . fmap reverse
  77
  78 rollCycle :: Grid -> Grid
  79 rollCycle = appEndo (stimes 4 (Endo rotate1 <> Endo rollToCompletion))
  80
  81 showGrid :: Grid -> String
  82 showGrid grid = unlines $ fmap (fmap showElem) $ transpose grid
  83   where showElem Empty = '.'
  84         showElem Cube = '#'
  85         showElem Round = 'O'
  86
  87
  88 rollCycleWithCache (grid, cache, index) = (rollCycle grid, M.insert grid index cache, (index + 1))
  89
  90 findRepeat grid = head $ dropWhile test $ iterate rollCycleWithCache (grid, M.empty, 0)
  91   where test (g, c, i) = g `M.notMember` c
  92