{-# Language ViewPatterns, QuasiQuotes, ImportQualifiedPost #-}
{-|
Module      : Main
Description : Day 23 solution
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2019/day/23>

This problem builds a packet network out of 50 concurrently executing
intcode machines. It's implemented by keeping track of the individual
machines, a packet delivery queue, and the most recent NAT packet.
As the system is simulated a list of interesting simulation events is
produced that can be processed to compute the answers to both parts of
the problem.

-}
module Main (main) where

import Advent.Format (format)
import Advent.Queue (Queue((:<|)))
import Advent.Queue qualified as Queue
import Data.IntMap (IntMap)
import Data.IntMap qualified as IntMap
import Intcode (Effect(..), run, new)

-- | >>> :main
-- 22151
-- 17001
main :: IO ()
IO ()
main =
 do [Int]
inp <- [format|2019 23 %d&,%n|]
    let events :: [Event]
events = Effect -> [Event]
startup (Machine -> Effect
run ([Int] -> Machine
new [Int]
inp))
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([Int] -> Int
forall a. HasCallStack => [a] -> a
head     [Int
y | Pkt Bool
_ (Packet Int
255 Int
_ Int
y) <- [Event]
events])
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([Int] -> Int
forall a. Eq a => [a] -> a
firstDup [Int
y | Pkt Bool
True (Packet Int
_ Int
_ Int
y) <- [Event]
events])

-- * Machine effect processing

-- | A bundle of destination and payload data sent on the network.
data Packet = Packet !Int !Int !Int -- ^ destination, x, y
  deriving Int -> Packet -> String -> String
[Packet] -> String -> String
Packet -> String
(Int -> Packet -> String -> String)
-> (Packet -> String)
-> ([Packet] -> String -> String)
-> Show Packet
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Packet -> String -> String
showsPrec :: Int -> Packet -> String -> String
$cshow :: Packet -> String
show :: Packet -> String
$cshowList :: [Packet] -> String -> String
showList :: [Packet] -> String -> String
Show

-- | Deliver the inputs to a machine expecting them, then collect all
-- emitted packets returning a machine once-again waiting for inputs.
resume :: Int -> Int -> Effect -> ([Packet], Effect)
resume :: Int -> Int -> Effect -> ([Packet], Effect)
resume Int
x Int
y (Input (((Int -> Effect) -> Int -> Effect
forall a b. (a -> b) -> a -> b
$ Int
x) -> Input (((Int -> Effect) -> Int -> Effect
forall a b. (a -> b) -> a -> b
$ Int
y) -> Effect
e))) = Effect -> ([Packet], Effect)
gather Effect
e
resume Int
_ Int
_ Effect
_ = String -> ([Packet], Effect)
forall a. HasCallStack => String -> a
error String
"resume: machine out of sync"

-- | Collect all packets the machine is ready to emit returning it to a blocked state.
gather :: Effect -> ([Packet], Effect)
gather :: Effect -> ([Packet], Effect)
gather (Output Int
d (Output Int
x (Output Int
y (Effect -> ([Packet], Effect)
gather -> ([Packet]
ps, Effect
e))))) = (Int -> Int -> Int -> Packet
Packet Int
d Int
x Int
y Packet -> [Packet] -> [Packet]
forall a. a -> [a] -> [a]
: [Packet]
ps, Effect
e)
gather Effect
e = Effect -> ([Packet], Effect)
forall a. a -> ([Packet], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Effect
e

-- * Event loop

-- | Network events needed to answer part 1 and 2.
data Event = Pkt Bool Packet  -- ^ Packet handled. Flag set True when sent due to NAT
  deriving Int -> Event -> String -> String
[Event] -> String -> String
Event -> String
(Int -> Event -> String -> String)
-> (Event -> String) -> ([Event] -> String -> String) -> Show Event
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Event -> String -> String
showsPrec :: Int -> Event -> String -> String
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> String -> String
showList :: [Event] -> String -> String
Show

-- | Start a network of 50 machines given the machine template. Start running
-- by waking all machines with their network IDs. The event stream from running
-- this network is then returned.
startup :: Effect -> [Event]
startup :: Effect -> [Event]
startup Effect
mach = Queue Packet -> Packet -> IntMap Effect -> [Event]
sim
  ([Packet] -> Queue Packet
forall a. [a] -> Queue a
Queue.fromList [Int -> Int -> Int -> Packet
Packet Int
i Int
i (-Int
1) | Int
i <- [Int
0..Int
49]])
  (String -> Packet
forall a. HasCallStack => String -> a
error String
"no NAT packet")
  ([(Int, Effect)] -> IntMap Effect
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int
i, Effect
mach) | Int
i <- [Int
0..Int
49]])

