From c96b3e327eb7f937787e9ac846d8f7c354bfa4a1 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Mon, 2 Jan 2023 16:51:59 +0000 Subject: [PATCH] Day 23 now using arrays --- advent-of-code22.cabal | 9 +- advent23/Main.hs | 282 +++++++++++++++++++++------------------ advent23/MainOriginal.hs | 217 ++++++++++++++++++++++++++++++ 3 files changed, 379 insertions(+), 129 deletions(-) create mode 100644 advent23/MainOriginal.hs diff --git a/advent-of-code22.cabal b/advent-of-code22.cabal index 54649c9..24f58ef 100644 --- a/advent-of-code22.cabal +++ b/advent-of-code22.cabal @@ -241,15 +241,20 @@ executable advent22 main-is: advent22/Main.hs build-depends: containers, linear, lens, mtl +executable advent23original + import: common-extensions, build-directives + main-is: advent23/MainOriginal.hs + build-depends: containers, linear, lens, mtl, multiset + executable advent23 import: common-extensions, build-directives main-is: advent23/Main.hs - build-depends: containers, linear, lens, mtl, multiset + build-depends: linear, lens, mtl, array executable advent23prof import: common-extensions, build-directives main-is: advent23/Main.hs - build-depends: containers, linear, lens, mtl, multiset + build-depends: linear, lens, mtl, array ghc-options: -O2 -Wall -threaded 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) diff --git a/advent23/MainOriginal.hs b/advent23/MainOriginal.hs new file mode 100644 index 0000000..6296489 --- /dev/null +++ b/advent23/MainOriginal.hs @@ -0,0 +1,217 @@ +-- Writeup at https://work.njae.me.uk/2022/12/23/advent-of-code-2022-day-23/ + +-- 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 + + +type Position = V2 Int -- r, c + +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)) + ++ "}" + +instance Eq Elf where + e1 == e2 = (_current e1) == (_current e2) + +instance Ord Elf where + e1 `compare` e2 = (_current e1) `compare` (_current e2) + +type Population = S.Set Elf + +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) + +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 $ execState (simulateN 4) grove + print $ part1 grove + print $ part2 grove + +part1, part2 :: Grove -> Int +part1 grove = countEmpty grove' bounds + where grove' = currentGrove $ execState (simulateN 10) grove + bounds = findBounds grove' + +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 = + do oldGrove <- gets currentGrove + simulateOnce + newGrove <- gets currentGrove + if oldGrove == newGrove + then return () + else simulateToCompletion + +simulateN :: Int -> GroveState () +simulateN 0 = return () +simulateN n = + do simulateOnce + 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 + let grove' = S.map moveElf grove + modify' (\g -> g { currentGrove = grove'}) + +updateDirections = modify' (\g -> g { proposalDirections = tail (proposalDirections g)}) +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)) + ] + +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 + +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 :: Population -> S.Set Position -> Bool +noElves elves tests = S.null $ S.intersection tests $ S.map _current elves + +-- get elves to make proposals + +isolated :: Population -> Elf -> Bool +isolated elves elf = noElves elves $ translateTo (elf ^. current) $ anyNeighbour + +nearby :: Population -> Elf -> Population +nearby elves elf = S.filter (\e -> (e ^. current) `S.member` nbrs) elves + where nbrs = translateTo (elf ^. current) $ anyNeighbour + +makeProposal :: Population -> [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 :: Population -> 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 + +-- find clashing elves and prevent them moving + +findClashes :: Population -> 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'}) + +notClash :: S.Set Position -> Elf -> Elf +notClash clashes elf + | (elf ^. proposed) `S.member` clashes = elf & proposed .~ (elf ^. current) + | otherwise = elf + +-- the elves move + +moveElf :: Elf -> Elf +moveElf elf = elf & current .~ (elf ^. proposed) + +-- part 1 solution utilities + +findBounds :: Population -> (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 :: Population -> (Position, Position) -> Int +countEmpty grove bounds = (rangeSize bounds) - (S.size grove) + +-- Parse the input file + +mkGrove :: String -> Population +mkGrove text = S.fromList + [ Elf (V2 x y) (V2 x y) + | x <- [0..maxX], y <- [0..maxY] + , isElf x y + ] + where rows = reverse $ lines text + maxY = length rows - 1 + maxX = (length $ head rows) - 1 + isElf x y = ((rows !! y) !! x) == '#' -- 2.34.1