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