import Control.Monad.State.Strict
import Control.Monad.ST
import qualified Data.Array.IArray as A
+import Data.Array.IArray ((!))
import qualified Data.Array.MArray as M
import Data.Array.ST
import Data.Maybe
simulateN (n - 1)
simulateOnce =
+ do updateGrove
+ growGrove
+ updateDirections
+ updateCount
+
+updateGrove :: GroveState ()
+updateGrove =
do grove <- gets currentGrove
proposalsInf <- gets proposalDirections
let proposals = take 4 proposalsInf
moveElves mPopulation
return mPopulation
modify' (\g -> g { currentGrove = newGrove})
- growGrove
- updateDirections
- updateCount
growGrove =
do grove <- gets currentGrove
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
+emptyStrip grove strip = all isNothing $ fmap (grove !) $ range strip
topStrip, bottomStrip, leftStrip, rightStrip :: (Position, Position) -> (Position, Position)
topStrip (V2 minX _minY, V2 maxX maxY) = (V2 minX maxY, V2 maxX maxY)
rightShrink = (V2 0 0, V2 -1 0)
countEmpty :: Population -> (Position, Position) -> Int
-countEmpty grove bounds = length $ filter isNothing $ fmap (grove A.!) cells
+countEmpty grove bounds = length $ filter isNothing $ fmap (grove !) cells
where cells = range bounds
-- Parse the input file
--- /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.HashSet 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 Data.Hashable
+
+
+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)
+
+instance Hashable Elf where
+ hashWithSalt s e = hashWithSalt s (e ^. current)
+
+type Population = S.HashSet 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.HashSet Position
+anyNeighbour = S.fromList [ V2 dx dy
+ | dx <- [-1, 0, 1]
+ , dy <- [-1, 0, 1]
+ , not ((dx == 0) && (dy == 0))
+ ]
+
+directionNeighbour :: Direction -> S.HashSet 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.HashSet Position -> S.HashSet Position
+translateTo here deltas = S.map (here ^+^) deltas
+
+noElves :: Population -> S.HashSet 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.HashSet Position
+findClashes grove = S.fromList $ MS.distinctElems $ MS.foldOccur ifMany MS.empty targets
+ where targets = MS.map _proposed $ MS.fromList $ S.toList grove
+ ifMany t n s
+ | n == 1 = s
+ | otherwise = MS.insert t s
+
+stopClashingElves :: S.HashSet Position -> GroveState ()
+stopClashingElves clashes =
+ do grove <- gets currentGrove
+ let grove' = S.map (notClash clashes) grove
+ modify' (\g -> g { currentGrove = grove'})
+
+notClash :: S.HashSet 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