{-# Language ImportQualifiedPost, LambdaCase, MonadComprehensions #-}
{-|
Module      : Main
Description : Day 18 solution
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2017/day/18>

Day 18 defines a simple programming language with arithmetic operations
and asynchronous communication. Our task will be to analyze the behavior
of the send and receive commands performed by these kinds of programs.

This implementation uses the following passes to transform the input
program into a high-level interpretation of the effects of the program
from which we can then easily answer the questions posed.

1. Get input file with 'getInput'
2. Parse the input with 'parser'
3. Compute effects with 'interpreter'
4. Analyze the effects with 'part1' and 'part2'

>>> :main
Just 2951
7366
-}
module Main
  (
  -- * Main drivers
    main
  , part1
  , part2
  , feed

  -- * Interpreter
  -- $interp
  , Effect(..)
  , interpreter

  -- * Parser
  -- $parser
  , Instruction(..)
  , Expression(..)
  , Register(..)
  , instruction
  , register
  , expression
  ) where

import Advent.Input ( getInputLines )
import Advent.ReadS (P(..), runP)
import Control.Applicative ((<|>), empty)
import Data.Char (isAlpha, isDigit)
import Data.Map qualified as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Vector qualified as V
import Text.ParserCombinators.ReadP

-- | Print the solution to both parts of the puzzle. Input file can be
-- overridden via command-line argument.
--
-- >>> :main
-- Just 2951
-- 7366
main :: IO ()
IO ()
main =
  do [Instruction]
pgm <- (String -> Instruction) -> [String] -> [Instruction]
forall a b. (a -> b) -> [a] -> [b]
map (P Instruction -> String -> Instruction
forall a. P a -> String -> a
runP P Instruction
instruction) ([String] -> [Instruction]) -> IO [String] -> IO [Instruction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO [String]
getInputLines Int
2017 Int
18
     let start :: Integer -> Effect
start = [Instruction] -> Integer -> Effect
interpreter [Instruction]
pgm
     Maybe Integer -> IO ()
forall a. Show a => a -> IO ()
print ((Integer -> Effect) -> Maybe Integer
part1 Integer -> Effect
start)
     Int -> IO ()
forall a. Show a => a -> IO ()
print ((Integer -> Effect) -> Int
part2 Integer -> Effect
start)

-- | Compute the last send command that precedes a non-zero receive command.
--
-- >>> :{
-- let pgm = map (runP instruction) $ lines
--           "set a 1\nadd a 2\nmul a a\nmod a 5\nsnd a\nset a 0\n\
--           \rcv a\njgz a -1\nset a 1\njgz a -2\n"
--   in part1 (interpreter pgm)
-- :}
-- Just 4
part1 ::
  (Integer -> Effect) {- ^ program ID to effect         -} ->
  Maybe Integer       {- ^ last non-zero snd before rcv -}
part1 :: (Integer -> Effect) -> Maybe Integer
part1 Integer -> Effect
start = Maybe Integer -> Effect -> Maybe Integer
go Maybe Integer
forall a. Maybe a
Nothing (Integer -> Effect
start Integer
0)
  where
    go :: Maybe Integer -> Effect -> Maybe Integer
    go :: Maybe Integer -> Effect -> Maybe Integer
go Maybe Integer
_ (Send Integer
x Effect
p)    = Maybe Integer -> Effect -> Maybe Integer
go (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
x) Effect
p -- remember last send
    go Maybe Integer
s (Receive Integer
0 Integer -> Effect
p) = Maybe Integer -> Effect -> Maybe Integer
go Maybe Integer
s (Integer -> Effect
p Integer
0)    -- ignore rcv 0, put 0 back
    go Maybe Integer
s (Receive Integer
_ Integer -> Effect
_) = Maybe Integer
s             -- non-zero rcv, we're done
    go Maybe Integer
_ Effect
Halt          = Maybe Integer
forall a. Maybe a
Nothing       -- never found the non-zero rcv!


-- | Run two programs concurrently and count how many sends the second program
-- executes once both programs are blocked.
--
-- >>> :{
-- let pgm = map (runP instruction) $ lines
--           "snd 1\nsnd 2\nsnd p\nrcv a\nrcv b\nrcv c\nrcv d\n"
--   in part2 (interpreter pgm)
-- :}
-- 3
part2 ::
  (Integer -> Effect) {- ^ program ID to effect -} ->
  Int                 {- ^ sends from program 1 -}
part2 :: (Integer -> Effect) -> Int
part2 Integer -> Effect
start = Effect -> Effect -> Int -> Int
go (Integer -> Effect
start Integer
0) (Integer -> Effect
start Integer
1) Int
0
  where
    go :: Effect -> Effect -> Int -> Int
    go :: Effect -> Effect -> Int -> Int
go (Send Integer
o Effect
p0) Effect
p1 Int
ctr = Effect -> Effect -> Int -> Int
go Effect
p0 (Integer -> Effect -> Effect
feed Integer
o Effect
p1) Int
ctr
    go Effect
p0 (Send Integer
o Effect
p1) Int
ctr = Effect -> Effect -> Int -> Int
go (Integer -> Effect -> Effect
feed Integer
o Effect
p0) Effect
p1 (Int
ctrInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    go Effect
_ Effect
_            Int
ctr = Int
ctr


-- | Provide the given 'Integer' argument to the first 'Receive' command in a
-- given effect sequence.
feed :: Integer -> Effect -> Effect
feed :: Integer -> Effect -> Effect
feed Integer
i (Send Integer
o Effect
p)       = Integer -> Effect -> Effect
Send Integer
o (Integer -> Effect -> Effect
feed Integer
i Effect
p)
feed Integer
i (Receive Integer
_ Integer -> Effect
k)    = Integer -> Effect
k Integer
i
feed Integer
_ Effect
Halt             = Effect
Halt

------------------------------------------------------------------------

-- $interp
-- The Interpreter transforms a program from the world of instructions,
-- registers, and program counters into only the effects of interpreting
-- those programs. We'll be able to process these effects in order to answer
-- the questions posed in part 1 and part 2 of this task.

-- | Observable program execution effects
data Effect
  = Halt                -- ^ Execution complete
  | Send Integer Effect -- ^ Send integer, continue
  | Receive Integer (Integer -> Effect)
  -- ^ Receive with original register value and continuation taking new value


-- | Compute the effect of executing a program starting at the first instruction
-- using the given map as the initial set of registers.
interpreter ::
  [Instruction] {- ^ instructions   -} ->
  Integer       {- ^ program ID     -} ->
  Effect        {- ^ program effect -}
interpreter :: [Instruction] -> Integer -> Effect
interpreter [Instruction]
cmds Integer
pid = Int -> Map Register Integer -> Effect
go Int
0 Map Register Integer
initialRegs
  where
    v :: Vector Instruction
v = [Instruction] -> Vector Instruction
forall a. [a] -> Vector a
V.fromList [Instruction]
cmds
    initialRegs :: Map Register Integer
initialRegs = Register -> Integer -> Map Register Integer
forall k a. k -> a -> Map k a
Map.singleton (Char -> Register
Register Char
'p') Integer
pid

    go ::
      Int                  {- ^ program counter -} ->
      Map Register Integer {- ^ registers       -} ->
      Effect               {- ^ program effect  -}
    go :: Int -> Map Register Integer -> Effect
go Int
pc Map Register Integer
regs =
      case Vector Instruction
v Vector Instruction -> Int -> Maybe Instruction
forall a. Vector a -> Int -> Maybe a
V.!? Int
pc of
        Maybe Instruction
Nothing        -> Effect
Halt
        Just (Snd Expression
e  ) -> Integer -> Effect -> Effect
Send    (Expression -> Integer
val Expression
e) (Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Map Register Integer
regs)
        Just (Rcv Register
r  ) -> Integer -> (Integer -> Effect) -> Effect
Receive (Register -> Integer
reg Register
r) (Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Map Register Integer -> Effect)
-> (Integer -> Map Register Integer) -> Integer -> Effect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Register -> Integer -> Map Register Integer
set Register
r)
        Just (Set Register
r Expression
e) -> Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Register -> Integer -> Map Register Integer
set Register
r (Expression -> Integer
val Expression
e))
        Just (Add Register
r Expression
e) -> Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Register -> (Integer -> Integer) -> Map Register Integer
upd Register
r (Expression -> Integer
val Expression
e Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+))
        Just (Mul Register
r Expression
e) -> Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Register -> (Integer -> Integer) -> Map Register Integer
upd Register
r (Expression -> Integer
val Expression
e Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*))
        Just (Mod Register
r Expression
e) -> Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Register -> (Integer -> Integer) -> Map Register Integer
upd Register
r (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Expression -> Integer
val Expression
e))
        Just (Jgz Expression
x Expression
y) -> Int -> Map Register Integer -> Effect
go (Int
pcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
o) Map Register Integer
regs
          where o :: Int
