intcode/src/Intcode.hs

   1 module Intcode where
   2
   3 import Debug.Trace
   4
   5 import Data.Text (Text)
   6 import qualified Data.Text.IO as TIO
   7
   8 import Data.Void (Void)
   9
  10 import Text.Megaparsec hiding (State)
  11 import Text.Megaparsec.Char
  12 import qualified Text.Megaparsec.Char.Lexer as L
  13 import qualified Control.Applicative as CA
  14
  15 -- import Control.Monad (unless)
  16 import Control.Monad.State.Strict
  17 import Control.Monad.Reader
  18 import Control.Monad.Writer
  19 import Control.Monad.RWS.Strict
  20
  21
  22 import qualified Data.Map.Strict as M
  23 import Data.Map.Strict ((!))
  24 import Data.List
  25
  26 type Memory = M.Map Integer Integer
  27
  28 data Machine = Machine { _memory :: Memory
  29                        , _ip :: Integer
  30                        , _inputIndex :: Int
  31                        , _rb :: Integer
  32                        }
  33                deriving (Show, Eq)
  34
  35 type ProgrammedMachine = RWS [Integer] [Integer] Machine
  36
  37 data ExecutionState = Runnable | Blocked | Terminated  deriving (Ord, Eq, Show)
  38
  39 data ParameterMode = Position | Immediate | Relative deriving (Ord, Eq, Show)
  40
  41
  42 -- returns (returnValue, finalMachine, outputs)
  43 runProgram :: [Integer] -> [Integer] -> (ExecutionState, Machine, [Integer])
  44 runProgram inputs program = runMachine inputs (makeMachine program)
  45
  46 runMachine :: [Integer] -> Machine -> (ExecutionState, Machine, [Integer])
  47 runMachine inputs machine = runRWS runAll inputs machine
  48
  49
  50 makeMachine :: [Integer] -> Machine
  51 makeMachine memory = Machine    {_ip = 0, _inputIndex = 0, _rb = 0
  52                                 , _memory = M.fromList $ zip [0..] memory
  53                                 }
  54
  55
  56 runAll :: ProgrammedMachine ExecutionState
  57 runAll = do mem <- gets _memory
  58             ip <- gets _ip
  59             input <- ask
  60             iIndex <- gets _inputIndex
  61             let opcode = (mem!ip) `mod` 100
  62             let acutalInputLength = length input
  63             let requiredInputLength = iIndex + 1
  64             if (opcode == 99)
  65             then return Terminated
  66             else    if (opcode == 3 && requiredInputLength > acutalInputLength)
  67                     then return Blocked
  68                     else do runStep
  69                             runAll
  70
  71 runStep :: ProgrammedMachine ()
  72 runStep =
  73     do mem <- gets _memory
  74        ip <- gets _ip
  75        rb <- gets _rb
  76        let opcode = (mem!ip) `mod` 100
  77        let modes = parameterModes ((mem!ip) `div` 100)
  78        fetchInput opcode modes
  79        putOutput opcode modes
  80        mem' <- gets _memory
  81        let (mem'', ip', rb') = perform opcode ip modes rb mem'
  82        modify (\m -> m {_ip = ip', _memory = mem'', _rb = rb'})
  83
  84 fetchInput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
  85 -- fetchInput opcode _modes | trace ("Input with opcode " ++ show opcode) False = undefined
  86 fetchInput 3 modes =
  87     do mem <- gets _memory
  88        ip <- gets _ip
  89        rb <- gets _rb
  90        inputIndex <- gets _inputIndex
  91        inputs <- ask
  92        -- let ii = trace ("Input, index " ++ show inputIndex ++ " : available " ++ show (length inputs)) inputIndex
  93        -- let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!ii) mem
  94        let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!inputIndex) mem
  95        modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
  96 fetchInput _ _ = return ()
  97
  98 putOutput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
  99 -- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
 100 putOutput 4 modes =
 101     do mem <- gets _memory
 102        ip <- gets _ip
 103        rb <- gets _rb
 104        let v = getMemoryValue (ip + 1) (modes!!0) rb mem
 105        tell [v]
 106 putOutput _ _ = return ()
 107
 108
 109 perform :: Integer -> Integer -> [ParameterMode] -> Integer -> Memory -> (Memory, Integer, Integer)
 110 -- perform instr ip modes rb mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " rb " ++ (show rb) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined
 111 perform 1 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a + b) mem, ip + 4, rb)
 112     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 113           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 114 perform 2 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a * b) mem, ip + 4, rb)
 115     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 116           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 117 perform 3 ip _ rb mem = (mem, ip + 2, rb)
 118 perform 4 ip _ rb mem = (mem, ip + 2, rb)
 119 perform 5 ip modes rb mem = (mem, ip', rb)
 120     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 121           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 122           ip' = if a /= 0 then b else ip + 3
 123 perform 6 ip modes rb mem = (mem, ip', rb)
 124     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 125           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 126           ip' = if a == 0 then b else ip + 3
 127 perform 7 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
 128     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 129           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 130           res = if a < b then 1 else 0
 131 perform 8 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
 132     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 133           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 134           res = if a == b then 1 else 0
 135 perform 9 ip modes rb mem = (mem, ip + 2, rb + a)
 136     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 137 perform _ ip _ rb mem = (mem, ip, rb)
 138
 139
 140 getMemoryValue :: Integer -> ParameterMode -> Integer -> Memory -> Integer
 141 getMemoryValue loc Position rb mem = getMemoryValue loc' Immediate rb mem
 142     where loc' = M.findWithDefault 0 loc mem
 143 getMemoryValue loc Immediate _ mem = M.findWithDefault 0 loc mem
 144 getMemoryValue loc Relative rb mem = getMemoryValue loc' Immediate 0 mem
 145     where loc' = rb + M.findWithDefault 0 loc mem
 146
 147 -- indirect insert
 148 iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory
 149 iInsert loc Position _rb value mem = M.insert loc' value mem
 150     where loc' = M.findWithDefault 0 loc mem
 151 iInsert loc Immediate _rb value mem = M.insert loc value mem
 152 iInsert loc Relative rb value mem = M.insert loc' value mem
 153     where loc' = rb + M.findWithDefault 0 loc mem
 154
 155 parameterModes :: Integer -> [ParameterMode]
 156 parameterModes modeCode = unfoldr generateMode modeCode
 157
 158 generateMode :: Integer -> Maybe (ParameterMode, Integer)
 159 generateMode modeCode = Just (mode, modeCode `div` 10)
 160     where mode = case (modeCode `mod` 10) of
 161                     0 -> Position
 162                     1 -> Immediate
 163                     2 -> Relative
 164
 165
 166 -- Parse the input file
 167 type Parser = Parsec Void Text
 168
 169 sc :: Parser ()
 170 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 171 -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
 172
 173 lexeme  = L.lexeme sc
 174 integer = lexeme L.decimal
 175 signedInteger = L.signed sc integer
 176 symb = L.symbol sc
 177 comma = symb ","
 178
 179 memoryP = signedInteger `sepBy` comma
 180
 181
 182 parseMachineMemory :: Text -> [Integer]
 183 parseMachineMemory input =
 184         case parse memoryP "input" input of
 185                 Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 186                 Right memory -> memory