{-# Language QuasiQuotes, TemplateHaskell, BlockArguments, BangPatterns, LambdaCase, ImportQualifiedPost #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-|
Module      : Main
Description : Day 20 solution
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

<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.


>>> :{
describe :: Int -> Outcome -> String
describe n (Send src dst msg o) =
  src ++ " -" ++ (if msg then "high" else "low") ++ "-> " ++
  dst ++ "\n" ++ describe n o
describe 0 (Stall _  ) = ""
describe n (Stall net) = describe (n - 1) (sim net)
:}

>>> putStr (describe 3 (sim (snd (build (parseInput "broadcaster -> a\n%a -> inv, con\n&inv -> b\n%b -> con\n&con -> output\n")))))
button -low-> broadcaster
broadcaster -low-> a
a -high-> inv
a -high-> con
inv -low-> b
con -high-> output
b -high-> con
con -low-> output
button -low-> broadcaster
broadcaster -low-> a
a -low-> inv
a -low-> con
inv -high-> b
con -high-> output
button -low-> broadcaster
broadcaster -low-> a
a -high-> inv
a -high-> con
inv -low-> b
con -low-> output
b -low-> con
con -high-> output
button -low-> broadcaster
broadcaster -low-> a
a -low-> inv
a -low-> con
inv -high-> b
con -high-> output

-}
module Main (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

-- | Kind sigil
data K = K | K_PERCENT | K_AMPERSAND
  deriving (K -> K -> Bool
(K -> K -> Bool) -> (K -> K -> Bool) -> Eq K
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: K -> K -> Bool
== :: K -> K -> Bool
$c/= :: K -> K -> Bool
/= :: K -> K -> Bool
Eq, Eq K
Eq K =>
(K -> K -> Ordering)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> K)
-> (K -> K -> K)
-> Ord K
K -> K -> Bool
K -> K -> Ordering
K -> K -> K
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: K -> K -> Ordering
compare :: K -> K -> Ordering
$c< :: K -> K -> Bool
< :: K -> K -> Bool
$c<= :: K -> K -> Bool
<= :: K -> K -> Bool
$c> :: K -> K -> Bool
> :: K -> K -> Bool
$c>= :: K -> K -> Bool
>= :: K -> K -> Bool
$cmax :: K -> K -> K
max :: K -> K -> K
$cmin :: K -> K -> K
min :: K -> K -> K
Ord, Int -> K -> ShowS
[K] -> ShowS
K -> String
(Int -> K -> ShowS) -> (K -> String) -> ([K] -> ShowS) -> Show K
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> K -> ShowS
showsPrec :: Int -> K -> ShowS
$cshow :: K -> String
show :: K -> String
$cshowList :: [K] -> ShowS
showList :: [K] -> ShowS
Show)

data Node
  = Broadcast                      [String] -- ^ broadcast node
  | FlipFlop !Bool                 [String] -- ^ flip-flop
  | Conjunction !Int !(Set String) [String] -- ^ conjunction gate
  deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show)

data Outcome = Send String String Bool Outcome | Stall (Map String Node)
  deriving Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
(Int -> Outcome -> ShowS)
-> (Outcome -> String) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Outcome -> ShowS
showsPrec :: Int -> Outcome -> ShowS
$cshow :: Outcome -> String
show :: Outcome -> String
$cshowList :: [Outcome] -> ShowS
showList :: [Outcome] -> ShowS
Show

stageTH

[format|(@K%a+ -> %a+&(, )%n)*|]

-- | Parse the input and print both parts.
--
-- >>> :main
-- 825167435
-- 225514321828633
main :: IO ()
IO ()
main =
 do (incoming, nodes) <- Input -> (Map String [String], Map String Node)
build (Input -> (Map String [String], Map String Node))
-> IO Input -> IO (Map String [String], Map String Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO Input
getInput Int
2023 Int
20
    print (part1 nodes)
    print (part2 incoming nodes)

build :: [(K, String, [String])] -> (Map String [String], Map String Node)
build :: Input -> (Map String [String], Map String Node)
build Input
input = (Map String [String]
incoming, Map String Node
nodes)
  where
    incoming :: Map String [String]
incoming = ([String] -> [String] -> [String])
-> [(String, [String])] -> Map String [String]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) [(String
k, [String
v]) | (K
_, String
v, [String]
ks) <- Input
input, String
k <- [String]
ks]
    nodes :: Map String Node
nodes = [(String, Node)] -> Map String Node
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
name, Map String [String] -> String -> K -> [String] -> Node
node Map String [String]
incoming String
name K
kind [String]
conns) | (K
kind, String
name, [String]
conns) <- Input
input]

node :: Map String [String] -> String -> K -> [String] -> Node
node :: Map String [String] -> String -> K -> [String] -> Node
node Map String [String]
incoming String
name = \case
  K
K           -> [String] -> Node
Broadcast
  K
K_AMPERSAND -> Int -> Set String -> [String] -> Node
Conjunction ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> String -> Map String [String] -> [String]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
name Map String [String]
incoming)) Set String
forall a. Set a
Set.empty
  K
K_PERCENT   -> Bool -> [String] -> Node
FlipFlop Bool
True

part1 :: Map String Node -> Int
part1 :: Map String Node -> Int
part1 = Int -> Int -> Int -> Outcome -> Int
forall {t} {t}. (Eq t, Num t, Num t) => t -> t -> t -> Outcome -> t
go (Int
1 :: Int) Int
0 Int
0 (Outcome -> Int)
-> (Map String Node -> Outcome) -> Map String Node -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Node -> Outcome
sim
  where
    go :: t -> t -> t -> Outcome -> t
