X-Git-Url: https://git.njae.me.uk/?a=blobdiff_plain;f=advent14%2FMain.hs;h=e7e8d5b53173018faff8bde55d43e6a625d30c2a;hb=dd72089097a0df4238584f21a8078248bcf30117;hp=1d0e71eb9313e5e7e3aaa1ab45911bcd90e467e3;hpb=a9af1ff8e08c473ece30ccdee9ff1a895126c0b2;p=advent-of-code-23.git diff --git a/advent14/Main.hs b/advent14/Main.hs index 1d0e71e..e7e8d5b 100644 --- a/advent14/Main.hs +++ b/advent14/Main.hs @@ -2,75 +2,122 @@ 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 $ showGrid grid - print $ part1 grid - print $ part2 grid - -part1, part2 :: Grid -> Int -part1 grid = scoreGrid grid' - where grid' = rollToCompletion grid - -part2 grid = scoreGrid finalGrid - where (grid', cache, repeatEnd) = 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 = 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)) - -findRepeat :: Grid -> (Grid, Cache, Int) -findRepeat grid = head $ dropWhile test $ iterate go (grid, M.empty, 0) +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, M.insert g i c, (i + 1)) - -showGrid :: Grid -> String -showGrid grid = unlines $ fmap (fmap showElem) $ transpose grid - where showElem Empty = '.' - showElem Cube = '#' - showElem Round = 'O' + 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 -> '.'