Done day 20 part 1

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index a731ac852a71821ca04e77b12cb18482d1fa09e9..08ab63c4a552c068489e2e1190444cc33310855d 100644 (file)
--- 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 (file)
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