3 import Data.Text (Text)
4 import qualified Data.Text.IO as TIO
6 import Data.Void (Void)
8 import Text.Megaparsec hiding (State)
9 import Text.Megaparsec.Char
10 import qualified Text.Megaparsec.Char.Lexer as L
11 import qualified Control.Applicative as CA
13 -- import Control.Monad (unless)
14 import Control.Monad.State.Strict
15 import Control.Monad.Reader
16 import Control.Monad.Writer
17 import Control.Monad.RWS.Strict
20 import qualified Data.Map.Strict as M
21 import Data.Map.Strict ((!))
23 -- import Data.Function (on)
25 type Memory = M.Map Integer Integer
27 data Machine = Machine { _memory :: Memory
34 type ProgrammedMachine = RWS [Integer] [Integer] Machine
36 data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show)
38 data ParameterMode = Position | Immediate | Relative deriving (Ord, Eq, Show)
43 text <- TIO.readFile "data/advent09.txt"
44 let mem = successfulParse text
49 part1 mem = findMachineOutput [1] mem
51 part2 mem = findMachineOutput [2] mem
54 findMachineOutput :: [Integer] -> [Integer] -> [Integer]
55 findMachineOutput inputs program = output
56 where (_haltedBecause, _machine, output) = runRWS runAll inputs (makeMachine program)
59 makeMachine :: [Integer] -> Machine
60 makeMachine memory = Machine {_ip = 0, _inputIndex = 0, _rb = 0
61 , _memory = M.fromList $ zip [0..] memory
65 runAll :: ProgrammedMachine ExecutionState
66 runAll = do mem <- gets _memory
69 iIndex <- gets _inputIndex
70 let acutalInputLength = length input
71 let requiredInputLength = iIndex + 1
73 then return Terminated
74 else if (mem!ip == 3 && requiredInputLength > acutalInputLength)
79 runStep :: ProgrammedMachine ()
81 do mem <- gets _memory
84 let opcode = (mem!ip) `mod` 100
85 let modes = parameterModes ((mem!ip) `div` 100)
86 fetchInput opcode modes
87 putOutput opcode modes
89 let (mem'', ip', rb') = perform opcode ip modes rb mem'
90 modify (\m -> m {_ip = ip', _memory = mem'', _rb = rb'})
92 fetchInput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
93 -- fetchInput opcode _modes | trace ("Input with opcode " ++ show opcode) False = undefined
95 do mem <- gets _memory
98 inputIndex <- gets _inputIndex
100 let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!inputIndex) mem
101 modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
102 fetchInput _ _ = return ()
104 putOutput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
105 -- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
107 do mem <- gets _memory
110 let v = getMemoryValue (ip + 1) (modes!!0) rb mem
112 putOutput _ _ = return ()
115 perform :: Integer -> Integer -> [ParameterMode] -> Integer -> Memory -> (Memory, Integer, Integer)
116 -- 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
117 perform 1 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a + b) mem, ip + 4, rb)
118 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
119 b = getMemoryValue (ip + 2) (modes!!1) rb mem
120 perform 2 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a * b) mem, ip + 4, rb)
121 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
122 b = getMemoryValue (ip + 2) (modes!!1) rb mem
123 perform 3 ip _ rb mem = (mem, ip + 2, rb)
124 perform 4 ip _ rb mem = (mem, ip + 2, rb)
125 perform 5 ip modes rb mem = (mem, ip', rb)
126 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
127 b = getMemoryValue (ip + 2) (modes!!1) rb mem
128 ip' = if a /= 0 then b else ip + 3
129 perform 6 ip modes rb mem = (mem, ip', rb)
130 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
131 b = getMemoryValue (ip + 2) (modes!!1) rb mem
132 ip' = if a == 0 then b else ip + 3
133 perform 7 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
134 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
135 b = getMemoryValue (ip + 2) (modes!!1) rb mem
136 res = if a < b then 1 else 0
137 perform 8 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
138 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
139 b = getMemoryValue (ip + 2) (modes!!1) rb mem
140 res = if a == b then 1 else 0
141 perform 9 ip modes rb mem = (mem, ip + 2, rb + a)
142 where a = getMemoryValue (ip + 1) (modes!!0) rb mem
143 perform _ ip _ rb mem = (mem, ip, rb)
146 getMemoryValue :: Integer -> ParameterMode -> Integer -> Memory -> Integer
147 getMemoryValue loc Position rb mem = getMemoryValue loc' Immediate rb mem
148 where loc' = M.findWithDefault 0 loc mem
149 getMemoryValue loc Immediate _ mem = M.findWithDefault 0 loc mem
150 getMemoryValue loc Relative rb mem = getMemoryValue loc' Immediate 0 mem
151 where loc' = rb + M.findWithDefault 0 loc mem
154 iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory
155 iInsert loc Position _rb value mem = M.insert loc' value mem
156 where loc' = M.findWithDefault 0 loc mem
157 iInsert loc Immediate _rb value mem = M.insert loc value mem
158 iInsert loc Relative rb value mem = M.insert loc' value mem
159 where loc' = rb + M.findWithDefault 0 loc mem
161 parameterModes :: Integer -> [ParameterMode]
162 parameterModes modeCode = unfoldr generateMode modeCode
164 generateMode :: Integer -> Maybe (ParameterMode, Integer)
165 generateMode modeCode = Just (mode, modeCode `div` 10)
166 where mode = case (modeCode `mod` 10) of
171 -- Parse the input file
172 type Parser = Parsec Void Text
175 sc = L.space (skipSome spaceChar) CA.empty CA.empty
176 -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
179 integer = lexeme L.decimal
180 signedInteger = L.signed sc integer
184 memoryP = signedInteger `sepBy` comma
186 successfulParse :: Text -> [Integer]
187 successfulParse input =
188 case parse memoryP "input" input of
189 Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
190 Right memory -> memory