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)
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)
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]]
projects / advent-of-code-23.git / blobdiff