src/advent18/advent18a.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)
  14 import Control.Monad.State.Lazy
  15 import Control.Monad.Reader
  16 import Control.Monad.Writer
  17
  18 import Advent18Parser
  19
  20 data Machine = Machine { registers :: M.Map Char Integer
  21                        , lastSound :: Integer
  22                        , pc :: Int
  23                        }
  24                deriving (Show, Eq)
  25
  26 type ProgrammedMachine = WriterT [Integer] (ReaderT [Instruction] (State Machine)) ()
  27
  28 emptyMachine = Machine {registers = M.empty, lastSound = 0, pc = 0}
  29
  30 main :: IO ()
  31 main = do
  32         text <- TIO.readFile "data/advent18.txt"
  33         let instrs = successfulParse text
  34         let ((result, l), machinef) = part1 instrs
  35         print $ head l
  36
  37 part1 :: [Instruction] -> (((), [Integer]), Machine)
  38 part1 instructions =
  39     runState (
  40         runReaderT (
  41             runWriterT executeInstructions
  42                    )
  43             instructions
  44              )
  45              emptyMachine
  46
  47 executeInstructions :: ProgrammedMachine
  48 executeInstructions =
  49     do  instrs <- ask
  50         m <- get
  51         when (pc m >= 0 && pc m < length instrs)
  52             $
  53             do let rt = recoverTriggers instrs m
  54                if rt
  55                then tell [lastSound m]
  56                else do executeInstruction
  57                        executeInstructions
  58
  59 executeInstruction :: ProgrammedMachine
  60 executeInstruction =
  61     do  instrs <- ask
  62         m <- get
  63         let instr = instrs!!(pc m)
  64         put (applyInstruction instr m)
  65
  66
  67 isRecover :: Instruction -> Bool
  68 isRecover (Rcv _) = True
  69 isRecover _ = False
  70
  71
  72 recoverTriggers :: [Instruction] -> Machine -> Bool
  73 recoverTriggers instrs m =
  74         if isRecover instr
  75         then (x /= 0)
  76         else False
  77         where instr = instrs!!(pc m)
  78               Rcv a = instr
  79               x = evaluate m a
  80
  81
  82 applyInstruction :: Instruction -> Machine -> Machine
  83
  84 applyInstruction (Snd sound) m = m {lastSound = freq, pc = pc'}
  85     where pc' = pc m + 1
  86           freq = evaluate m sound
  87
  88 applyInstruction (Set (Register a) b) m = m {registers = reg', pc = pc'}
  89     where pc' = pc m + 1
  90           y = evaluate m b
  91           reg' = M.insert a y $ registers m
  92
  93 applyInstruction (Add (Register a) b) m = m {registers = reg', pc = pc'}
  94     where pc' = pc m + 1
  95           x = evaluate m (Register a)
  96           y = evaluate m b
  97           reg' = M.insert a (x + y) $ registers m
  98
  99 applyInstruction (Mul (Register a) b) m = m {registers = reg', pc = pc'}
 100     where pc' = pc m + 1
 101           x = evaluate m (Register a)
 102           y = evaluate m b
 103           reg' = M.insert a (x * y) $ registers m
 104
 105 applyInstruction (Mod (Register a) b) m = m {registers = reg', pc = pc'}
 106     where pc' = pc m + 1
 107           x = evaluate m (Register a)
 108           y = evaluate m b
 109           reg' = M.insert a (x `mod` y) $ registers m
 110
 111 applyInstruction (Rcv _a) m = m {pc = pc'}
 112     where pc' = pc m + 1
 113
 114 applyInstruction (Jgz a b) m = m {pc = pc'}
 115     where x = evaluate m a
 116           y = evaluate m b
 117           pc' = if x > 0 then pc m + (fromIntegral y) else pc m + 1
 118
 119
 120 evaluate :: Machine -> Location -> Integer
 121 evaluate _ (Literal i)  = i
 122 evaluate m (Register r) = M.findWithDefault 0 r (registers m)
 123