X-Git-Url: https://git.njae.me.uk/?p=advent-of-code-19.git;a=blobdiff_plain;f=intcode%2Fsrc%2FIntcode.hs;fp=intcode%2Fsrc%2FIntcode.hs;h=bdc4cb4adb84b244f4dba801641c7b6ba0972091;hp=0000000000000000000000000000000000000000;hb=9c092291e0a897ae7c8b3d59b04a0cd1938bbcaf;hpb=6bee1a6e12e08b5e130add0d3e1f8b80b66b722a

diff --git a/intcode/src/Intcode.hs b/intcode/src/Intcode.hs
new file mode 100644
index 0000000..bdc4cb4
--- /dev/null
+++ b/intcode/src/Intcode.hs
@@ -0,0 +1,183 @@
+module Intcode where
+
+import Debug.Trace
+
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+
+import Data.Void (Void)
+
+import Text.Megaparsec hiding (State)
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import qualified Control.Applicative as CA
+
+-- import Control.Monad (unless)
+import Control.Monad.State.Strict
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.RWS.Strict
+
+
+import qualified Data.Map.Strict as M
+import Data.Map.Strict ((!))
+import Data.List
+
+type Memory = M.Map Integer Integer
+
+data Machine = Machine { _memory :: Memory
+                       , _ip :: Integer
+                       , _inputIndex :: Int
+                       , _rb :: Integer
+                       } 
+               deriving (Show, Eq)
+
+type ProgrammedMachine = RWS [Integer] [Integer] Machine
+
+data ExecutionState = Runnable | Blocked | Terminated  deriving (Ord, Eq, Show)
+
+data ParameterMode = Position | Immediate | Relative deriving (Ord, Eq, Show)
+
+
+-- returns (returnValue, finalMachine, outputs)
+runProgram :: [Integer] -> [Integer] -> (ExecutionState, Machine, [Integer])
+runProgram inputs program = runMachine inputs (makeMachine program)
+
+runMachine :: [Integer] -> Machine -> (ExecutionState, Machine, [Integer])
+runMachine inputs machine = runRWS runAll inputs machine
+
+
+makeMachine :: [Integer] -> Machine
+makeMachine memory = Machine    {_ip = 0, _inputIndex = 0, _rb = 0
+                                , _memory = M.fromList $ zip [0..] memory
+                                }
+
+
+runAll :: ProgrammedMachine ExecutionState
+runAll = do mem <- gets _memory
+            ip <- gets _ip
+            input <- ask
+            iIndex <- gets _inputIndex
+            let acutalInputLength = length input
+            let requiredInputLength = iIndex + 1
+            if (mem!ip == 99)
+            then return Terminated
+            else    if (mem!ip == 3 && requiredInputLength > acutalInputLength)
+                    then return Blocked
+                    else do runStep
+                            runAll
+
+runStep :: ProgrammedMachine ()
+runStep = 
+    do mem <- gets _memory
+       ip <- gets _ip
+       rb <- gets _rb
+       let opcode = (mem!ip) `mod` 100
+       let modes = parameterModes ((mem!ip) `div` 100)
+       fetchInput opcode modes
+       putOutput opcode modes
+       mem' <- gets _memory
+       let (mem'', ip', rb') = perform opcode ip modes rb mem'
+       modify (\m -> m {_ip = ip', _memory = mem'', _rb = rb'})
+
+fetchInput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
+-- fetchInput opcode _modes | trace ("Input with opcode " ++ show opcode) False = undefined
+fetchInput 3 modes =
+    do mem <- gets _memory
+       ip <- gets _ip
+       rb <- gets _rb
+       inputIndex <- gets _inputIndex
+       inputs <- ask 
+       let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!inputIndex) mem
+       modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
+fetchInput _ _ = return ()
+
+putOutput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
+-- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
+putOutput 4 modes =
+    do mem <- gets _memory
+       ip <- gets _ip
+       rb <- gets _rb
+       let v = getMemoryValue (ip + 1) (modes!!0) rb mem
+       tell [v]
+putOutput _ _ = return ()       
+
+
+perform :: Integer -> Integer -> [ParameterMode] -> Integer -> Memory -> (Memory, Integer, Integer)
+-- 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
+perform 1 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a + b) mem, ip + 4, rb)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+          b = getMemoryValue (ip + 2) (modes!!1) rb mem
+perform 2 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a * b) mem, ip + 4, rb)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+          b = getMemoryValue (ip + 2) (modes!!1) rb mem
+perform 3 ip _ rb mem = (mem, ip + 2, rb)
+perform 4 ip _ rb mem = (mem, ip + 2, rb)
+perform 5 ip modes rb mem = (mem, ip', rb)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+          b = getMemoryValue (ip + 2) (modes!!1) rb mem
+          ip' = if a /= 0 then b else ip + 3
+perform 6 ip modes rb mem = (mem, ip', rb)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+          b = getMemoryValue (ip + 2) (modes!!1) rb mem
+          ip' = if a == 0 then b else ip + 3
+perform 7 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+          b = getMemoryValue (ip + 2) (modes!!1) rb mem
+          res = if a < b then 1 else 0
+perform 8 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+          b = getMemoryValue (ip + 2) (modes!!1) rb mem
+          res = if a == b then 1 else 0
+perform 9 ip modes rb mem = (mem, ip + 2, rb + a)
+    where a = getMemoryValue (ip + 1) (modes!!0) rb mem
+perform _ ip _ rb mem = (mem, ip, rb)
+
+
+getMemoryValue :: Integer -> ParameterMode -> Integer -> Memory -> Integer
+getMemoryValue loc Position rb mem = getMemoryValue loc' Immediate rb mem
+    where loc' = M.findWithDefault 0 loc mem
+getMemoryValue loc Immediate _ mem = M.findWithDefault 0 loc mem
+getMemoryValue loc Relative rb mem = getMemoryValue loc' Immediate 0 mem
+    where loc' = rb + M.findWithDefault 0 loc mem
+
+-- indirect insert
+iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory
+iInsert loc Position _rb value mem = M.insert loc' value mem
+    where loc' = M.findWithDefault 0 loc mem
+iInsert loc Immediate _rb value mem = M.insert loc value mem
+iInsert loc Relative rb value mem = M.insert loc' value mem
+    where loc' = rb + M.findWithDefault 0 loc mem
+
+parameterModes :: Integer -> [ParameterMode]
+parameterModes modeCode = unfoldr generateMode modeCode
+
+generateMode :: Integer -> Maybe (ParameterMode, Integer)
+generateMode modeCode = Just (mode, modeCode `div` 10)
+    where mode = case (modeCode `mod` 10) of 
+                    0 -> Position
+                    1 -> Immediate
+                    2 -> Relative
+
+
+-- Parse the input file
+type Parser = Parsec Void Text
+
+sc :: Parser ()
+sc = L.space (skipSome spaceChar) CA.empty CA.empty
+-- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
+
+lexeme  = L.lexeme sc
+integer = lexeme L.decimal
+signedInteger = L.signed sc integer
+symb = L.symbol sc
+comma = symb ","
+
+memoryP = signedInteger `sepBy` comma
+
+
+parseMachineMemory :: Text -> [Integer]
+parseMachineMemory input = 
+        case parse memoryP "input" input of
+                Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
+                Right memory -> memory