X-Git-Url: https://git.njae.me.uk/?a=blobdiff_plain;f=advent14%2FMain.hs;h=9a8627c6acbc8187447dc72c2882e6490bca503b;hb=HEAD;hp=d3b0c621feaeedc80e070b07b2237d36aa7fbe5b;hpb=ac1cb7b87194225d518bae8e5a9d9efe7d27220a;p=advent-of-code-23.git diff --git a/advent14/Main.hs b/advent14/Main.hs index d3b0c62..9a8627c 100644 --- a/advent14/Main.hs +++ b/advent14/Main.hs @@ -2,97 +2,80 @@ import AoC import Data.List -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as M import qualified Data.Array.Unboxed as U -import qualified Data.Array.ST as M +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( (:|>), (:<|) ) ) -data Element = Empty | Cube | Round deriving (Show, Eq, Ord) - type Position = V2 Int type Grid = U.UArray Position Bool -type MGrid s = M.STUArray s Position Bool - +type MGrid s = A.STUArray s Position Bool type Gaps s = STRef s (Q.Seq Position) - -type Cache = Map.Map Grid Int - +type Cache = M.Map Grid Int main :: IO () main = do dataFileName <- getDataFileName text <- readFile dataFileName 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 :: Grid -> Grid -> Int +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 Map.! grid' + repeatStart = cache M.! grid' repeatLen = repeatEnd - repeatStart finalIndex = ((1e9 - repeatStart) `mod` repeatLen) + repeatStart - (finalGrid, _) = Map.findMin $ Map.filter (== finalIndex) cache + (finalGrid, _) = M.findMin $ M.filter (== finalIndex) cache findRepeat :: Grid -> Grid -> (Grid, Cache, Int) -findRepeat rGrid cGrid = head $ dropWhile test $ iterate go (rGrid, Map.empty, 0) - where test (g, c, _) = g `Map.notMember` c - go (g, c, i) = (rollCycle g cGrid, Map.insert g i c, (i + 1)) +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) - ] +rollNorth rGrid cGrid = roll [(V2 0 0, V2 0 1, V2 1 0)] cGrid rGrid + +rollCycle rGrid cGrid = roll [ (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) + ] + cGrid rGrid 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 = - M.runSTUArray $ - do grid <- M.thaw rGrid +roll :: [(Position, Position, Position)] -> Grid -> Grid -> Grid +roll moveSpecs 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 -> - do rollPosition grid cGrid holes here + forM_ moveSpecs $ \(start, majorStep, minorStep) -> + 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 <- M.readArray grid here + | otherwise = do roundHere <- A.readArray grid here holesVal <- readSTRef holes if roundHere then case holesVal of Q.Empty -> return () - (h :<| hs) -> do M.writeArray grid h True - M.writeArray grid here False + (h :<| hs) -> do A.writeArray grid h True + A.writeArray grid here False writeSTRef holes (hs :|> here) else modifySTRef holes (:|> here) @@ -100,9 +83,8 @@ inBounds :: Grid -> Position -> Bool inBounds g h = inRange (U.bounds g) h getLoad :: Grid -> Int -getLoad grid = sum columnLoads +getLoad grid = sum [getColLoad c | c <- [0..cMax]] 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) @@ -110,16 +92,11 @@ 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)) $ map ((== Round) . readElem) $ concat rows - cGrid = U.listArray ((V2 0 0), (V2 r c)) $ map ((== Cube ) . readElem) $ concat rows - -readElem :: Char -> Element -readElem '.' = Empty -readElem '#' = Cube -readElem 'O' = Round + 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 -showGrid :: Grid -> Grid -> String -showGrid rGrid cGrid = unlines rows +showGrids :: Grid -> Grid -> String +showGrids 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]]