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