o | Expression -> Integer
val Expression
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Expression -> Integer
val Expression
y)
                  | Bool
otherwise = Int
1
      where
        val :: Expression -> Integer
val (RegisterExpression Register
r) = Register -> Integer
reg Register
r                  -- evaluate register
        val (IntegerExpression  Integer
i) = Integer
i                      -- evaluate literal
        reg :: Register -> Integer
reg Register
r   = Integer -> Register -> Map Register Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Integer
0 Register
r Map Register Integer
regs              -- lookup register
        set :: Register -> Integer -> Map Register Integer
set Register
r Integer
x = Register -> Integer -> Map Register Integer -> Map Register Integer
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Register
r Integer
x Map Register Integer
regs                       -- assign register
        upd :: Register -> (Integer -> Integer) -> Map Register Integer
upd Register
r Integer -> Integer
f = (Maybe Integer -> Maybe Integer)
-> Register -> Map Register Integer -> Map Register Integer
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Maybe Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
f (Integer -> Integer)
-> (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0) Register
r Map Register Integer
regs -- update register

------------------------------------------------------------------------

-- $parser
-- The language defined by this problem is particularly simple and so is
-- its parser. Each instruction can be found on its own line, and tokens
-- in the language are separated by whitespace. Each instruction has one
-- or two operands. Some of these operands need to be register names while
-- others can be an expression composed of either an integer literal or
-- a register name.

