2023-20

inputs/2023/20.txt

@@ -0,0 +1,58 @@
+%cf -> hl, qt
+&bn -> rx
+%nb -> vt
+%hm -> jp
+%vr -> qt, sl
+%gq -> hm, nl
+%sl -> jx, qt
+&pl -> bn
+%hf -> vt, ch
+%kx -> dq
+%fr -> qf
+%rh -> vr
+&vt -> lz, dh, kr, kq, lm, qk
+&dq -> mz, ml, xd, fb, xs, rc, rt
+%hn -> qk, vt
+%bv -> nl
+%jv -> rh, qt
+%kq -> lm
+%nd -> hp
+%gj -> bv, nl
+%lv -> xs, dq
+%ch -> vt, kd
+%sm -> qt, nd
+%nt -> jv
+%qk -> cb
+%jx -> cf
+%hl -> qt, ng
+&qt -> sm, rh, nd, jx, nt, pl
+%bh -> nl, fr
+%kd -> vt, nb
+%gx -> mh, dq
+%hp -> nt, qt
+%rc -> lv
+broadcaster -> kr, zb, sm, xd
+&mz -> bn
+%qf -> rd, nl
+%sk -> nl, bh
+%rb -> nl, sk
+%cb -> hf, vt
+%fb -> rt
+&lz -> bn
+%mh -> dq, kx
+%rt -> mt
+%xd -> dq, fb
+%lm -> hn
+%hh -> vt, dh
+%ml -> ts
+%mt -> rc, dq
+%ts -> gx, dq
+%rd -> nl, gq
+%zb -> nl, rb
+%kr -> hh, vt
+&nl -> fr, zb, hm, zm
+&zm -> bn
+%dh -> kq
+%ng -> qt
+%xs -> ml
+%jp -> nl, gj

solutions/solutions.cabal

@@ -1079,3 +1079,8 @@ executable sln_2023_19
   import:              day
   main-is:             2023/19.hs
   build-depends:       containers
+
+executable sln_2023_20
+  import:              day
+  main-is:             2023/20.hs
+  build-depends:       containers

solutions/src/2023/20.hs

@@ -0,0 +1,98 @@
+{-# Language QuasiQuotes, TemplateHaskell, BangPatterns, BlockArguments, LambdaCase, ImportQualifiedPost #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-|
+Module      : Main
+Description : Day 20 solution
+Copyright   : (c) Eric Mertens, 2023
+License     : ISC
+Maintainer  : [email protected]
+
+<https://adventofcode.com/2023/day/20>
+
+This problem requires you to hack around inside your input file,
+so if this solution doesn't work on yours, you didn't get lucky
+and get a easier case like I did, but I assume we all got the same
+kind of dumb easy case as the last LCM problem this year.
+
+-}
+module Main where
+
+import Advent (format, stageTH)
+import Advent.Queue as Queue
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Set (Set)
+import Data.Set qualified as Set
+
+data K = K_PERCENT | K_AMPERSAND deriving (Eq, Ord, Show)
+
+stageTH
+
+data Kind = Broad | Conj | Flip
+
+-- | Parse the input and print both parts.
+--
+-- >>> :main
+-- 825167435
+-- 225514321828633
+main :: IO ()
+main =
+ do input <- [format|2023 20 ((broadcaster|@K%s) -> %s&(, )%n)*|]
+    let nodes = Map.fromList [matchKind kind conns | (kind, conns) <- input]
+    let conj = Map.fromListWith (++) [(v, [k]) | (k, (_,vs)) <- Map.assocs nodes, v <- vs]    
+
+    let part1 !n !l !h (("button",_,_):_) | n == (1000 :: Int) = l * h :: Int
+        part1 n l h ((src,_,sig):xs) =
+            part1 (if src == "button" then n+1 else n)
+                  (if sig then l else l+1)
+                  (if sig then h+1 else h) xs
+        part1 _ _ _ [] = error "part1 failed"
+
+    print (part1 0 0 0 (sim conj nodes))
+
+    -- This is one of those sad days that you have to look at your own input :(
+    print (part2 conj (sim conj nodes))
+
+
+part2 :: Map String [String] -> [(String, String, Bool)] -> Int
+part2 incoming msgs = foldl1 lcm [buttonsFor 0 dude msgs | dude <- incoming Map.! specialConj]
+  where
+    [specialConj] = incoming Map.! "rx"
+
+    buttonsFor n gate (("button", _, _):xs) = buttonsFor (n+1) gate xs
+    buttonsFor n gate ((src, dst, True):_) | src == gate, dst == specialConj = n
+    buttonsFor n gate (_:xs) = buttonsFor n gate xs
+    buttonsFor _ _ _ = undefined
+
+matchKind :: Maybe (K, String) -> a -> (String, (Kind, a))
+matchKind Nothing xs = ("broadcaster", (Broad, xs))
+matchKind (Just (K_PERCENT, name)) xs = (name, (Flip, xs))
+matchKind (Just (K_AMPERSAND, name)) xs = (name, (Conj, xs))
+
+sim :: Map String [String] -> Map String (Kind, [String]) -> [(String, String, Bool)]
+sim conj conns = go Set.empty Queue.Empty
+  where
+    go st q =
+      case Queue.pop q of
+        Nothing -> go st (Queue.singleton ("button", "broadcaster", False))
+        Just ((src, dst, msg), q') ->
+          (src, dst, msg) :
+          case Map.lookup dst conns of
+            Nothing -> go st q' -- output node, keep going
+            Just (Broad, next) ->
+              go st (appendList q' [(dst, t, msg) | t <- next])
+            Just (Flip, next)
+              | msg -> go st q' -- ignored
+              | otherwise -> -- was on sends low
+                  let active = not (Set.member dst st)
+                      outmsgs = [(dst, t, active) | t <- next]
+                  in go (mark dst active st) (appendList q' outmsgs)
+            Just (Conj, next) ->
+              let st1 = mark (src ++ " " ++ dst) msg st
+                  out = not (and [Set.member (inp ++ " " ++ dst) st1 | inp <- conj Map.! dst])
+                  outmsgs = [(dst, t, out) | t <- next]
+              in go st1 (Queue.appendList q' outmsgs)
+
+mark :: Ord a => a -> Bool -> Set a -> Set a
+mark key True = Set.insert key
+mark key False = Set.delete key