advent23/MainUnordered.hs

   1 -- Writeup at https://work.njae.me.uk/2022/12/23/advent-of-code-2022-day-23/
   2
   3 -- import Debug.Trace
   4
   5 import AoC
   6 import qualified Data.HashSet as S
   7 import Linear
   8 import Control.Lens
   9 import Data.Ix
  10 import Data.Maybe
  11 -- import Data.Char
  12 import Data.Monoid
  13 import Data.MultiSet as MS
  14 import Control.Monad.State.Strict
  15 import Data.Hashable
  16
  17
  18 type Position = V2 Int -- r, c
  19
  20 data Direction = North | South | West | East
  21   deriving (Show, Eq, Ord, Enum, Bounded)
  22
  23 data Elf = Elf { _current :: Position, _proposed :: Position}
  24   -- deriving (Show, Eq, Ord)
  25   -- deriving (Eq, Ord)
  26 makeLenses ''Elf
  27
  28 instance Show Elf where
  29   show elf = "Elf {c= " ++ (show (elf ^. current))
  30                         ++ ", p= " ++ (show (elf ^. proposed))
  31                         ++ " -> " ++ (show (directionOfElf elf))
  32                         ++ "}"
  33
  34 instance Eq Elf where
  35   e1 == e2 = (_current e1) == (_current e2)
  36
  37 instance Ord Elf where
  38   e1 `compare` e2 = (_current e1) `compare` (_current e2)
  39
  40 instance Hashable Elf where
  41   hashWithSalt s e = hashWithSalt s (e ^. current)
  42
  43 type Population = S.HashSet Elf
  44
  45 data Grove = Grove { currentGrove :: Population, proposalDirections :: [Direction], elapsedRounds :: Int}
  46   deriving (Eq)
  47
  48 instance Show Grove where
  49   show grove = (show $ currentGrove grove) ++ ", " ++ (show $ take 4 $ proposalDirections grove) ++ ", e = " ++ (show $ elapsedRounds grove)
  50
  51 type GroveState = State Grove
  52
  53
  54 main :: IO ()
  55 main =
  56   do  dataFileName <- getDataFileName
  57       text <- readFile dataFileName
  58       let grove = Grove (mkGrove text) (cycle [North .. East]) 0
  59       -- print grove
  60       -- print $ execState simulateOnce grove
  61       -- print $ execState (simulateN 4) grove
  62       print $ part1 grove
  63       print $ part2 grove
  64
  65 part1, part2 :: Grove -> Int
  66 part1 grove = countEmpty grove' bounds
  67   where grove' = currentGrove $ execState (simulateN 10) grove
  68         bounds = findBounds grove'
  69
  70 part2 grove = elapsedRounds grove'
  71   where grove' = execState simulateToCompletion grove
  72
  73 directionOfElf :: Elf -> Maybe Direction
  74 directionOfElf elf
  75   | delta == V2 0 1 = Just North
  76   | delta == V2 0 -1 = Just South
  77   | delta == V2 1 0 = Just East
  78   | delta == V2 -1 0 = Just West
  79   | otherwise = Nothing
  80   where delta = (elf ^. proposed) ^-^ (elf ^. current)
  81
  82 simulateToCompletion, simulateOnce, proposeMoves, removeClashes, moveElves, updateDirections, updateCount :: GroveState ()
  83 simulateToCompletion =
  84   do oldGrove <- gets currentGrove
  85      simulateOnce
  86      newGrove <- gets currentGrove
  87      if oldGrove == newGrove
  88      then return ()
  89      else simulateToCompletion
  90
  91 simulateN :: Int -> GroveState ()
  92 simulateN 0 = return ()
  93 simulateN n =
  94   do simulateOnce
  95      simulateN (n - 1)
  96
  97 simulateOnce =
  98   do proposeMoves
  99      removeClashes
 100      moveElves
 101      updateDirections
 102      updateCount
 103
 104 proposeMoves =
 105   do grove <- gets currentGrove
 106      proposalsInf <- gets proposalDirections
 107      let proposals = take 4 proposalsInf
 108      let grove' = S.map (makeProposal grove proposals) grove
 109      modify' (\g -> g { currentGrove = grove'})
 110
 111 removeClashes =
 112   do grove <- gets currentGrove
 113      let clashes = findClashes grove
 114      stopClashingElves clashes
 115
 116 moveElves =
 117   do grove <- gets currentGrove
 118      let grove' = S.map moveElf grove
 119      modify' (\g -> g { currentGrove = grove'})
 120
 121 updateDirections = modify' (\g -> g { proposalDirections = tail (proposalDirections g)})
 122 updateCount = modify' (\g -> g { elapsedRounds = (elapsedRounds g) + 1})
 123
 124 -- position changing utilities
 125
 126 anyNeighbour :: S.HashSet Position
 127 anyNeighbour = S.fromList [ V2 dx dy
 128                           | dx <- [-1, 0, 1]
 129                           , dy <- [-1, 0, 1]
 130                           , not ((dx == 0) && (dy == 0))
 131                           ]
 132
 133 directionNeighbour :: Direction -> S.HashSet Position
 134 directionNeighbour North = S.filter (\d -> d ^. _y ==  1) anyNeighbour
 135 directionNeighbour South = S.filter (\d -> d ^. _y == -1) anyNeighbour
 136 directionNeighbour West  = S.filter (\d -> d ^. _x == -1) anyNeighbour
 137 directionNeighbour East  = S.filter (\d -> d ^. _x ==  1) anyNeighbour
 138
 139 stepDelta :: Direction -> Position
 140 stepDelta North = V2  0  1
 141 stepDelta South = V2  0 -1
 142 stepDelta West  = V2 -1  0
 143 stepDelta East  = V2  1  0
 144
 145 translateTo :: Position -> S.HashSet Position -> S.HashSet Position
 146 translateTo here deltas = S.map (here ^+^) deltas
 147
 148 noElves :: Population -> S.HashSet Position -> Bool
 149 noElves elves tests = S.null $ S.intersection tests $ S.map _current elves
 150
 151 -- get elves to make proposals
 152
 153 isolated :: Population -> Elf -> Bool
 154 isolated elves elf = noElves elves $ translateTo (elf ^. current) $ anyNeighbour
 155
 156 nearby :: Population -> Elf -> Population
 157 nearby elves elf = S.filter (\e -> (e ^. current) `S.member` nbrs) elves
 158   where nbrs = translateTo (elf ^. current) $ anyNeighbour
 159
 160 makeProposal :: Population -> [Direction] -> Elf -> Elf
 161 makeProposal grove directions elf
 162   | isolated localElves elf = elf
 163   | otherwise = fromMaybe elf $ getFirst $ mconcat $ fmap First $ fmap (proposedStep localElves elf) directions
 164   where localElves = nearby grove elf
 165
 166 proposedStep :: Population -> Elf -> Direction -> Maybe Elf
 167 proposedStep grove elf direction
 168   | noElves grove interfering = Just $ elf & proposed .~ (here ^+^ (stepDelta direction))
 169   | otherwise = Nothing
 170   where here = elf ^. current
 171         interfering = translateTo here $ directionNeighbour direction
 172
 173 -- find clashing elves and prevent them moving
 174
 175 findClashes :: Population -> S.HashSet Position
 176 findClashes grove = S.fromList $ MS.distinctElems $ MS.foldOccur ifMany MS.empty targets
 177   where targets = MS.map _proposed $ MS.fromList $ S.toList grove
 178         ifMany t n s
 179           | n == 1 = s
 180           | otherwise = MS.insert t s
 181
 182 stopClashingElves :: S.HashSet Position -> GroveState ()
 183 stopClashingElves clashes =
 184   do grove <- gets currentGrove
 185      let grove' = S.map (notClash clashes) grove
 186      modify' (\g -> g { currentGrove = grove'})
 187
 188 notClash :: S.HashSet Position -> Elf -> Elf
 189 notClash clashes elf
 190   | (elf ^. proposed) `S.member` clashes = elf & proposed .~ (elf ^. current)
 191   | otherwise = elf
 192
 193 -- the elves move
 194
 195 moveElf :: Elf -> Elf
 196 moveElf elf = elf & current .~ (elf ^. proposed)
 197
 198 -- part 1 solution utilities
 199
 200 findBounds :: Population -> (Position, Position)
 201 findBounds grove = ((V2 minX minY), (V2 maxX maxY))
 202   where minX = fromJust $ minimumOf (folded . current . _x) grove
 203         minY = fromJust $ minimumOf (folded . current . _y) grove
 204         maxX = fromJust $ maximumOf (folded . current . _x) grove
 205         maxY = fromJust $ maximumOf (folded . current . _y) grove
 206
 207 countEmpty :: Population -> (Position, Position) -> Int
 208 countEmpty grove bounds = (rangeSize bounds) - (S.size grove)
 209
 210 -- Parse the input file
 211
 212 mkGrove :: String -> Population
 213 mkGrove text = S.fromList
 214       [ Elf (V2 x y) (V2 x y)
 215       | x <- [0..maxX], y <- [0..maxY]
 216       , isElf x y
 217       ]
 218   where rows = reverse $ lines text
 219         maxY = length rows - 1
 220         maxX = (length $ head rows) - 1
 221         isElf x y = ((rows !! y) !! x) == '#'