-- | Register names: single letters
newtype Register = Register Char
  deriving (ReadPrec [Register]
ReadPrec Register
Int -> ReadS Register
ReadS [Register]
(Int -> ReadS Register)
-> ReadS [Register]
-> ReadPrec Register
-> ReadPrec [Register]
-> Read Register
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Register
readsPrec :: Int -> ReadS Register
$creadList :: ReadS [Register]
readList :: ReadS [Register]
$creadPrec :: ReadPrec Register
readPrec :: ReadPrec Register
$creadListPrec :: ReadPrec [Register]
readListPrec :: ReadPrec [Register]
Read, Int -> Register -> ShowS
[Register] -> ShowS
Register -> String
(Int -> Register -> ShowS)
-> (Register -> String) -> ([Register] -> ShowS) -> Show Register
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Register -> ShowS
showsPrec :: Int -> Register -> ShowS
$cshow :: Register -> String
show :: Register -> String
$cshowList :: [Register] -> ShowS
showList :: [Register] -> ShowS
Show, Register -> Register -> Bool
(Register -> Register -> Bool)
-> (Register -> Register -> Bool) -> Eq Register
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Register -> Register -> Bool
== :: Register -> Register -> Bool
$c/= :: Register -> Register -> Bool
/= :: Register -> Register -> Bool
Eq, Eq Register
Eq Register =>
(Register -> Register -> Ordering)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Register)
-> (Register -> Register -> Register)
-> Ord Register
Register -> Register -> Bool
Register -> Register -> Ordering
Register -> Register -> Register
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 :: Register -> Register -> Ordering
compare :: Register -> Register -> Ordering
$c< :: Register -> Register -> Bool
< :: Register -> Register -> Bool
$c<= :: Register -> Register -> Bool
<= :: Register -> Register -> Bool
$c> :: Register -> Register -> Bool
> :: Register -> Register -> Bool
$c>= :: Register -> Register -> Bool
>= :: Register -> Register -> Bool
$cmax :: Register -> Register -> Register
max :: Register -> Register -> Register
$cmin :: Register -> Register -> Register
min :: Register -> Register -> Register
Ord)

-- | Expressions are either integer literals or register values
data Expression
  = RegisterExpression Register -- ^ read from register
  | IntegerExpression  Integer  -- ^ constant integer
  deriving (ReadPrec [Expression]
ReadPrec Expression
Int -> ReadS Expression
ReadS [Expression]
(Int -> ReadS Expression)
-> ReadS [Expression]
-> ReadPrec Expression
-> ReadPrec [Expression]
-> Read Expression
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Expression
readsPrec :: Int -> ReadS Expression
$creadList :: ReadS [Expression]
readList :: ReadS [Expression]
$creadPrec :: ReadPrec Expression
readPrec :: ReadPrec Expression
$creadListPrec :: ReadPrec [Expression]
readListPrec :: ReadPrec [Expression]
Read, Int -> Expression -> ShowS
[Expression] -> ShowS
Expression -> String
(Int -> Expression -> ShowS)
-> (Expression -> String)
-> ([Expression] -> ShowS)
-> Show Expression
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expression -> ShowS
showsPrec :: Int -> Expression -> ShowS
$cshow :: Expression -> String
show :: Expression -> String
$cshowList :: [Expression] -> ShowS
showList :: [Expression] -> ShowS
Show)