-- | Simulation loop for a running network.
sim ::
  Queue Packet  {- ^ packet delivery queue   -} ->
  Packet        {- ^ most recently stored NAT -} ->
  IntMap Effect {- ^ machines on the network -} ->
  [Event]       {- ^ simulation event stream -}
sim :: Queue Packet -> Packet -> IntMap Effect -> [Event]
sim (Packet
p :<| Queue Packet
q) Packet
nat IntMap Effect
net = Bool -> Packet -> Event
Pkt Bool
False Packet
p  Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: Queue Packet -> Packet -> Packet -> IntMap Effect -> [Event]
deliver Queue Packet
q Packet
nat Packet
p   IntMap Effect
net
sim Queue Packet
q         Packet
nat IntMap Effect
net = Bool -> Packet -> Event
Pkt Bool
True Packet
nat Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: Queue Packet -> Packet -> Packet -> IntMap Effect -> [Event]
deliver Queue Packet
q Packet
nat Packet
nat IntMap Effect
net

-- | Helper for 'sim' that delivers a packet to the network.
deliver :: Queue Packet -> Packet {- ^ NAT -} -> Packet {- ^ current -} -> IntMap Effect -> [Event]
deliver :: Queue Packet -> Packet -> Packet -> IntMap Effect -> [Event]
deliver Queue Packet
q Packet
nat (Packet Int
d Int
x Int
y) IntMap Effect
net
  | Int
255 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
d                                 = Queue Packet -> Packet -> IntMap Effect -> [Event]
sim Queue Packet
q (Int -> Int -> Int -> Packet
Packet Int
0 Int
x Int
y) IntMap Effect
net
  | ([Packet]
ps, IntMap Effect
net') <- Int
-> (Effect -> ([Packet], Effect))
-> IntMap Effect
-> ([Packet], IntMap Effect)
forall (f :: * -> *) a.
Applicative f =>
Int -> (a -> f a) -> IntMap a -> f (IntMap a)
updateF Int
d (Int -> Int -> Effect -> ([Packet], Effect)
resume Int
x Int
y) IntMap Effect
net = Queue Packet -> Packet -> IntMap Effect -> [Event]
sim (Queue Packet -> [Packet] -> Queue Packet
forall a. Queue a -> [a] -> Queue a
Queue.appendList Queue Packet
q [Packet]
ps) Packet
nat IntMap Effect
net'

-- * Utilities

-- | Traversal for an element in an 'IntMap'.
updateF :: Applicative f => Int -> (a -> f a) -> IntMap a -> f (IntMap a)
updateF :: forall (f :: * -> *) a.
Applicative f =>
Int -> (a -> f a) -> IntMap a -> f (IntMap a)
updateF Int
i a -> f a
f = (Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF ((a -> f a) -> Maybe a -> f (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse a -> f a
f) Int
i

-- | Find the first value that occurs twice in a row in a list.
--
-- >>> firstDup [1,2,3,2,1,2,5,5,3,2,1]
-- 5
firstDup :: Eq a => [a] -> a
firstDup :: forall a. Eq a => [a] -> a
firstDup [a]
ys = [a] -> a
forall a. HasCallStack => [a] -> a
head [a
a | (a
a,a
b) <- [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ys ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
ys), a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
b]