X-Git-Url: https://git.njae.me.uk/?p=advent-of-code-22.git;a=blobdiff_plain;f=advent23%2FMain.hs;fp=advent23%2FMain.hs;h=08eef6c6f4f07c0970322e1d0ba74fbb44004a33;hp=194a8ea1a65177f0298a7491dbc8ca2e90e43df5;hb=c96b3e327eb7f937787e9ac846d8f7c354bfa4a1;hpb=74302040c3188f5306aee7b438094f11652a11f8 diff --git a/advent23/Main.hs b/advent23/Main.hs index 194a8ea..08eef6c 100644 --- a/advent23/Main.hs +++ b/advent23/Main.hs @@ -1,57 +1,48 @@ --- Writeup at https://work.njae.me.uk/2022/12/23/advent-of-code-2022-day-23/ +-- Writeup at https://work.njae.me.uk/2023/01/02/optimising-haskell-example-2/ -- import Debug.Trace import AoC -import qualified Data.Set as S import Linear -import Control.Lens import Data.Ix -import Data.Maybe --- import Data.Char import Data.Monoid -import Data.MultiSet as MS import Control.Monad.State.Strict +import Control.Monad.ST +import qualified Data.Array.IArray as A +import qualified Data.Array.MArray as M +import Data.Array.ST +import Data.Maybe -type Position = V2 Int -- r, c +type Position = V2 Int -- x, y data Direction = North | South | West | East deriving (Show, Eq, Ord, Enum, Bounded) -data Elf = Elf { _current :: Position, _proposed :: Position} - -- deriving (Show, Eq, Ord) - -- deriving (Eq, Ord) -makeLenses ''Elf - -instance Show Elf where - show elf = "Elf {c= " ++ (show (elf ^. current)) - ++ ", p= " ++ (show (elf ^. proposed)) - ++ " -> " ++ (show (directionOfElf elf)) - ++ "}" +newtype Elf = Elf Position + deriving (Eq, Ord, Show) -instance Eq Elf where - e1 == e2 = (_current e1) == (_current e2) +type Population = A.Array Position (Maybe Elf) -instance Ord Elf where - e1 `compare` e2 = (_current e1) `compare` (_current e2) +type MPopulation s = STArray s Position (Maybe Elf) +type MClashCounts s = STArray s Position Int -data Grove = Grove { currentGrove :: S.Set Elf, proposalDirections :: [Direction], elapsedRounds :: Int} +data Grove = Grove { currentGrove :: Population, proposalDirections :: [Direction], elapsedRounds :: Int} deriving (Eq) instance Show Grove where - show grove = (show $ currentGrove grove) ++ ", " ++ (show $ take 4 $ proposalDirections grove) ++ ", e = " ++ (show $ elapsedRounds grove) + show grove = (showElves $ currentGrove grove) ++ ", " ++ (show $ take 4 $ proposalDirections grove) ++ ", e = " ++ (show $ elapsedRounds grove) + where showElves g = "Grove " ++ (show $ A.bounds g) ++ " " ++ (show $ filter (isJust . snd) $ A.assocs g) type GroveState = State Grove - main :: IO () main = do dataFileName <- getDataFileName text <- readFile dataFileName let grove = Grove (mkGrove text) (cycle [North .. East]) 0 -- print grove - -- print $ execState simulateOnce grove + -- print $ runState simulateOnce grove -- print $ execState (simulateN 4) grove print $ part1 grove print $ part2 grove @@ -64,16 +55,9 @@ part1 grove = countEmpty grove' bounds part2 grove = elapsedRounds grove' where grove' = execState simulateToCompletion grove -directionOfElf :: Elf -> Maybe Direction -directionOfElf elf - | delta == V2 0 1 = Just North - | delta == V2 0 -1 = Just South - | delta == V2 1 0 = Just East - | delta == V2 -1 0 = Just West - | otherwise = Nothing - where delta = (elf ^. proposed) ^-^ (elf ^. current) -simulateToCompletion, simulateOnce, proposeMoves, removeClashes, moveElves, updateDirections, updateCount :: GroveState () +simulateToCompletion, simulateOnce, growGrove, updateDirections, updateCount :: GroveState () + simulateToCompletion = do oldGrove <- gets currentGrove simulateOnce @@ -89,27 +73,27 @@ simulateN n = simulateN (n - 1) simulateOnce = - do proposeMoves - removeClashes - moveElves - updateDirections - updateCount - -proposeMoves = - do grove <- gets currentGrove - proposalsInf <- gets proposalDirections - let proposals = take 4 proposalsInf - let grove' = S.map (makeProposal grove proposals) grove - modify' (\g -> g { currentGrove = grove'}) - -removeClashes = - do grove <- gets currentGrove - let clashes = findClashes grove - stopClashingElves clashes - -moveElves = + do grove <- gets currentGrove + proposalsInf <- gets proposalDirections + let proposals = take 4 proposalsInf + let newGrove = + runSTArray $ + do mPopulation <- M.thaw grove + mCounts <- M.mapArray (const 0) mPopulation + proposeMoves mPopulation mCounts proposals + removeClashes mPopulation mCounts + moveElves mPopulation + return mPopulation + modify' (\g -> g { currentGrove = newGrove}) + growGrove + updateDirections + updateCount + +growGrove = do grove <- gets currentGrove - let grove' = S.map moveElf grove + let (b0, b1) = findBounds grove + let bounds' = (b0 ^+^ (V2 -1 -1), b1 ^+^ (V2 1 1)) + let grove' = A.accumArray (flip const) Nothing bounds' $ filter ((inRange bounds') . fst ) $ A.assocs grove modify' (\g -> g { currentGrove = grove'}) updateDirections = modify' (\g -> g { proposalDirections = tail (proposalDirections g)}) @@ -117,99 +101,143 @@ updateCount = modify' (\g -> g { elapsedRounds = (elapsedRounds g) + 1}) -- position changing utilities -anyNeighbour :: S.Set Position -anyNeighbour = S.fromList [ V2 dx dy - | dx <- [-1, 0, 1] - , dy <- [-1, 0, 1] - , not ((dx == 0) && (dy == 0)) - ] +anyNeighbour :: [Position] +anyNeighbour = [ V2 dx dy + | dx <- [-1, 0, 1] + , dy <- [-1, 0, 1] + , not ((dx == 0) && (dy == 0)) + ] -directionNeighbour :: Direction -> S.Set Position -directionNeighbour North = S.filter (\d -> d ^. _y == 1) anyNeighbour -directionNeighbour South = S.filter (\d -> d ^. _y == -1) anyNeighbour -directionNeighbour West = S.filter (\d -> d ^. _x == -1) anyNeighbour -directionNeighbour East = S.filter (\d -> d ^. _x == 1) anyNeighbour +directionNeighbour :: Direction -> [Position] +directionNeighbour North = filter (\(V2 _x y) -> y == 1) anyNeighbour +directionNeighbour South = filter (\(V2 _x y) -> y == -1) anyNeighbour +directionNeighbour West = filter (\(V2 x _y) -> x == -1) anyNeighbour +directionNeighbour East = filter (\(V2 x _y) -> x == 1) anyNeighbour -stepDelta ::Direction -> Position +stepDelta :: Direction -> Position stepDelta North = V2 0 1 stepDelta South = V2 0 -1 stepDelta West = V2 -1 0 stepDelta East = V2 1 0 -translateTo :: Position -> S.Set Position -> S.Set Position -translateTo here deltas = S.map (here ^+^) deltas +noElves :: MPopulation s -> [Position] -> ST s Bool +noElves elves tests = + do others <- mapM (M.readArray elves) tests + return $ all isNothing others -noElves :: S.Set Elf -> S.Set Position -> Bool -noElves elves tests = S.null $ S.intersection tests $ S.map _current elves +isolated :: MPopulation s -> Position -> ST s Bool +isolated elves here = noElves elves $ fmap (here ^+^) anyNeighbour -- get elves to make proposals -isolated :: S.Set Elf -> Elf -> Bool -isolated elves elf = noElves elves $ translateTo (elf ^. current) $ anyNeighbour - -nearby :: S.Set Elf -> Elf -> S.Set Elf -nearby elves elf = S.filter (\e -> (e ^. current) `S.member` nbrs) elves - where nbrs = translateTo (elf ^. current) $ anyNeighbour - -makeProposal :: S.Set Elf -> [Direction] -> Elf -> Elf -makeProposal grove directions elf - | isolated localElves elf = elf - | otherwise = fromMaybe elf $ getFirst $ mconcat $ fmap First $ fmap (proposedStep localElves elf) directions - where localElves = nearby grove elf - -proposedStep :: S.Set Elf -> Elf -> Direction -> Maybe Elf -proposedStep grove elf direction - | noElves grove interfering = Just $ elf & proposed .~ (here ^+^ (stepDelta direction)) - | otherwise = Nothing - where here = elf ^. current - interfering = translateTo here $ directionNeighbour direction +proposeMoves :: MPopulation s -> MClashCounts s -> [Direction] -> ST s () +proposeMoves mPopulation mCounts proposals = + do assocs <- M.getAssocs mPopulation + mapM_ (makeProposal mPopulation mCounts proposals) assocs + +makeProposal :: MPopulation s -> MClashCounts s -> [Direction] -> (Position, Maybe Elf) -> ST s () +makeProposal elves clashes directions (here, elf) + | isNothing elf = return () + | otherwise = do isIsolated <- isolated elves here + unless isIsolated + do proposals <- mapM (proposedStep elves here) directions + let step = fromMaybe (V2 0 0) $ getFirst $ mconcat $ fmap First proposals + let there = here ^+^ step + thereCount <- M.readArray clashes there + M.writeArray clashes there (thereCount + 1) + M.writeArray elves here (Just (Elf there)) + +proposedStep :: MPopulation s -> Position -> Direction -> ST s (Maybe Position) +proposedStep elves here direction = + do isFree <- noElves elves interfering + if isFree + then return $ Just $ stepDelta direction + else return Nothing + where interfering = fmap (here ^+^) $ directionNeighbour direction -- find clashing elves and prevent them moving -findClashes :: S.Set Elf -> S.Set Position -findClashes grove = MS.toSet $ MS.foldOccur ifMany MS.empty targets - where targets = MS.map _proposed $ MS.fromSet grove - ifMany t n s - | n == 1 = s - | otherwise = MS.insert t s - -stopClashingElves :: S.Set Position -> GroveState () -stopClashingElves clashes = - do grove <- gets currentGrove - let grove' = S.map (notClash clashes) grove - modify' (\g -> g { currentGrove = grove'}) +removeClashes :: MPopulation s -> MClashCounts s -> ST s () +removeClashes elves counts = + do cts <- M.getAssocs counts + let clashes = fmap fst $ filter ((> 1) . snd) cts + stopClashingElves clashes elves -notClash :: S.Set Position -> Elf -> Elf -notClash clashes elf - | (elf ^. proposed) `S.member` clashes = elf & proposed .~ (elf ^. current) - | otherwise = elf +stopClashingElves :: [Position] -> MPopulation s -> ST s () +stopClashingElves clashes elves = mapM_ stopClash targets + where targets = concatMap findNbrs clashes + findNbrs c = fmap (^+^ c) $ fmap stepDelta [North .. East] + stopClash here = + do target <- M.readArray elves here + when (isJust target) $ M.writeArray elves here (Just (Elf here)) -- the elves move -moveElf :: Elf -> Elf -moveElf elf = elf & current .~ (elf ^. proposed) - --- part 1 solution utilities - -findBounds :: S.Set Elf -> (Position, Position) -findBounds grove = ((V2 minX minY), (V2 maxX maxY)) - where minX = fromJust $ minimumOf (folded . current . _x) grove - minY = fromJust $ minimumOf (folded . current . _y) grove - maxX = fromJust $ maximumOf (folded . current . _x) grove - maxY = fromJust $ maximumOf (folded . current . _y) grove - -countEmpty :: S.Set Elf -> (Position, Position) -> Int -countEmpty grove bounds = (rangeSize bounds) - (S.size grove) +moveElves :: MPopulation s -> ST s () +moveElves elves = + do assocs <- M.getAssocs elves + mapM_ (moveElf elves) assocs + +moveElf :: MPopulation s -> (Position, Maybe Elf) -> ST s () +moveElf _elves (_here, Nothing) = return () +moveElf elves (here, Just (Elf there)) = + do M.writeArray elves here Nothing + M.writeArray elves there (Just (Elf there)) + +-- reset the array bounds + +findBounds :: Population -> (Position, Position) +findBounds grove = boundsR + where bounds0 = A.bounds grove + boundsT = shrink grove topStrip topShrink bounds0 + boundsB = shrink grove bottomStrip bottomShrink boundsT + boundsL = shrink grove leftStrip leftShrink boundsB + boundsR = shrink grove rightStrip rightShrink boundsL + +shrink :: Population + -> ((Position, Position) -> (Position, Position)) + -> (Position, Position) + -> (Position, Position) + -> (Position, Position) +shrink grove findStrip stripDirection currentBounds + | emptyStrip grove (findStrip currentBounds) = + shrink grove findStrip stripDirection (shiftBounds currentBounds stripDirection) + | otherwise = currentBounds + where shiftBounds (b0, b1) (d0, d1) = (b0 ^+^ d0, b1 ^+^ d1) + +emptyStrip :: Population -> (Position, Position) -> Bool +emptyStrip grove strip = all isNothing $ fmap (grove A.!) $ range strip + +topStrip, bottomStrip, leftStrip, rightStrip :: (Position, Position) -> (Position, Position) +topStrip (V2 minX _minY, V2 maxX maxY) = (V2 minX maxY, V2 maxX maxY) +bottomStrip (V2 minX minY, V2 maxX _maxY) = (V2 minX minY, V2 maxX minY) +leftStrip (V2 minX minY, V2 _maxX maxY) = (V2 minX minY, V2 minX maxY) +rightStrip (V2 _minX minY, V2 maxX maxY) = (V2 maxX minY, V2 maxX maxY) + +topShrink, bottomShrink, leftShrink, rightShrink :: (Position, Position) +topShrink = (V2 0 0, V2 0 -1) +bottomShrink = (V2 0 1, V2 0 0) +leftShrink = (V2 1 0, V2 0 0) +rightShrink = (V2 0 0, V2 -1 0) + +countEmpty :: Population -> (Position, Position) -> Int +countEmpty grove bounds = length $ filter isNothing $ fmap (grove A.!) cells + where cells = range bounds -- Parse the input file -mkGrove :: String -> S.Set Elf -mkGrove text = S.fromList - [ Elf (V2 x y) (V2 x y) - | x <- [0..maxX], y <- [0..maxY] - , isElf x y +mkGrove :: String -> Population +mkGrove text = A.accumArray + (\_ e -> e) + Nothing + (V2 -1 -1, V2 maxX maxY) + [ mkElf x y -- Elf (V2 x y) (V2 x y) + | x <- [0..(maxX - 1)], y <- [0..(maxY - 1)] + -- , isElf x y ] where rows = reverse $ lines text - maxY = length rows - 1 - maxX = (length $ head rows) - 1 - isElf x y = ((rows !! y) !! x) == '#' + maxY = length rows + maxX = (length $ head rows) + mkElf x y + | ((rows !! y) !! x) == '#' = ((V2 x y), Just ( Elf (V2 x y) )) + | otherwise = ((V2 x y), Nothing)