src/advent18/advent18concurrent.hs

   1 import Data.Text (Text)
   2 import qualified Data.Text as T
   3 import qualified Data.Text.IO as TIO
   4
   5 import qualified Data.Map.Strict as M
   6 import Data.Map.Strict ((!))
   7
   8 import Control.Monad (when, unless)
   9 import Control.Monad.State.Lazy
  10 import Control.Monad.Reader
  11 import Control.Monad.Writer
  12
  13 import Control.Concurrent.Classy.Chan
  14
  15 import Advent18Parser
  16
  17
  18 type Messages = State (Chan Integer)
  19
  20 data Machine = Machine { registers :: M.Map Char Integer
  21                        , pc :: Int
  22                        , receivedMessages :: Messages
  23                        , sentMessages :: Message
  24                        }
  25                deriving (Show, Eq)
  26
  27 data MachinePair = MachinePair { machine0 :: Machine
  28                                , machine1 :: Machine
  29                                } deriving (Show, Eq)
  30
  31 type ProgrammedMachine = WriterT [String] (ReaderT [Instruction] (State MachinePair)) ()
  32
  33
  34 emptyMachine rq sq = Machine { registers = M.empty, pc = 0
  35                              , receivedMessages = rq
  36                              , sentMessages = sq
  37                              }
  38
  39
  40 emptyMachinePair c01 c10 = MachinePair { machine0 = emptyMachine c10 c01 { registers = M.singleton 'p' 0 }
  41                                        , machine1 = emptyMachine c01 c10 { registers = M.singleton 'p' 1 }
  42                                        }
  43
  44
  45 main :: IO ()
  46 main = do
  47         text <- TIO.readFile "data/advent18.txt"
  48         let instrs = successfulParse text
  49         let ((result, l), statef) = part2 instrs
  50         print $ length l
  51
  52 part2 :: [Instruction] -> (((), [String]), Machine)
  53 part2 instructions =
  54     runState (
  55         runReaderT (
  56             runWriterT executeInstructions
  57                    )
  58             instructions
  59              )
  60              emptyMachine
  61
  62 setupMachines =
  63     do  p0p1 <- newChan
  64         p1p0 <- newChan
  65         let mp = empytMachinePair p0p1 p1p0
  66         put mp
  67
  68
  69
  70 executeInstructions :: ProgrammedMachinePair
  71 executeInstructions =
  72     do  instrs <- ask
  73         m <- get
  74         when (pc m >= 0 && pc m < length instrs)
  75                 $
  76                 do executeInstruction
  77                    executeInstructions
  78
  79 executeInstruction :: Bool -> ProgrammedMachinePair
  80 executeInstruction =
  81     do  instrs <- ask
  82         m <- get
  83         let mq = messageQueue m
  84         let instr = instrs!!(pc m)
  85         let (ma', mq') = applyInstruction instr mq ma
  86         let mb' = mb {messageQueue = mq'}
  87         let mp' = if m0Active then mp {machine0 = ma', machine1 = mb'}
  88                               else mp {machine0 = mb', machine1 = ma'}
  89         put mp'
  90
  91 applyInstruction :: Instruction -> [Integer] -> Machine -> (Machine, [Integer])
  92
  93 applyInstruction (Snd a) other m = (m {pc = pc'}, other ++ [y])
  94     where pc' = pc m + 1
  95           y = evaluate m a
  96
  97 applyInstruction (Set (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
  98     where pc' = pc m + 1
  99           y = evaluate m b
 100           reg' = M.insert a y $ registers m
 101
 102 applyInstruction (Add (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
 103     where pc' = pc m + 1
 104           x = evaluate m (Register a)
 105           y = evaluate m b
 106           reg' = M.insert a (x + y) $ registers m
 107
 108 applyInstruction (Mul (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
 109     where pc' = pc m + 1
 110           x = evaluate m (Register a)
 111           y = evaluate m b
 112           reg' = M.insert a (x * y) $ registers m
 113
 114 applyInstruction (Mod (Register a) b) other  m = (m {registers = reg', pc = pc'}, other)
 115     where pc' = pc m + 1
 116           x = evaluate m (Register a)
 117           y = evaluate m b
 118           reg' = M.insert a (x `mod` y) $ registers m
 119
 120 applyInstruction (Rcv (Register a)) other m = ( m {registers = reg', messageQueue = mq', pc = pc'}, other)
 121     where pc' = pc m + 1
 122           reg' = M.insert a (head $ messageQueue m) $ registers m
 123           mq' = tail $ messageQueue m
 124
 125 applyInstruction (Jgz a b) other m = (m {pc = pc'}, other)
 126     where x = evaluate m a
 127           y = evaluate m b
 128           pc' = if x > 0 then pc m + (fromIntegral y) else pc m + 1
 129
 130 evaluate :: Machine -> Location -> Integer
 131 evaluate _ (Literal i)  = i
 132 evaluate m (Register r) = M.findWithDefault 0 r (registers m)
 133
 134 isReceive :: Instruction -> Bool
 135 isReceive (Rcv _) = True
 136 isReceive _ = False
 137
 138 isSend :: Instruction -> Bool
 139 isSend (Snd _) = True
 140 isSend _ = False