-- | Program instruction
data Instruction
  = Snd Expression            -- ^ @snd e@: send @e@
  | Rcv Register              -- ^ @rcv r@: receive to @r@
  | Set Register Expression   -- ^ @set r e@: @r=e@
  | Add Register Expression   -- ^ @add r e@: @r=r+e@
  | Mul Register Expression   -- ^ @mul r e@: @r=r*e@
  | Mod Register Expression   -- ^ @mod r e@: @r=r%e@
  | Jgz Expression Expression -- ^ @jgz t o@: @if t>0 then pc+=o@
  deriving (ReadPrec [Instruction]
ReadPrec Instruction
Int -> ReadS Instruction
ReadS [Instruction]
(Int -> ReadS Instruction)
-> ReadS [Instruction]
-> ReadPrec Instruction
-> ReadPrec [Instruction]
-> Read Instruction
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Instruction
readsPrec :: Int -> ReadS Instruction
$creadList :: ReadS [Instruction]
readList :: ReadS [Instruction]
$creadPrec :: ReadPrec Instruction
readPrec :: ReadPrec Instruction
$creadListPrec :: ReadPrec [Instruction]
readListPrec :: ReadPrec [Instruction]
Read, Int -> Instruction -> ShowS
[Instruction] -> ShowS
Instruction -> String
(Int -> Instruction -> ShowS)
-> (Instruction -> String)
-> ([Instruction] -> ShowS)
-> Show Instruction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Instruction -> ShowS
showsPrec :: Int -> Instruction -> ShowS
$cshow :: Instruction -> String
show :: Instruction -> String
$cshowList :: [Instruction] -> ShowS
showList :: [Instruction] -> ShowS
Show)

instruction :: P Instruction
instruction :: P Instruction
instruction = ReadS String -> P String
forall a. ReadS a -> P a
P ReadS String
lex P String -> (String -> P Instruction) -> P Instruction
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  String
"snd" -> Expression -> Instruction
Snd (Expression -> Instruction) -> P Expression -> P Instruction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Expression
expression
  String
"rcv" -> Register -> Instruction
Rcv (Register -> Instruction) -> P Register -> P Instruction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
register
  String
"set" -> Register -> Expression -> Instruction
Set (Register -> Expression -> Instruction)
-> P Register -> P (Expression -> Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
register   P (Expression -> Instruction) -> P Expression -> P Instruction
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Expression
expression
  String
"add" -> Register -> Expression -> Instruction
Add (Register -> Expression -> Instruction)
-> P Register -> P (Expression -> Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
register   P (Expression -> Instruction) -> P Expression -> P Instruction
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Expression
expression
  String
"mul" -> Register -> Expression -> Instruction
Mul (Register -> Expression -> Instruction)
-> P Register -> P (Expression -> Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
register   P (Expression -> Instruction) -> P Expression -> P Instruction
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Expression
expression
  String
"mod" -> Register -> Expression -> Instruction
Mod (Register -> Expression -> Instruction)
-> P Register -> P (Expression -> Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
register   P (Expression -> Instruction) -> P Expression -> P Instruction
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Expression
expression
  String
"jgz" -> Expression -> Expression -> Instruction
Jgz (Expression -> Expression -> Instruction)
-> P Expression -> P (Expression -> Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Expression
expression P (Expression -> Instruction) -> P Expression -> P Instruction
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Expression
expression
  String
_     -> P Instruction
forall a. P a
forall (f :: * -> *) a. Alternative f => f a
empty

expression :: P Expression
expression :: P Expression
expression =
  Register -> Expression
RegisterExpression (Register -> Expression) -> P Register -> P Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
register P Expression -> P Expression -> P Expression
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Integer -> Expression
IntegerExpression  (Integer -> Expression) -> P Integer -> P Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadS Integer -> P Integer
forall a. ReadS a -> P a
P ReadS Integer
forall a. Read a => ReadS a
reads

register :: P Register
register :: P Register
register = [Char -> Register
Register Char
c | [Char
c] <- ReadS String -> P String
forall a. ReadS a -> P a
P ReadS String
lex, Char -> Bool
isAlpha Char
c]