Done day 5
[advent-of-code-19.git] / advent05 / src / advent05.hs
1 import Debug.Trace
2
3 import Data.Text (Text)
4 import qualified Data.Text.IO as TIO
5
6 import Data.Void (Void)
7
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
12
13 import Control.Monad (unless)
14 import Control.Monad.State.Strict
15 import Control.Monad.Reader
16 import Control.Monad.Writer
17
18 import qualified Data.IntMap.Strict as M
19 import Data.IntMap.Strict ((!))
20 import Data.List
21
22 type Memory = M.IntMap Int
23
24 data Machine = Machine { _memory :: Memory
25 , _ip :: Int
26 , _inputIndex :: Int
27 }
28 deriving (Show, Eq)
29
30 type ProgrammedMachine = WriterT [Int] (ReaderT ([Int]) (State Machine)) ()
31
32 data ParameterMode = Position | Immediate deriving (Ord, Eq, Show)
33
34
35 main :: IO ()
36 main = do
37 text <- TIO.readFile "data/advent05.txt"
38 let mem = successfulParse text
39 -- let machine = makeMachine mem
40 print $ findMachineOutput [1] mem
41 print $ findMachineOutput [5] mem
42 -- print $ part2 machine
43
44
45 -- part1 machine = (_memory $ execState runAll machine1202)!0
46 -- where machine1202 = machine { _memory = M.insert 1 12 $ M.insert 2 2 $ _memory machine }
47
48
49 findMachineOutput inputs program = output -- last output
50 where finalStack =
51 runState (
52 runReaderT (
53 runWriterT runAll
54 )
55 inputs
56 )
57 (makeMachine program)
58 ((_retval, output), _machine) = finalStack
59
60
61 -- part1 = nounVerbResult 12 2
62
63 -- part2Target = 19690720
64
65 -- part2 machine = noun * 100 + verb
66 -- where (noun, verb) = head $ [(n, v) | n <- [0..99], v <- [0..99],
67 -- nounVerbResult n v machine == part2Target ]
68
69
70 makeMachine :: [Int] -> Machine
71 makeMachine memory = Machine {_ip = 0, _inputIndex = 0
72 , _memory = M.fromList $ zip [0..] memory
73 }
74
75 -- nounVerbResult :: Int -> Int -> Machine -> Int
76 -- nounVerbResult noun verb machine = machineOutput nvMachine
77 -- where nvMachine0 = machineNounVerb machine noun verb
78 -- nvMachine = execState runAll nvMachine0
79
80 -- machineNounVerb :: Machine -> Int -> Int -> Machine
81 -- machineNounVerb machine noun verb = machine { _memory = M.insert 1 noun $ M.insert 2 verb $ _memory machine }
82
83 -- machineOutput :: Machine -> Int
84 -- machineOutput machine = (_memory machine)!0
85
86
87 runAll :: ProgrammedMachine
88 runAll = do mem <- gets _memory
89 ip <- gets _ip
90 unless (mem!ip == 99)
91 do runStep
92 runAll
93
94 runStep :: ProgrammedMachine
95 runStep =
96 do mem <- gets _memory
97 ip <- gets _ip
98 let opcode = (mem!ip) `mod` 100
99 let modes = parameterModes ((mem!ip) `div` 100)
100 fetchInput opcode
101 putOutput opcode modes
102 mem' <- gets _memory
103 let (mem'', ip') = perform opcode ip modes mem'
104 modify (\m -> m {_ip = ip', _memory = mem''})
105
106
107 -- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined
108 fetchInput 3 =
109 do mem <- gets _memory
110 ip <- gets _ip
111 inputIndex <- gets _inputIndex
112 inputs <- ask
113 let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem
114 modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
115 fetchInput _ = return ()
116
117
118 -- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
119 putOutput 4 modes =
120 do mem <- gets _memory
121 ip <- gets _ip
122 let v = getMemoryValue (ip + 1) (modes!!0) mem
123 tell [v]
124 putOutput _ _ = return ()
125
126
127 perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int)
128 -- perform instr ip modes mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined
129 perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4)
130 where a = getMemoryValue (ip + 1) (modes!!0) mem
131 b = getMemoryValue (ip + 2) (modes!!1) mem
132 perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4)
133 where a = getMemoryValue (ip + 1) (modes!!0) mem
134 b = getMemoryValue (ip + 2) (modes!!1) mem
135 perform 3 ip _ mem = (mem, ip + 2)
136 perform 4 ip _ mem = (mem, ip + 2)
137 perform 5 ip modes mem = (mem, ip')
138 where a = getMemoryValue (ip + 1) (modes!!0) mem
139 b = getMemoryValue (ip + 2) (modes!!1) mem
140 ip' = if a /= 0 then b else ip + 3
141 perform 6 ip modes mem = (mem, ip')
142 where a = getMemoryValue (ip + 1) (modes!!0) mem
143 b = getMemoryValue (ip + 2) (modes!!1) mem
144 ip' = if a == 0 then b else ip + 3
145 perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
146 where a = getMemoryValue (ip + 1) (modes!!0) mem
147 b = getMemoryValue (ip + 2) (modes!!1) mem
148 res = if a < b then 1 else 0
149 perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
150 where a = getMemoryValue (ip + 1) (modes!!0) mem
151 b = getMemoryValue (ip + 2) (modes!!1) mem
152 res = if a == b then 1 else 0
153 perform _ ip _ mem = (mem, ip)
154
155
156 getMemoryValue loc Position mem = mem!>loc
157 getMemoryValue loc Immediate mem = mem!loc
158
159
160 parameterModes :: Int -> [ParameterMode]
161 parameterModes modeCode = unfoldr generateMode modeCode
162
163 generateMode :: Int -> Maybe (ParameterMode, Int)
164 generateMode modeCode = Just (mode, modeCode `div` 10)
165 where mode = case (modeCode `mod` 10) of
166 0 -> Position
167 1 -> Immediate
168
169
170 -- Some IntMap utility functions, for syntactic sugar
171
172 -- prefix version of (!)
173 lkup k m = m!k
174
175 -- indirect lookup
176 (!>) m k = m!(m!k)
177
178 -- indirect insert
179 iInsert k v m = M.insert (m!k) v m
180
181
182
183 -- Parse the input file
184 type Parser = Parsec Void Text
185
186 sc :: Parser ()
187 sc = L.space (skipSome spaceChar) CA.empty CA.empty
188 -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
189
190 lexeme = L.lexeme sc
191 integer = lexeme L.decimal
192 signedInteger = L.signed sc integer
193 symb = L.symbol sc
194 comma = symb ","
195
196 memoryP = signedInteger `sepBy` comma
197
198 successfulParse :: Text -> [Int]
199 successfulParse input =
200 case parse memoryP "input" input of
201 Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
202 Right memory -> memory