--- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-11/
+-- Writeup at https://work.njae.me.uk/2023/12/25/advent-of-code-2023-day-20/
import Debug.Trace
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
+import Data.Function (on)
type Name = String
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
+ print $ part2 network modules
-part1 :: Network -> Modules -> Int
-part1 network modules = highs * lows
- where (highs, lows) = manyButtonPress 1000 (0, 0) network state0
+part1, part2 :: Network -> Modules -> Int
+part1 network modules = highs * lows
+ where (_, (highs, lows)) =
+ (!! 1000) $ iterate (pressAndEvaluate network part1Extractor) (state0, (0, 0))
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
+part2 network modules = foldl' lcm 1 cycleLengths
+ where (_, lxPulses) =
+ (!! 10000) $ iterate (pressAndEvaluate network part2Extractor) (state0, [(0, [])])
+ state0 = NetworkState modules Q.empty
+ lxHighs = filter (not . null . snd) lxPulses
+ cycleLengths = fmap ((fst . head) . sort) $
+ groupBy ((==) `on` (_source . snd)) $
+ sortBy (compare `on` (\(_, p) -> p ^. source)) $
+ fmap (\(n, ps) -> (n, head ps)) lxHighs
+
+pressAndEvaluate :: Network -> (a -> [Pulse] -> a) -> (NetworkState, a) -> (NetworkState, a)
+pressAndEvaluate network resultExtractor (state0, result0) = (state1, result1)
+ where (state1, pulses) = buttonPress network state0
+ result1 = resultExtractor result0 pulses
+
+part1Extractor :: (Int, Int) -> [Pulse] -> (Int, Int)
+part1Extractor (highs, lows) pulses = (highs + length hs, lows + length ls)
+ where (hs, ls) = partition ((== High) . _level) pulses
+
+part2Extractor :: [(Int, [Pulse])] -> [Pulse] -> [(Int, [Pulse])]
+part2Extractor allRs@((i, _):rs) pulses = (i + 1, lxPulses) : allRs
+ where lxPulses = filter catchLx pulses
+ catchLx (Pulse _ High "lx") = True
+ catchLx _ = False
buttonPress :: Network -> NetworkState -> (NetworkState, [Pulse])
buttonPress network state =
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
+ case pulses of
+ Q.Empty -> return ()
+ (p :<| ps) ->
+ do modify (\s -> s & queue .~ ps)
+ handlePulse p
+ handlePulses
handlePulse :: Pulse -> NetworkHandler ()
handlePulse p@(Pulse _ _ destination) =
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
outLevel = if all (== High) $ M.elems memory' then Low else High
processPulse _ Untyped = (Untyped, Nothing)
-
+-- Assemble the network
assembleNetwork :: [((Module, Name), [Name])] -> (Network, Modules)
assembleNetwork config = (network, modules)
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
+mkModules :: [((Module, Name), [Name])] -> Modules
+mkModules = M.fromList . fmap (\((m, n), _) -> (n, m))
+
addConjunctionMemory :: Network -> Modules -> Modules
addConjunctionMemory network modules =
M.foldlWithKey addMemory modules network
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
+ 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])]
projects / advent-of-code-23.git / blobdiff