--- Writeup at https://work.njae.me.uk/2023/12/15/advent-of-code-2023-day-13/
+-- Writeup at https://work.njae.me.uk/2023/12/18/advent-of-code-2023-day-14/
import AoC
import Data.List
-import Data.Semigroup
-import Data.Monoid
import qualified Data.Map.Strict as M
-
-data Element = Empty | Cube | Round deriving (Show, Eq, Ord)
-type Grid = [[Element]]
-
+import qualified Data.Array.Unboxed as U
+import qualified Data.Array.ST as A
+import Data.STRef
+import Control.Monad.ST
+import Control.Monad
+import Data.Ix
+import Linear (V2(..), (^+^))
+import qualified Data.Sequence as Q
+import Data.Sequence (Seq( (:|>), (:<|) ) )
+
+type Position = V2 Int
+type Grid = U.UArray Position Bool
+type MGrid s = A.STUArray s Position Bool
+type Gaps s = STRef s (Q.Seq Position)
type Cache = M.Map Grid Int
-
main :: IO ()
main =
do dataFileName <- getDataFileName
text <- readFile dataFileName
- let grid = transpose $ fmap (fmap readElem) $ lines text
- -- print grid
- -- print $ rollGrid $ transpose grid
- -- let r1 = rollToCompletion grid
- -- print r1
- -- putStrLn $ showGrid r1
- -- print $ transpose $ fmap reverse r1
- print $ part1 grid
- -- print $ rollCycle grid
- -- putStrLn $ showGrid $ rollCycle grid
- -- putStrLn $ showGrid $ rollCycle $ rollCycle grid
- -- putStrLn $ showGrid $ rollCycle $ rollCycle $ rollCycle grid
- -- print $ findRepeat grid
-
-
-
- print $ part2 grid
- -- print $ part2 patts
-
-part1 :: Grid -> Int
-part1 grid = scoreGrid grid'
- where grid' = rollToCompletion grid
-
-part2 grid = scoreGrid finalGrid
- where (grid', cache, i) = findRepeat grid
+ let (rGrid, cGrid) = readGrids text
+ -- putStrLn $ showGrid rGrid cGrid
+ -- let rGrid' = rollNorth rGrid cGrid
+ -- putStrLn $ showGrid rGrid' cGrid
+ print $ part1 rGrid cGrid
+ -- let rGrid1 = rollCycle rGrid cGrid
+ -- putStrLn $ showGrid rGrid1 cGrid
+ -- let rGrid2 = rollCycle rGrid1 cGrid
+ -- putStrLn $ showGrid rGrid2 cGrid
+ -- let rGrid3 = rollCycle rGrid2 cGrid
+ -- putStrLn $ showGrid rGrid3 cGrid
+ print $ part2 rGrid cGrid
+
+
+part1, part2 :: Grid -> Grid -> Int
+part1 rGrid cGrid = getLoad $ rollNorth rGrid cGrid
+part2 rGrid cGrid = getLoad finalGrid
+ where (grid', cache, repeatEnd) = findRepeat rGrid cGrid
repeatStart = cache M.! grid'
- repeatLen = i - repeatStart
- finalIndex = (1e9 - repeatStart - 1) `mod` repeatLen
+ repeatLen = repeatEnd - repeatStart
+ finalIndex = ((1e9 - repeatStart) `mod` repeatLen) + repeatStart
(finalGrid, _) = M.findMin $ M.filter (== finalIndex) cache
-readElem :: Char -> Element
-readElem '.' = Empty
-readElem '#' = Cube
-readElem 'O' = Round
-
-rollToCompletion :: Grid -> Grid
-rollToCompletion grid = fst $ head $ dropWhile (uncurry (/=)) $ zip states $ tail states
- where states = iterate rollGrid grid
-
-rollGrid :: Grid -> Grid
-rollGrid = fmap roll
-
-roll :: [Element] -> [Element]
-roll [] = []
-roll (l:ls) = rs ++ [r]
- where (rs, r) = foldl' rollStep ([], l) ls
-
-rollStep :: ([Element], Element) -> Element -> ([Element], Element)
-rollStep (handled, Empty) Round = (handled ++ [Round], Empty)
-rollStep (handled, target) source = (handled ++ [target], source)
-
-scoreGrid :: Grid -> Int
-scoreGrid grid = sum $ fmap scoreRow indexedGrid
- where indexedGrid = zip [1..] $ reverse $ transpose grid
- scoreRow (i, r) = i * (length $ filter (== Round) r)
-
-rotate1 :: Grid -> Grid
-rotate1 = transpose . fmap reverse
-
-rollCycle :: Grid -> Grid
-rollCycle = appEndo (stimes 4 (Endo rotate1 <> Endo rollToCompletion))
-
-showGrid :: Grid -> String
-showGrid grid = unlines $ fmap (fmap showElem) $ transpose grid
- where showElem Empty = '.'
- showElem Cube = '#'
- showElem Round = 'O'
-
-
-rollCycleWithCache (grid, cache, index) = (rollCycle grid, M.insert grid index cache, (index + 1))
-
-findRepeat grid = head $ dropWhile test $ iterate rollCycleWithCache (grid, M.empty, 0)
- where test (g, c, i) = g `M.notMember` c
+findRepeat :: Grid -> Grid -> (Grid, Cache, Int)
+findRepeat rGrid cGrid = head $ dropWhile test $ iterate go (rGrid, M.empty, 0)
+ where test (g, c, _) = g `M.notMember` c
+ go (g, c, i) = (rollCycle g cGrid, M.insert g i c, (i + 1))
+
+rollNorth, rollCycle :: Grid -> Grid -> Grid
+rollNorth rGrid cGrid = roll (V2 0 0) (V2 0 1) (V2 1 0) cGrid rGrid
+
+rollCycle rGrid cGrid = foldl' go rGrid [ (V2 0 0, V2 0 1, V2 1 0)
+ , (V2 0 0, V2 1 0, V2 0 1)
+ , (V2 r 0, V2 0 1, V2 -1 0)
+ , (V2 0 c, V2 1 0, V2 0 -1)
+ ]
+ where (_, V2 r c) = U.bounds rGrid
+ go g (start, majorStep, minorStep) =
+ roll start majorStep minorStep cGrid g
+
+roll :: Position -> Position -> Position -> Grid -> Grid -> Grid
+roll start majorStep minorStep cGrid rGrid =
+ A.runSTUArray $
+ do grid <- A.thaw rGrid
+ holes <- newSTRef Q.Empty
+ forM_ (takeWhile (inBounds rGrid) $ iterate (^+^ majorStep) start) $ \maj ->
+ do writeSTRef holes Q.Empty
+ forM_ (takeWhile (inBounds rGrid) $ iterate (^+^ minorStep) maj) $ \here ->
+ rollPosition grid cGrid holes here
+ return grid
+
+rollPosition :: (MGrid s) -> Grid -> (Gaps s) -> Position -> ST s ()
+rollPosition grid cGrid holes here
+ | cGrid U.! here = writeSTRef holes Q.Empty
+ | otherwise = do roundHere <- A.readArray grid here
+ holesVal <- readSTRef holes
+ if roundHere then
+ case holesVal of
+ Q.Empty -> return ()
+ (h :<| hs) -> do A.writeArray grid h True
+ A.writeArray grid here False
+ writeSTRef holes (hs :|> here)
+ else modifySTRef holes (:|> here)
+
+inBounds :: Grid -> Position -> Bool
+inBounds g h = inRange (U.bounds g) h
+
+getLoad :: Grid -> Int
+getLoad grid = sum columnLoads
+ where (_, V2 rMax cMax) = U.bounds grid
+ columnLoads = [getColLoad c | c <- [0..cMax]]
+ getColLoad c = sum [(rMax - r + 1) | r <- [0..rMax], grid U.! (V2 r c)]
+
+readGrids :: String -> (Grid, Grid)
+readGrids text = (rGrid, cGrid)
+ where rows = lines text
+ r = length rows - 1
+ c = (length $ head rows) - 1
+ rGrid = U.listArray ((V2 0 0), (V2 r c)) $ fmap (== 'O') $ concat rows
+ cGrid = U.listArray ((V2 0 0), (V2 r c)) $ fmap (== '#') $ concat rows
+
+-- readElem :: Char -> Element
+-- readElem '.' = Empty
+-- readElem '#' = Cube
+-- readElem 'O' = Round
+
+showGrid :: Grid -> Grid -> String
+showGrid rGrid cGrid = unlines rows
+ where (_, V2 rMax cMax) = U.bounds rGrid
+ rows = [showRow r | r <- [0..rMax]]
+ showRow r = [showElem r c | c <- [0..cMax]]
+ showElem r c = let isR = rGrid U.! (V2 r c)
+ isC = cGrid U.! (V2 r c)
+ in if | isR && isC -> 'X'
+ | isR -> 'O'
+ | isC -> '#'
+ | otherwise -> '.'
projects / advent-of-code-23.git / blobdiff