--- 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
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
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)})
-- 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)
--- /dev/null
+-- 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) == '#'
projects / advent-of-code-22.git / commitdiff