From 603626268a850cf5e6a3d6dec6051e8196b8708f Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Sun, 30 Jun 2024 22:56:25 +0200 Subject: 2023-20 part 1 in haskell --- 2023/20-Pulse_Propagation/example | 5 ++ 2023/20-Pulse_Propagation/example2 | 5 ++ 2023/20-Pulse_Propagation/first.hs | 120 +++++++++++++++++++++++++++++++++++++ 2023/20-Pulse_Propagation/input | 58 ++++++++++++++++++ 4 files changed, 188 insertions(+) create mode 100644 2023/20-Pulse_Propagation/example create mode 100644 2023/20-Pulse_Propagation/example2 create mode 100644 2023/20-Pulse_Propagation/first.hs create mode 100644 2023/20-Pulse_Propagation/input diff --git a/2023/20-Pulse_Propagation/example b/2023/20-Pulse_Propagation/example new file mode 100644 index 0000000..2dc1bab --- /dev/null +++ b/2023/20-Pulse_Propagation/example @@ -0,0 +1,5 @@ +broadcaster -> a, b, c +%a -> b +%b -> c +%c -> inv +&inv -> a diff --git a/2023/20-Pulse_Propagation/example2 b/2023/20-Pulse_Propagation/example2 new file mode 100644 index 0000000..2738ceb --- /dev/null +++ b/2023/20-Pulse_Propagation/example2 @@ -0,0 +1,5 @@ +broadcaster -> a +%a -> inv, con +&inv -> b +%b -> con +&con -> output diff --git a/2023/20-Pulse_Propagation/first.hs b/2023/20-Pulse_Propagation/first.hs new file mode 100644 index 0000000..c43e332 --- /dev/null +++ b/2023/20-Pulse_Propagation/first.hs @@ -0,0 +1,120 @@ +-- requires cabal install --lib megaparsec parser-combinators heap vector +module Main (main) where + +import Control.Applicative.Permutations +import Control.Monad (void, when) +import qualified Data.Char as C +import Data.Either +import Data.Functor +import qualified Data.Heap as H +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char + +import Debug.Trace + +exampleExpectedOutput = 32000000 +example2ExpectedOutput = 11687500 +data Pulse = Low | High deriving (Eq, Show) +data Module = Normal | FlipFlop Bool | Conjunction (M.Map String Pulse) | Broadcaster deriving (Eq, Show) +data Configuration = Configuration Module String [String] deriving (Eq, Show) +type Conf = (Module, [String]) +type Input = M.Map String Conf + +type Parser = Parsec Void String + +parseModule :: Parser Module +parseModule = char '%' $> FlipFlop False + <|> char '&' $> Conjunction M.empty + <|> lookAhead (string "broadcaster") $> Broadcaster + <|> lookAhead letterChar $> Normal + +parseLabel :: Parser String +parseLabel = some letterChar + +parseConfiguration :: Parser Configuration +parseConfiguration = Configuration <$> parseModule + <*> parseLabel <* string " -> " + <*> some (parseLabel <* optional (string ", ")) + +parseInput' :: Parser Input +parseInput' = M.fromList . map (\(Configuration m s l) -> (s, (m, l))) <$> some (parseConfiguration <* eol) <* eof + +parseInput :: String -> IO Input +parseInput filename = do + input <- readFile filename + case runParser parseInput' filename input of + Left bundle -> error $ errorBundlePretty bundle + Right input' -> return input' + +compute :: Input -> Int +compute input = let (x, y) = computeX 1000 (0, 0) $ initConjuctions input in x * y + where + computeX :: Int -> (Int, Int) -> Input -> (Int, Int) + computeX 0 n _ = n + computeX i n input = let (n', input') = compute' (1, 0) [("button", Low, "broadcaster")] input + in computeX (i-1) (scoreAdd n n') input' + compute' :: (Int, Int) -> [(String, Pulse, String)] -> Input -> ((Int, Int), Input) + compute' n [] input = (n, input) + compute' n signals input | length stepAll == 0 = (n, input) + | otherwise = compute' (scoreAdd n $ score stepAll) stepAll alterAll + where + alterAll :: Input + alterAll = L.foldl' alterOne input signals + alterOne :: Input -> (String, Pulse, String) -> Input + alterOne acc (prev, p, me) = alter p prev me acc (M.lookup me input) + alter :: Pulse -> String -> String -> Input -> Maybe Conf -> Input + alter _ _ _ input (Just (Normal, _)) = input + alter High _ _ input (Just (FlipFlop _, _)) = input + alter Low _ me input (Just (FlipFlop False, l)) = M.insert me (FlipFlop True, l) input + alter Low _ me input (Just (FlipFlop True, l)) = M.insert me (FlipFlop False, l) input + alter p prev me input (Just (Conjunction m, l)) = M.insert me (Conjunction $ M.insert prev p m, l) input + alter p _ _ input (Just (Broadcaster, l)) = input + alter _ _ _ input Nothing = input + score :: [(String, Pulse, String)] -> (Int, Int) + score = L.foldl' scoreOne (0, 0) + scoreOne :: (Int, Int) -> (String, Pulse, String) -> (Int, Int) + scoreOne (x, y) (_, Low, _) = (x + 1, y) + scoreOne (x, y) (_, High, _) = (x, y + 1) + stepAll :: [(String, Pulse, String)] + stepAll = L.foldl' stepOne [] signals + stepOne :: [(String, Pulse, String)] -> (String, Pulse, String) -> [(String, Pulse, String)] + stepOne acc (prev, p, s) = step p prev s acc (M.lookup s input) + step :: Pulse -> String -> String -> [(String, Pulse, String)] -> Maybe Conf -> [(String, Pulse, String)] + step _ _ _ acc (Just (Normal, _)) = acc + step High _ _ acc (Just (FlipFlop _, _)) = acc + step Low _ me acc (Just (FlipFlop False, l)) = acc ++ map (set me High) l + step Low _ me acc (Just (FlipFlop True, l)) = acc ++ map (set me Low) l + step p prev me acc (Just (Conjunction m, l)) = let p2 = if length (M.filter (\x -> x == High) $ M.insert prev p m) == length m then Low else High + in acc ++ map (set me p2) l + step p _ me acc (Just (Broadcaster, l)) = acc ++ map (set me p) l + step _ _ _ acc Nothing = acc + initConjuctions :: Input -> Input + initConjuctions input = let r = M.foldrWithKey initConf input input in r + initConf :: String -> Conf -> Input -> Input + initConf c (_, l) input = L.foldl' initOne input l + where + initOne :: Input -> String -> Input + initOne input s = case M.lookup s input of + Just (Conjunction m, l) -> M.insert s (Conjunction (M.insert c Low m), l) input + _ -> input + scoreAdd (x, y) (x', y') = (x + x', y + y') + set :: String -> Pulse -> String -> (String, Pulse, String) + set me p s = (me, p, s) + +main :: IO () +main = do + example <- parseInput "example" + let exampleOutput = compute example + when (exampleOutput /= exampleExpectedOutput) (error $ "example failed: got " ++ show exampleOutput ++ " instead of " ++ show exampleExpectedOutput) + example2 <- parseInput "example2" + let example2Output = compute example2 + when (example2Output /= example2ExpectedOutput) (error $ "example2 failed: got " ++ show example2Output ++ " instead of " ++ show example2ExpectedOutput) + input <- parseInput "input" + print $ compute input diff --git a/2023/20-Pulse_Propagation/input b/2023/20-Pulse_Propagation/input new file mode 100644 index 0000000..32d7954 --- /dev/null +++ b/2023/20-Pulse_Propagation/input @@ -0,0 +1,58 @@ +%bz -> rb, mf +%tn -> kb, md +broadcaster -> nr, tn, bx, nx +%jp -> ps +&kc -> rx +%dh -> kb, lt +%lt -> cq, kb +%ps -> mf, fh +%sr -> nh, jh +%jg -> tv +%bx -> fd, jg +%kg -> fd, lg +%fh -> dp +%hv -> mf, bz +%mj -> zv +%rz -> gq, mf +%tc -> td +%bl -> fd +%lg -> fd, qj +%gq -> hc, mf +%kh -> ck +%td -> kb, bm +%cq -> kx, kb +%zv -> tk +&nh -> kh, zv, tk, mj, nx, qm, ph +%tk -> mc +%nr -> jp, mf +%bt -> rz +%dj -> nh, qm +%qt -> gb, fd +%rb -> mf +&ph -> kc +%dp -> bt, mf +&kb -> hn, md, tc, tn, mr +%gb -> fd, qs +&vn -> kc +%rt -> kg, fd +%ck -> nh, sr +%qx -> rt, fd +%jh -> pt, nh +%mr -> rs +%nx -> nh, dj +%qm -> mj +&fd -> bx, kt, jg +%rs -> kb, dh +%bm -> kb, mr +%tv -> qx, fd +%pt -> nh +%qj -> qt, fd +%kx -> kb +%qs -> bl, fd +%md -> hh +%hh -> tc, kb +%mc -> kh, nh +%hc -> hv +&kt -> kc +&mf -> fh, vn, bt, hc, nr, jp +&hn -> kc -- cgit v1.2.3