go t
1000 t
l t
h (Stall Map String Node
_        ) = t
l t -> t -> t
forall a. Num a => a -> a -> a
* t
h
    go t
n    t
l t
h (Stall Map String Node
net      ) = t -> t -> t -> Outcome -> t
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) t
l t
h (Map String Node -> Outcome
sim Map String Node
net)
    go t
n    t
l t
h (Send String
_ String
_ Bool
sig Outcome
xs) =
      t -> t -> t -> Outcome -> t
go t
n (if Bool
sig then t
l else t
lt -> t -> t
forall a. Num a => a -> a -> a
+t
1) (if Bool
sig then t
ht -> t -> t
forall a. Num a => a -> a -> a
+t
1 else t
h) Outcome
xs

part2 :: Map String [String] -> Map String Node -> Int
part2 :: Map String [String] -> Map String Node -> Int
part2 Map String [String]
incoming = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Integral a => a -> a -> a
lcm Int
1 ([Int] -> Int)
-> (Map String Node -> [Int]) -> Map String Node -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Set String -> Outcome -> [Int]
forall {a}. Num a => a -> Set String -> Outcome -> [a]
go Int
1 Set String
gates0 (Outcome -> [Int])
-> (Map String Node -> Outcome) -> Map String Node -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Node -> Outcome
sim
  where
    [String
conj] = Map String [String]
incoming Map String [String] -> String -> [String]
forall k a. Ord k => Map k a -> k -> a
Map.! String
"rx"

    -- all the gates feeding into @conj@
    gates0 :: Set String
gates0 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> String -> Map String [String] -> [String]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
conj Map String [String]
incoming)

    -- finds the first button count for each gate in gates
    go :: a -> Set String -> Outcome -> [a]
go a
_ Set String
gates Outcome
_ | Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
gates = []
    go a
n Set String
gates (Stall Map String Node
net) = a -> Set String -> Outcome -> [a]
go (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) Set String
gates (Map String Node -> Outcome
sim Map String Node
net)
    go a
n Set String
gates (Send String
src String
dst Bool
msg Outcome
xs)
      | Bool
msg, String
dst String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
conj, String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
src Set String
gates = a
n a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> Set String -> Outcome -> [a]
go a
n (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
src Set String
gates) Outcome
xs
      | Bool
otherwise = a -> Set String -> Outcome -> [a]
go a
n Set String
gates Outcome
xs

-- | Generate a stream of messages generated by this network initiated by
-- pressing the button and running until there are no more messages
sim :: Map String Node -> Outcome
sim :: Map String Node -> Outcome
sim = String
-> String
-> Bool
-> Queue (String, String, Bool)
-> Map String Node
-> Outcome
dispatch String
"button" String
"broadcaster" Bool
False Queue (String, String, Bool)
forall a. Queue a
Queue.Empty
  where
    go :: Queue (String, String, Bool) -> Map String Node -> Outcome
go ((String
src, String
dst, Bool
msg) Queue.:<| Queue (String, String, Bool)
q) = String
-> String
-> Bool
-> Queue (String, String, Bool)
-> Map String Node
-> Outcome
dispatch String
src String
dst Bool
msg Queue (String, String, Bool)
q
    go Queue (String, String, Bool)
Queue.Empty                   = Map String Node -> Outcome
Stall

    -- Dispatch msg from src to dst
    dispatch :: String
-> String
-> Bool
-> Queue (String, String, Bool)
-> Map String Node
-> Outcome
dispatch String
src String
dst Bool
msg Queue (String, String, Bool)
q Map String Node
st =
      String -> String -> Bool -> Outcome -> Outcome
Send String
src String
dst Bool
msg
      case String -> Map String Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
dst Map String Node
st of

        -- broadcast: just forward message to nexts
        Just (Broadcast [String]
next) -> Bool -> [String] -> Map String Node -> Outcome
send Bool
msg [String]
next Map String Node
st

        -- flipflop: on low, toggle state and send to nexts
        Just (FlipFlop Bool
mode [String]
next)
          | Bool -> Bool
not Bool
msg -> Bool -> [String] -> Map String Node -> Outcome
send Bool
mode [String]
next Map String Node
st' -- was on sends low
          where
            st' :: Map String Node
st' = String -> Node -> Map String Node -> Map String Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
dst (Bool -> [String] -> Node
FlipFlop (Bool -> Bool
not Bool
mode) [String]
next) Map String Node
st

        -- conjunction: remember incoming value, transmit nand
        Just (Conjunction Int
sz Set String
inc [String]
next) -> Bool -> [String] -> Map String Node -> Outcome
send Bool
out [String]
next Map String Node
st'
          where
            inc' :: Set String
inc' = (if Bool
msg then String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert else String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete) String
src Set String
inc
            st' :: Map String Node
st'  = String -> Node -> Map String Node -> Map String Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
dst (Int -> Set String -> [String] -> Node
Conjunction Int
sz Set String
inc' [String]
next) Map String Node
st
            out :: Bool
out  = Int
sz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Set String -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set String
inc'

        -- output node or flipflop on high: ignored
        Maybe Node
_ -> Queue (String, String, Bool) -> Map String Node -> Outcome
go Queue (String, String, Bool)
q Map String Node
st
      where
        send :: Bool -> [String] -> Map String Node -> Outcome
send Bool
msg' [String]
next = Queue (String, String, Bool) -> Map String Node -> Outcome
go (Queue (String, String, Bool)
-> [(String, String, Bool)] -> Queue (String, String, Bool)
forall a. Queue a -> [a] -> Queue a
Queue.appendList Queue (String, String, Bool)
q [(String
dst, String
t, Bool
msg') | String
t <- [String]
next])