From ab15eef15936a685030126a725088371eb475c60 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sun, 24 Dec 2023 19:41:26 +0000 Subject: [PATCH] Done day 20 part 1 --- advent-of-code23.cabal | 5 + advent20/Main.hs | 210 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 215 insertions(+) create mode 100644 advent20/Main.hs diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index a731ac8..08ab63c 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -211,3 +211,8 @@ executable advent19 import: common-extensions, build-directives main-is: advent19/Main.hs build-depends: containers, text, attoparsec, lens + +executable advent20 + import: common-extensions, build-directives + main-is: advent20/Main.hs + build-depends: containers, text, attoparsec, lens, mtl diff --git a/advent20/Main.hs b/advent20/Main.hs new file mode 100644 index 0000000..5f77278 --- /dev/null +++ b/advent20/Main.hs @@ -0,0 +1,210 @@ +-- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-11/ + +import Debug.Trace + +import AoC +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take) +import Control.Applicative +import Data.List +import qualified Data.Map.Strict as M +import Data.Map ((!)) +import qualified Data.Sequence as Q +import Data.Sequence ((|>), (><), Seq( (:|>), (:<|) ) ) +-- import Data.Sequence ((|>), (><)) +import Control.Lens hiding (Level) +import Control.Monad.State.Strict +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.RWS.Strict + +type Name = String + +data Level = Low | High deriving (Show, Eq, Ord) +data Pulse = Pulse { _source :: Name, _level :: Level , _destination :: Name } + deriving (Show, Eq, Ord) +makeLenses ''Pulse + +type Queue = Q.Seq Pulse + +type Memory = M.Map Name Level + +data Module = + Broadcast + | FlipFlop Bool + | Conjunction Memory + | Untyped + deriving (Show, Eq, Ord) + +type Network = M.Map Name [Name] +type Modules = M.Map Name Module + +data NetworkState = NetworkState { _modules :: Modules + , _queue :: Queue + } + deriving (Show, Eq, Ord) +makeLenses ''NetworkState + +type NetworkHandler = RWS Network [Pulse] NetworkState + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let config = successfulParse text + let (network, modules) = assembleNetwork config + -- print config + -- print $ assembleNetwork config + -- let pulse0 = Q.singleton $ Pulse "button" Low "broadcaster" + -- let (state1, out1) = + -- execRWS handlePulses + -- network + -- (NetworkState modules pulse0) + -- print (out1, state1) + -- let (state2, out2) = + -- execRWS handlePulses + -- network + -- (state1 & queue .~ pulse0) + -- print (out2, state2) + -- let (state3, out3) = + -- execRWS handlePulses + -- network + -- (state2 & queue .~ pulse0) + -- print (out3, state3) + -- let (state4, out4) = + -- execRWS handlePulses + -- network + -- (state3 & queue .~ pulse0) + -- print (out4, state4) + print $ part1 network modules + putStrLn $ showDot network + + + + +part1 :: Network -> Modules -> Int +part1 network modules = highs * lows + where (highs, lows) = manyButtonPress 1000 (0, 0) network state0 + state0 = NetworkState modules Q.empty + +manyButtonPress :: Int -> (Int, Int) -> Network -> NetworkState -> (Int, Int) +manyButtonPress 0 (highs, lows) _ _ = (highs, lows) +manyButtonPress n (highs, lows) network state = + manyButtonPress (n - 1) (highs + length hs, lows + length ls) network state' + where (state', pulses) = buttonPress network state + (hs, ls) = partition ((== High) . _level) pulses + +buttonPress :: Network -> NetworkState -> (NetworkState, [Pulse]) +buttonPress network state = + execRWS handlePulses network (state & queue .~ pulse0) + where pulse0 = Q.singleton $ Pulse "button" Low "broadcaster" + + +handlePulses :: NetworkHandler () +handlePulses = + do pulses <- gets _queue + if Q.null pulses + then return () + else + do let p :<| _ = pulses + handlePulse p + modify (\s -> s & queue %~ (Q.drop 1)) + handlePulses + -- case Q.viewl pulses of + -- Q.EmptyL -> return () + -- p :< _ -> + -- do modify (\s -> s & queue %~ (Q.drop 1)) + -- handlePulse p + -- handlePulses + +handlePulse :: Pulse -> NetworkHandler () +handlePulse p@(Pulse _ _ destination) = + do mdl <- gets ((! destination) . _modules) + outGoings <- asks (! destination) + let (mdl', maybeLevel) = processPulse p mdl + modify (\s -> s & modules . ix destination .~ mdl') + tell [p] + case maybeLevel of + Nothing -> return () + Just level' -> + do let newPulses = fmap (Pulse destination level') outGoings + modify (\s -> s & queue %~ (>< (Q.fromList newPulses))) + -- tell newPulses + return () + +processPulse :: Pulse -> Module -> (Module, Maybe Level) +-- processPulse p m | trace ((show p) ++ " " ++ (show m) ) False = undefined +processPulse (Pulse _ l _) Broadcast = (Broadcast, Just l) +processPulse (Pulse _ Low _) (FlipFlop False) = (FlipFlop True, Just High) +processPulse (Pulse _ Low _) (FlipFlop True) = (FlipFlop False, Just Low) +processPulse (Pulse _ High _) (FlipFlop s) = (FlipFlop s, Nothing) +processPulse (Pulse s l _) (Conjunction memory) = + (Conjunction memory', Just outLevel) + where memory' = M.insert s l memory + outLevel = if all (== High) $ M.elems memory' then Low else High +processPulse _ Untyped = (Untyped, Nothing) + + + +assembleNetwork :: [((Module, Name), [Name])] -> (Network, Modules) +assembleNetwork config = (network, modules) + where (network, modules0) = mkNetwork config + modules1 = M.union (mkModules config) modules0 + modules = addConjunctionMemory network modules1 + +mkModules :: [((Module, Name), [Name])] -> Modules +mkModules = M.fromList . fmap (\((m, n), _) -> (n, m)) + +mkNetwork :: [((Module, Name), [Name])] -> (Network, Modules) +mkNetwork config = (net, mods) + where net = M.fromList $ fmap (\((_, n), ds) -> (n, ds)) config + mods = M.fromList $ concatMap (\(_, ds) -> fmap (\d -> (d, Untyped)) ds) config + +addConjunctionMemory :: Network -> Modules -> Modules +addConjunctionMemory network modules = + M.foldlWithKey addMemory modules network + +addMemory :: Modules -> Name -> [Name] -> Modules +addMemory modules source connections = + foldl' (addOneMemory source) modules connections + +addOneMemory :: Name -> Modules -> Name -> Modules +addOneMemory source modules destination = + case modules ! destination of + Conjunction memory -> M.insert destination (Conjunction $ M.insert source Low memory) modules + _ -> modules + + +showDot :: Network -> String +showDot network = + "digraph {\n" ++ (concatMap showDotLine $ M.toList network) ++ "\n}" + where showDotLine (source, destinations) = + concatMap (\d -> source ++ " -> " ++ d ++ ";\n") destinations + + +-- Parse the input file + +configLinesP :: Parser [((Module, Name), [Name])] +configLineP :: Parser ((Module, Name), [Name]) +moduleP, broadcastP, flipFlopP, conjunctionP :: Parser (Module, Name) +-- namesP :: Parser [Name] +nameP :: Parser Name + +configLinesP = configLineP `sepBy` endOfLine +configLineP = (,) <$> (moduleP <* " -> ") <*> (nameP `sepBy` ", ") + +moduleP = broadcastP <|> flipFlopP <|> conjunctionP + +broadcastP = (Broadcast, "broadcaster") <$ "broadcaster" +flipFlopP = (FlipFlop False, ) <$> ("%" *> nameP) +conjunctionP = (Conjunction M.empty, ) <$> ("&" *> nameP) + +-- namesP = nameP `sepBy` ", " +nameP = many1 letter + +successfulParse :: Text -> [((Module, Name), [Name])] +successfulParse input = + case parseOnly configLinesP input of + Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err + Right monkeys -> monkeys -- 2.34.1