src/advent18/advent18b.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5
   6 import Data.Text (Text)
   7 import qualified Data.Text as T
   8 import qualified Data.Text.IO as TIO
   9
  10 import qualified Data.Map.Strict as M
  11 import Data.Map.Strict ((!))
  12
  13 import Control.Monad (when, unless)
  14 import Control.Monad.State.Lazy
  15 import Control.Monad.Reader
  16 import Control.Monad.Writer
  17
  18 import Advent18Parser
  19
  20
  21 data Machine = Machine { registers :: M.Map Char Integer
  22                        , pc :: Int
  23                        , messageQueue :: [Integer]
  24                        }
  25                deriving (Show, Eq)
  26
  27 data MachinePair = MachinePair { machine0 :: Machine
  28                                , machine1 :: Machine
  29                                } deriving (Show, Eq)
  30
  31 type ProgrammedMachinePair = WriterT [String] (ReaderT [Instruction] (State MachinePair)) ()
  32
  33
  34 emptyMachine = Machine {registers = M.empty, messageQueue = [], pc = 0}
  35
  36 emptyMachinePair = MachinePair { machine0 = emptyMachine {registers = M.singleton 'p' 0}
  37                                , machine1 = emptyMachine {registers = M.singleton 'p' 1}
  38                                }
  39
  40 main :: IO ()
  41 main = do
  42         text <- TIO.readFile "data/advent18.txt"
  43         let instrs = successfulParse text
  44         let ((result, l), statef) = part2 instrs
  45         print $ length l
  46
  47 part2 :: [Instruction] -> (((), [String]), MachinePair)
  48 part2 instructions =
  49     runState (
  50         runReaderT (
  51             runWriterT executeInstructions
  52                    )
  53             instructions
  54              )
  55              emptyMachinePair
  56
  57 executeInstructions :: ProgrammedMachinePair
  58 executeInstructions =
  59     do  instrs <- ask
  60         mp <- get
  61         let m0 = machine0 mp
  62         let m1 = machine1 mp
  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)
  68
  69         unless (m0Blocked && m1Blocked)
  70             $
  71             when (pc ma >= 0 && pc ma < length instrs)
  72                 $
  73                 do let m0Active = not m0Blocked
  74                    when (m0Blocked && isSend instr1) (tell ["sending: " ++ show mp])
  75                    executeInstruction m0Active
  76                    executeInstructions
  77
  78 executeInstruction :: Bool -> ProgrammedMachinePair
  79 executeInstruction m0Active =
  80     do  instrs <- ask
  81         mp <- get
  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'}
  91         put mp'
  92 applyInstruction :: Instruction -> [Integer] -> Machine -> (Machine, [Integer])
  93
  94 -- applyInstruction (Snd a) other m = (m {registers = reg', pc = pc'}, other ++ [y])
  95 --     where pc' = pc m + 1
  96 --           y = evaluate m a
  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])
 100     where pc' = pc m + 1
 101           y = evaluate m a
 102
 103 applyInstruction (Set (Register a) b) other m = (m {registers = reg', pc = pc'}, other)
 104     where pc' = pc m + 1
 105           y = evaluate m b
 106           reg' = M.insert a y $ registers m
 107
 108 applyInstruction (Add (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 (Mul (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 * y) $ registers m
 119
 120 applyInstruction (Mod (Register a) b) other  m = (m {registers = reg', pc = pc'}, other)
 121     where pc' = pc m + 1
 122           x = evaluate m (Register a)
 123           y = evaluate m b
 124           reg' = M.insert a (x `mod` y) $ registers m
 125
 126 applyInstruction (Rcv (Register a)) other m = ( m {registers = reg', messageQueue = mq', pc = pc'}, other)
 127     where pc' = pc m + 1
 128           reg' = M.insert a (head $ messageQueue m) $ registers m
 129           mq' = tail $ messageQueue m
 130
 131 applyInstruction (Jgz a b) other m = (m {pc = pc'}, other)
 132     where x = evaluate m a
 133           y = evaluate m b
 134           pc' = if x > 0 then pc m + (fromIntegral y) else pc m + 1
 135
 136 evaluate :: Machine -> Location -> Integer
 137 evaluate _ (Literal i)  = i
 138 evaluate m (Register r) = M.findWithDefault 0 r (registers m)
 139
 140 isReceive :: Instruction -> Bool
 141 isReceive (Rcv _) = True
 142 isReceive _ = False
 143
 144 isSend :: Instruction -> Bool
 145 isSend (Snd _) = True
 146 isSend _ = False