757bd5f011ea9dbc31434176010031d6b9306db0
[synacor-challenge.git] / src / SynacorEngine.hs
1 module SynacorEngine where
2
3 import Debug.Trace
4
5 -- import System.Environment
6 import Data.Bits
7 import Data.Word
8 -- import Data.Binary.Get
9 -- import qualified Data.ByteString.Lazy as BL
10 import qualified Data.Map.Strict as M
11 import Data.Map.Strict ((!))
12 import Control.Lens
13 import Data.List
14 import Data.Char
15 import Numeric
16
17 import Control.Monad.State.Strict
18 import Control.Monad.Reader
19 import Control.Monad.Writer
20 import Control.Monad.RWS.Strict
21
22 type Memory = M.Map Word16 Word16
23
24
25
26 data Machine = Machine { _memory :: Memory
27 , _ip :: Word16
28 , _registers :: Memory
29 , _inputIndex :: Int
30 , _stack :: [Word16]
31 , _tracing :: Bool
32 }
33 deriving (Show, Eq, Ord)
34 makeLenses ''Machine
35
36 type ProgrammedMachine = RWS [Word16] [Word16] Machine
37
38 data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show)
39
40 -- returns (returnValue, finalMachine, outputs)
41
42 runMachine :: [Word16] -> Machine -> (ExecutionState, Machine, [Word16])
43 runMachine inputs machine = runRWS (runAll (10 ^ 6)) inputs machine
44
45
46 makeMachine :: Memory -> Machine
47 makeMachine memory = Machine
48 { _ip = 0
49 , _inputIndex = 0
50 , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
51 , _memory = memory
52 , _stack = []
53 , _tracing = False
54 }
55
56 -- traceMachine x =
57 -- do cip <- gets _ip
58 -- opcode <- getLocation cip
59 -- arg1 <- getValue (cip + 1)
60 -- arg2 <- getValue (cip + 2)
61 -- arg3 <- getValue (cip + 3)
62 -- mem <- gets _memory
63 -- regs <- gets _registers
64 -- let raw1 = mem ! (cip + 1)
65 -- let raw2 = mem ! (cip + 2)
66 -- let raw3 = mem ! (cip + 3)
67 -- let x' = trace (
68 -- intercalate ": "
69 -- [ "IP Addr"
70 -- , show (showHex (cip * 2) "")
71 -- , "IP"
72 -- , (show (showHex cip ""))
73 -- , "Op"
74 -- , show (opcode)
75 -- , "Args"
76 -- , show (showHex arg1 "")
77 -- , show (showHex arg2 "")
78 -- , show (showHex arg3 "")
79 -- , "Raw"
80 -- , show (showHex raw1 "")
81 -- , show (showHex raw2 "")
82 -- , show (showHex raw3 "")
83 -- , show (M.elems regs)
84 -- ]
85 -- ) x
86 -- return x'
87
88 runAll :: Int -> ProgrammedMachine ExecutionState
89 runAll executionLimit
90 | executionLimit == 0 = return Terminated
91 | otherwise =
92 do cip <- gets _ip
93 opcode <- getLocation cip
94 traceMachine
95 -- opcode' <- traceMachine opcode
96 -- exState <- runStep opcode'
97 exState <- runStep opcode
98 case exState of
99 Terminated -> return Terminated
100 Blocked -> return Blocked
101 _ -> runAll (executionLimit - 1)
102
103
104 runStep :: Word16 -> ProgrammedMachine ExecutionState
105 -- runStep n | trace (show n) False = undefined
106 runStep 0 = return Terminated
107 runStep 1 =
108 do cip <- gets _ip
109 regR <- getLocation (cip + 1)
110 let reg = regR .&. 7
111 value <- getValue (cip + 2)
112 advanceIP 3
113 modify (\m -> m & registers . ix reg .~ value)
114 return Runnable
115 runStep 2 =
116 do cip <- gets _ip
117 value <- getValue (cip + 1)
118 advanceIP 2
119 modify (\m -> m & stack %~ (value :) )
120 return Runnable
121 runStep 3 =
122 do cip <- gets _ip
123 tgt <- getLocation (cip + 1)
124 val <- gets (\m -> head $ m ^. stack)
125 modify (\m -> m & stack %~ tail )
126 putValue tgt val
127 advanceIP 2
128 return Runnable
129 runStep 4 =
130 do cip <- gets _ip
131 tgt <- getLocation (cip + 1)
132 b <- getValue (cip + 2)
133 c <- getValue (cip + 3)
134 putValue tgt (if b == c then 1 else 0)
135 modify (\m -> m & ip %~ (+ 4))
136 return Runnable
137 runStep 5 =
138 do cip <- gets _ip
139 tgt <- getLocation (cip + 1)
140 b <- getValue (cip + 2)
141 c <- getValue (cip + 3)
142 putValue tgt (if b > c then 1 else 0)
143 advanceIP 4
144 return Runnable
145 runStep 6 =
146 do cip <- gets _ip
147 tgt <- getLocation (cip + 1)
148 modify (\m -> m & ip .~ tgt)
149 return Runnable
150 runStep 7 =
151 do cip <- gets _ip
152 a <- getValue (cip + 1)
153 tgt <- getLocation (cip + 2)
154 if a /= 0
155 then modify (\m -> m & ip .~ tgt)
156 else advanceIP 3
157 return Runnable
158 runStep 8 =
159 do cip <- gets _ip
160 a <- getValue (cip + 1)
161 tgt <- getLocation (cip + 2)
162 if a == 0
163 then modify (\m -> m & ip .~ tgt)
164 else advanceIP 3
165 return Runnable
166
167 runStep 9 =
168 do cip <- gets _ip
169 a <- getLocation (cip + 1)
170 b <- getValue (cip + 2)
171 c <- getValue (cip + 3)
172 putValue a (b + c)
173 advanceIP 4
174 return Runnable
175 runStep 10 =
176 do cip <- gets _ip
177 a <- getLocation (cip + 1)
178 b <- getValue (cip + 2)
179 c <- getValue (cip + 3)
180 putValue a (b * c)
181 advanceIP 4
182 return Runnable
183 runStep 11 =
184 do cip <- gets _ip
185 a <- getLocation (cip + 1)
186 b <- getValue (cip + 2)
187 c <- getValue (cip + 3)
188 putValue a (b `mod` c)
189 advanceIP 4
190 return Runnable
191 runStep 12 =
192 do cip <- gets _ip
193 a <- getLocation (cip + 1)
194 b <- getValue (cip + 2)
195 c <- getValue (cip + 3)
196 putValue a (b .&. c)
197 advanceIP 4
198 return Runnable
199 runStep 13 =
200 do cip <- gets _ip
201 a <- getLocation (cip + 1)
202 b <- getValue (cip + 2)
203 c <- getValue (cip + 3)
204 putValue a (b .|. c)
205 advanceIP 4
206 return Runnable
207 runStep 14 =
208 do cip <- gets _ip
209 a <- getLocation (cip + 1)
210 b <- getValue (cip + 2)
211 putValue a (complement b)
212 advanceIP 3
213 return Runnable
214
215 runStep 15 =
216 do cip <- gets _ip
217 a <- getLocation (cip + 1)
218 b <- getValue (cip + 2)
219 v <- getValue b
220 putValue a v
221 advanceIP 3
222 return Runnable
223 runStep 16 =
224 do cip <- gets _ip
225 a <- getValue (cip + 1)
226 b <- getValue (cip + 2)
227 putValue a b
228 advanceIP 3
229 return Runnable
230
231 runStep 17 =
232 do cip <- gets _ip
233 a <- getValue (cip + 1)
234 modify (\m -> m & stack %~ ((cip + 2) :)
235 & ip .~ a)
236 return Runnable
237
238 runStep 18 =
239 do val <- gets (\m -> head $ m ^. stack)
240 modify (\m -> m & stack %~ tail
241 & ip .~ val)
242 return Runnable
243
244 runStep 19 =
245 do cip <- gets _ip
246 v <- getValue (cip + 1)
247 tell [v]
248 advanceIP 2
249 return Runnable
250
251 runStep 20 =
252 do iIndex <- gets _inputIndex
253 inputs <- ask
254 cip <- gets _ip
255 tgt <- getLocation (cip + 1)
256 if (iIndex + 1) > (length inputs)
257 then return Blocked
258 else do let char = (inputs!!iIndex)
259 putValue tgt char
260 modify (\m -> m & inputIndex %~ (+ 1))
261 advanceIP 2
262 return Runnable
263
264 runStep 21 =
265 do advanceIP 1
266 return Runnable
267 runStep _ =
268 do advanceIP 1
269 return Runnable
270
271
272 traceMachine :: ProgrammedMachine ()
273 traceMachine = do
274 isTracing <- gets _tracing
275 when isTracing
276 do cip <- gets _ip
277 (l, _) <- dissembleInstruction cip
278 registers <- gets _registers
279 let regVals = intercalate "; " $ fmap show $ M.elems registers
280 stack <- gets _stack
281 let stackVals = intercalate "; " $ fmap show $ take 10 stack
282 tell $ fmap (fromIntegral . ord) (">> " ++ l ++ " : r> " ++ regVals ++ " : s> " ++ stackVals ++ "<<")
283
284 runDissemble :: Word16 -> Int -> Machine -> [String]
285 runDissemble startAt num machine =fst $ evalRWS (dissemble startAt num) [] machine
286
287
288 dissemble :: Word16 -> Int -> ProgrammedMachine [String]
289 dissemble startAt num = go startAt num []
290 where go _ 0 ls = return $ reverse ls
291 go here n ls =
292 do (line, step) <- dissembleInstruction here
293 go (here + step) (n - 1) (line : ls)
294
295 dissembleInstruction :: Word16 -> ProgrammedMachine (String, Word16)
296 dissembleInstruction cip =
297 do -- cip <- gets _ip
298 opcode <- getLocation cip
299 mem <- gets _memory
300 let a = mem ! (cip + 1)
301 let b = mem ! (cip + 2)
302 let c = mem ! (cip + 3)
303 let sa = show a
304 let sb = show b
305 let sc = show c
306 va <- getValue (cip + 1)
307 vb <- getValue (cip + 2)
308 vc <- getValue (cip + 3)
309 let sva = show va
310 let svb = show vb
311 let svc = show vc
312 let traceText =
313 case opcode of
314 0 -> ["halt"]
315 1 -> ["set", sa, sb, "*", sva, svb]
316 2 -> ["push", sa, "*", sva]
317 3 -> ["pop", sa, "*", sva]
318 4 -> ["eq", sa, sb, sc, "*", sva, svb, svc]
319 5 -> ["gt", sa, sb, sc, "*", sva, svb, svc]
320 6 -> ["jmp", sa, "*", sva]
321 7 -> ["jt", sa, sb, "*", sva, svb]
322 8 -> ["jf", sa, sb, "*", sva, svb]
323 9 -> ["add", sa, sb, sc, "*", sva, svb, svc]
324 10 -> ["mul", sa, sb, sc, "*", sva, svb, svc]
325 11 -> ["mod", sa, sb, sc, "*", sva, svb, svc]
326 12 -> ["and", sa, sb, sc, "*", sva, svb, svc]
327 13 -> ["or", sa, sb, sc, "*", sva, svb, svc]
328 14 -> ["not", sa, sb, "*", sva, svb]
329 15 -> ["rmem", sa, sb, "*", sva, svb]
330 16 -> ["wmem", sa, sb, "*", sva, svb]
331 17 -> ["call", sa, "*", sva]
332 18 -> ["ret"]
333 19 -> ["out", sa, "*", sva]
334 20 -> ["in", sa, "*", sva]
335 21 -> ["noop"]
336 _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc]
337 let stepSize =
338 if | opcode `elem` [0, 18, 21] -> 1
339 | opcode `elem` [2, 3, 6, 17, 19, 20] -> 2
340 | opcode `elem` [1, 7, 8, 14, 15, 16] -> 3
341 | opcode `elem` [4, 5, 9, 10, 11, 12, 13] -> 4
342 | otherwise -> 1
343 return ( ((show cip) ++ ": " ++ (intercalate " " traceText))
344 , stepSize
345 )
346
347 getValue :: Word16 -> ProgrammedMachine Word16
348 getValue loc =
349 do mem <- gets _memory
350 regs <- gets _registers
351 let val = mem ! loc
352 if val < (2 ^ 15)
353 then return val
354 else return (regs ! (val .&. 7))
355
356
357
358 -- | loc < 32768 =
359 -- do mem <- gets _memory
360 -- return $ mem ! loc
361 -- | otherwise =
362 -- do regs <- gets _registers
363 -- return $ regs ! (loc `shiftR` 15)
364
365 getLocation :: Word16 -> ProgrammedMachine Word16
366 getLocation loc =
367 do mem <- gets _memory
368 return $ mem ! loc
369
370 putValue :: Word16 -> Word16 -> ProgrammedMachine ()
371 putValue loc value
372 | loc < (2 ^ 15) = modify (\m -> m & memory . ix loc .~ v)
373 | otherwise = modify (\m -> m & registers . ix (loc .&. 7) .~ v)
374 where v = value `mod` (2 ^ 15)
375
376 advanceIP :: Word16 -> ProgrammedMachine ()
377 advanceIP delta = modify (\m -> m & ip %~ (+ delta))