advent20/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-11/
   2
   3 import Debug.Trace
   4
   5 import AoC
   6 import Data.Text (Text)
   7 import qualified Data.Text.IO as TIO
   8 import Data.Attoparsec.Text hiding (take)
   9 import Control.Applicative
  10 import Data.List
  11 import qualified Data.Map.Strict as M
  12 import Data.Map ((!))
  13 import qualified Data.Sequence as Q
  14 import Data.Sequence ((|>), (><), Seq( (:|>), (:<|) ) )
  15 -- import Data.Sequence ((|>), (><))
  16 import Control.Lens hiding (Level)
  17 import Control.Monad.State.Strict
  18 import Control.Monad.Reader
  19 import Control.Monad.Writer
  20 import Control.Monad.RWS.Strict
  21
  22 type Name = String
  23
  24 data Level = Low | High deriving (Show, Eq, Ord)
  25 data Pulse = Pulse { _source :: Name, _level :: Level , _destination :: Name }
  26   deriving (Show, Eq, Ord)
  27 makeLenses ''Pulse
  28
  29 type Queue = Q.Seq Pulse
  30
  31 type Memory = M.Map Name Level
  32
  33 data Module =
  34   Broadcast
  35   | FlipFlop Bool
  36   | Conjunction Memory
  37   | Untyped
  38   deriving (Show, Eq, Ord)
  39
  40 type Network = M.Map Name [Name]
  41 type Modules = M.Map Name Module
  42
  43 data NetworkState = NetworkState { _modules :: Modules
  44                                  , _queue :: Queue
  45                                  }
  46   deriving (Show, Eq, Ord)
  47 makeLenses ''NetworkState
  48
  49 type NetworkHandler = RWS Network [Pulse] NetworkState
  50
  51 main :: IO ()
  52 main =
  53   do  dataFileName <- getDataFileName
  54       text <- TIO.readFile dataFileName
  55       let config = successfulParse text
  56       let (network, modules) = assembleNetwork config
  57       -- print config
  58       -- print $ assembleNetwork config
  59       -- let pulse0 = Q.singleton $ Pulse "button" Low "broadcaster"
  60       -- let (state1, out1) =
  61       --         execRWS handlePulses
  62       --           network
  63       --           (NetworkState modules pulse0)
  64       -- print (out1, state1)
  65       -- let (state2, out2) =
  66       --         execRWS handlePulses
  67       --           network
  68       --           (state1 & queue .~ pulse0)
  69       -- print (out2, state2)
  70       -- let (state3, out3) =
  71       --         execRWS handlePulses
  72       --           network
  73       --           (state2 & queue .~ pulse0)
  74       -- print (out3, state3)
  75       -- let (state4, out4) =
  76       --         execRWS handlePulses
  77       --           network
  78       --           (state3 & queue .~ pulse0)
  79       -- print (out4, state4)
  80       print $ part1 network modules
  81       putStrLn $ showDot network
  82
  83
  84
  85
  86 part1 :: Network -> Modules -> Int
  87 part1 network modules = highs * lows
  88   where (highs, lows) = manyButtonPress 1000 (0, 0) network state0
  89         state0 = NetworkState modules Q.empty
  90
  91 manyButtonPress :: Int -> (Int, Int) -> Network -> NetworkState -> (Int, Int)
  92 manyButtonPress 0 (highs, lows) _ _ = (highs, lows)
  93 manyButtonPress n (highs, lows) network state =
  94   manyButtonPress (n - 1) (highs + length hs, lows + length ls) network state'
  95   where (state', pulses) = buttonPress network state
  96         (hs, ls) = partition ((== High) . _level) pulses
  97
  98 buttonPress :: Network -> NetworkState -> (NetworkState, [Pulse])
  99 buttonPress network state =
 100   execRWS handlePulses network (state & queue .~ pulse0)
 101   where pulse0 = Q.singleton $ Pulse "button" Low "broadcaster"
 102
 103
 104 handlePulses :: NetworkHandler ()
 105 handlePulses =
 106   do  pulses <- gets _queue
 107       if Q.null pulses
 108         then return ()
 109         else
 110           do  let p :<| _ = pulses
 111               handlePulse p
 112               modify (\s -> s & queue %~ (Q.drop 1))
 113               handlePulses
 114       -- case Q.viewl pulses of
 115       --   Q.EmptyL -> return ()
 116       --   p :< _ ->
 117       --     do  modify (\s -> s & queue %~ (Q.drop 1))
 118       --         handlePulse p
 119       --         handlePulses
 120
 121 handlePulse :: Pulse -> NetworkHandler ()
 122 handlePulse p@(Pulse _ _ destination) =
 123   do  mdl <- gets ((! destination) . _modules)
 124       outGoings <- asks (! destination)
 125       let (mdl', maybeLevel) = processPulse p mdl
 126       modify (\s -> s & modules . ix destination .~ mdl')
 127       tell [p]
 128       case maybeLevel of
 129         Nothing -> return ()
 130         Just level' ->
 131           do let newPulses = fmap (Pulse destination level') outGoings
 132              modify (\s -> s & queue %~ (>< (Q.fromList newPulses)))
 133             --  tell newPulses
 134              return ()
 135
 136 processPulse :: Pulse -> Module -> (Module, Maybe Level)
 137 -- processPulse p m | trace ((show p) ++ " " ++ (show m) ) False = undefined
 138 processPulse (Pulse _ l _) Broadcast = (Broadcast, Just l)
 139 processPulse (Pulse _ Low _) (FlipFlop False) = (FlipFlop True, Just High)
 140 processPulse (Pulse _ Low _) (FlipFlop True) = (FlipFlop False, Just Low)
 141 processPulse (Pulse _ High _) (FlipFlop s) = (FlipFlop s, Nothing)
 142 processPulse (Pulse s l _) (Conjunction memory) =
 143   (Conjunction memory', Just outLevel)
 144   where memory' = M.insert s l memory
 145         outLevel = if all (== High) $ M.elems memory' then Low else High
 146 processPulse _ Untyped = (Untyped, Nothing)
 147
 148
 149
 150 assembleNetwork :: [((Module, Name), [Name])] -> (Network, Modules)
 151 assembleNetwork config = (network, modules)
 152   where (network, modules0) = mkNetwork config
 153         modules1 = M.union (mkModules config) modules0
 154         modules = addConjunctionMemory network modules1
 155
 156 mkModules :: [((Module, Name), [Name])] -> Modules
 157 mkModules = M.fromList . fmap (\((m, n), _) -> (n, m))
 158
 159 mkNetwork :: [((Module, Name), [Name])] -> (Network, Modules)
 160 mkNetwork config = (net, mods)
 161   where net = M.fromList $ fmap (\((_, n), ds) -> (n, ds)) config
 162         mods = M.fromList $ concatMap (\(_, ds) -> fmap (\d -> (d, Untyped)) ds) config
 163
 164 addConjunctionMemory :: Network -> Modules -> Modules
 165 addConjunctionMemory network modules =
 166   M.foldlWithKey addMemory modules network
 167
 168 addMemory :: Modules -> Name -> [Name] -> Modules
 169 addMemory modules source connections =
 170   foldl' (addOneMemory source) modules connections
 171
 172 addOneMemory :: Name -> Modules -> Name -> Modules
 173 addOneMemory source modules destination =
 174   case modules ! destination of
 175     Conjunction memory -> M.insert destination (Conjunction $ M.insert source Low memory) modules
 176     _ -> modules
 177
 178
 179 showDot :: Network -> String
 180 showDot network =
 181   "digraph {\n" ++ (concatMap showDotLine $ M.toList network) ++ "\n}"
 182   where showDotLine (source, destinations) =
 183           concatMap (\d -> source ++ " -> " ++ d ++ ";\n") destinations
 184
 185
 186 -- Parse the input file
 187
 188 configLinesP :: Parser [((Module, Name), [Name])]
 189 configLineP :: Parser ((Module, Name), [Name])
 190 moduleP, broadcastP, flipFlopP, conjunctionP :: Parser (Module, Name)
 191 -- namesP :: Parser [Name]
 192 nameP :: Parser Name
 193
 194 configLinesP = configLineP `sepBy` endOfLine
 195 configLineP = (,) <$> (moduleP <* " -> ") <*> (nameP `sepBy` ", ")
 196
 197 moduleP = broadcastP <|> flipFlopP <|> conjunctionP
 198
 199 broadcastP = (Broadcast, "broadcaster") <$ "broadcaster"
 200 flipFlopP = (FlipFlop False, ) <$> ("%" *> nameP)
 201 conjunctionP = (Conjunction M.empty, ) <$> ("&" *> nameP)
 202
 203 -- namesP = nameP `sepBy` ", "
 204 nameP = many1 letter
 205
 206 successfulParse :: Text -> [((Module, Name), [Name])]
 207 successfulParse input =
 208   case parseOnly configLinesP input of
 209     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 210     Right monkeys -> monkeys