1 {-# LANGUAGE NegativeLiterals #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE TypeFamilies #-}
6 import Data.Text (Text)
7 import qualified Data.Text as T
8 import qualified Data.Text.IO as TIO
10 import qualified Data.Map.Strict as M
11 import Data.Map.Strict ((!))
13 import Control.Monad (when, unless)
14 import Control.Monad.State.Lazy
15 import Control.Monad.Reader
16 import Control.Monad.Writer
21 data Machine = Machine { registers :: M.Map Char Integer
23 , messageQueue :: [Integer]
27 data MachinePair = MachinePair { machine0 :: Machine
31 type ProgrammedMachinePair = WriterT [String] (ReaderT [Instruction] (State MachinePair)) ()
34 emptyMachine = Machine {registers = M.empty, messageQueue = [], pc = 0}
36 emptyMachinePair = MachinePair { machine0 = emptyMachine {registers = M.singleton 'p' 0}
37 , machine1 = emptyMachine {registers = M.singleton 'p' 1}
42 text <- TIO.readFile "data/advent18.txt"
43 let instrs = successfulParse text
44 let ((result, l), statef) = part2 instrs
47 part2 :: [Instruction] -> (((), [String]), MachinePair)
51 runWriterT executeInstructions
57 executeInstructions :: ProgrammedMachinePair
63 let instr0 = instrs !! pc m0
64 let m0Blocked = isReceive instr0 && null (messageQueue m0)
65 let instr1 = instrs !! pc m1
66 let m1Blocked = isReceive instr1 && null (messageQueue m1)
67 let (ma, mb) = if m0Blocked then (m1, m0) else (m0, m1)
69 unless (m0Blocked && m1Blocked)
71 when (pc ma >= 0 && pc ma < length instrs)
73 do let m0Active = not m0Blocked
74 when (m0Blocked && isSend instr1) (tell ["sending: " ++ show mp])
75 executeInstruction m0Active
78 executeInstruction :: Bool -> ProgrammedMachinePair
79 executeInstruction m0Active =
82 let (ma, mb) = if m0Active
83 then (machine0 mp, machine1 mp)
84 else (machine1 mp, machine0 mp)
85 let mq = messageQueue mb
86 let instr = instrs!!(pc ma)
87 let (ma', mq') = applyInstruction instr mq ma
88 let mb' = mb {messageQueue = mq'}
89 let mp' = if m0Active then mp {machine0 = ma', machine1 = mb'}
90 else mp {machine0 = mb', machine1 = ma'}
92 applyInstruction :: Instruction -> [Integer] -> Machine -> (Machine, [Integer])
94 -- applyInstruction (Snd a) other m = (m {registers = reg', pc = pc'}, other ++ [y])
95 -- where pc' = pc m + 1
97 -- sentCount = evaluate m (Register 'x')
98 -- reg' = M.insert 'x' (sentCount + 1) $ registers m
99 applyInstruction (Snd a) other m = (m {pc = pc'}, other ++ [y])
103 applyInstruction (Set (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
106 reg' = M.insert a y $ registers m
108 applyInstruction (Add (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
110 x = evaluate m (Register a)
112 reg' = M.insert a (x + y) $ registers m
114 applyInstruction (Mul (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
116 x = evaluate m (Register a)
118 reg' = M.insert a (x * y) $ registers m
120 applyInstruction (Mod (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
122 x = evaluate m (Register a)
124 reg' = M.insert a (x `mod` y) $ registers m
126 applyInstruction (Rcv (Register a)) other m = ( m {registers = reg', messageQueue = mq', pc = pc'}, other)
128 reg' = M.insert a (head $ messageQueue m) $ registers m
129 mq' = tail $ messageQueue m
131 applyInstruction (Jgz a b) other m = (m {pc = pc'}, other)
132 where x = evaluate m a
134 pc' = if x > 0 then pc m + (fromIntegral y) else pc m + 1
136 evaluate :: Machine -> Location -> Integer
137 evaluate _ (Literal i) = i
138 evaluate m (Register r) = M.findWithDefault 0 r (registers m)
140 isReceive :: Instruction -> Bool
141 isReceive (Rcv _) = True
144 isSend :: Instruction -> Bool
145 isSend (Snd _) = True