63fb20c60be300c6e4fa23402578523c8aad612d
[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 mem = Machine
48 { _ip = 0
49 , _inputIndex = 0
50 , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
51 , _memory = mem
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 regs <- gets _registers
279 let regVals = intercalate "; " $ fmap show $ M.elems regs
280 stk <- gets _stack
281 let stackVals = intercalate "; " $ fmap show $ take 10 stk
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))