1 module SynacorEngine where
5 -- import System.Environment
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 ((!))
17 import Control.Monad.State.Strict
18 import Control.Monad.Reader
19 import Control.Monad.Writer
20 import Control.Monad.RWS.Strict
22 type Memory = M.Map Word16 Word16
26 data Machine = Machine { _memory :: Memory
28 , _registers :: Memory
33 deriving (Show, Eq, Ord)
36 type ProgrammedMachine = RWS [Word16] [Word16] Machine
38 data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show)
40 -- returns (returnValue, finalMachine, outputs)
42 runMachine :: [Word16] -> Machine -> (ExecutionState, Machine, [Word16])
43 runMachine inputs machine = runRWS runAll inputs machine
46 makeMachine :: Memory -> Machine
47 makeMachine memory = Machine
50 , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
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)
70 -- , show (showHex (cip * 2) "")
72 -- , (show (showHex cip ""))
76 -- , show (showHex arg1 "")
77 -- , show (showHex arg2 "")
78 -- , show (showHex arg3 "")
80 -- , show (showHex raw1 "")
81 -- , show (showHex raw2 "")
82 -- , show (showHex raw3 "")
83 -- , show (M.elems regs)
88 runAll :: ProgrammedMachine ExecutionState
89 runAll = do cip <- gets _ip
90 opcode <- getLocation cip
92 -- opcode' <- traceMachine opcode
93 -- exState <- runStep opcode'
94 exState <- runStep opcode
96 Terminated -> return Terminated
97 Blocked -> return Blocked
101 runStep :: Word16 -> ProgrammedMachine ExecutionState
102 -- runStep n | trace (show n) False = undefined
103 runStep 0 = return Terminated
106 regR <- getLocation (cip + 1)
108 value <- getValue (cip + 2)
110 modify (\m -> m & registers . ix reg .~ value)
114 value <- getValue (cip + 1)
116 modify (\m -> m & stack %~ (value :) )
120 tgt <- getLocation (cip + 1)
121 val <- gets (\m -> head $ m ^. stack)
122 modify (\m -> m & stack %~ tail )
128 tgt <- getLocation (cip + 1)
129 b <- getValue (cip + 2)
130 c <- getValue (cip + 3)
131 putValue tgt (if b == c then 1 else 0)
132 modify (\m -> m & ip %~ (+ 4))
136 tgt <- getLocation (cip + 1)
137 b <- getValue (cip + 2)
138 c <- getValue (cip + 3)
139 putValue tgt (if b > c then 1 else 0)
144 tgt <- getLocation (cip + 1)
145 modify (\m -> m & ip .~ tgt)
149 a <- getValue (cip + 1)
150 tgt <- getLocation (cip + 2)
152 then modify (\m -> m & ip .~ tgt)
157 a <- getValue (cip + 1)
158 tgt <- getLocation (cip + 2)
160 then modify (\m -> m & ip .~ tgt)
166 a <- getLocation (cip + 1)
167 b <- getValue (cip + 2)
168 c <- getValue (cip + 3)
174 a <- getLocation (cip + 1)
175 b <- getValue (cip + 2)
176 c <- getValue (cip + 3)
182 a <- getLocation (cip + 1)
183 b <- getValue (cip + 2)
184 c <- getValue (cip + 3)
185 putValue a (b `mod` c)
190 a <- getLocation (cip + 1)
191 b <- getValue (cip + 2)
192 c <- getValue (cip + 3)
198 a <- getLocation (cip + 1)
199 b <- getValue (cip + 2)
200 c <- getValue (cip + 3)
206 a <- getLocation (cip + 1)
207 b <- getValue (cip + 2)
208 putValue a (complement b)
214 a <- getLocation (cip + 1)
215 b <- getValue (cip + 2)
222 a <- getValue (cip + 1)
223 b <- getValue (cip + 2)
230 a <- getValue (cip + 1)
231 modify (\m -> m & stack %~ ((cip + 2) :)
236 do val <- gets (\m -> head $ m ^. stack)
237 modify (\m -> m & stack %~ tail
243 v <- getValue (cip + 1)
249 do iIndex <- gets _inputIndex
252 tgt <- getLocation (cip + 1)
253 if (iIndex + 1) > (length inputs)
255 else do let char = (inputs!!iIndex)
257 modify (\m -> m & inputIndex %~ (+ 1))
269 traceMachine :: ProgrammedMachine ()
271 isTracing <- gets _tracing
274 opcode <- getLocation cip
275 a <- getLocation (cip + 1)
276 b <- getLocation (cip + 2)
277 c <- getLocation (cip + 3)
281 va <- getValue (cip + 1)
282 vb <- getValue (cip + 2)
283 vc <- getValue (cip + 3)
290 1 -> ["set", sa, sb, "*", sva, svb]
291 2 -> ["push", sa, "*", sva]
292 3 -> ["pop", sa, "*", sva]
293 4 -> ["eq", sa, sb, sc, "*", sva, svb, svc]
294 5 -> ["gt", sa, sb, sc, "*", sva, svb, svc]
295 6 -> ["jmp", sa, "*", sva]
296 7 -> ["jt", sa, sb, "*", sva, svb]
297 8 -> ["jf", sa, sb, "*", sva, svb]
298 9 -> ["add", sa, sb, sc, "*", sva, svb, svc]
299 10 -> ["mul", sa, sb, sc, "*", sva, svb, svc]
300 11 -> ["mod", sa, sb, sc, "*", sva, svb, svc]
301 12 -> ["and", sa, sb, sc, "*", sva, svb, svc]
302 13 -> ["or", sa, sb, sc, "*", sva, svb, svc]
303 14 -> ["not", sa, sb, "*", sva, svb]
304 15 -> ["rmem", sa, sb, "*", sva, svb]
305 16 -> ["wmem", sa, sb, "*", sva, svb]
306 17 -> ["call", sa, "*", sva]
308 19 -> ["out", sa, "*", sva]
309 20 -> ["in", sa, "*", sva]
310 21 -> ["noop", sa, sb, sc, "*", sva, svb, svc]
311 _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc]
312 tell $ fmap (fromIntegral . ord) (">> " ++ (show cip) ++ ": " ++ (intercalate " " traceText) ++ "<<")
314 getValue :: Word16 -> ProgrammedMachine Word16
316 do mem <- gets _memory
317 regs <- gets _registers
321 else return (regs ! (val .&. 7))
326 -- do mem <- gets _memory
327 -- return $ mem ! loc
329 -- do regs <- gets _registers
330 -- return $ regs ! (loc `shiftR` 15)
332 getLocation :: Word16 -> ProgrammedMachine Word16
334 do mem <- gets _memory
337 putValue :: Word16 -> Word16 -> ProgrammedMachine ()
339 | loc < (2 ^ 15) = modify (\m -> m & memory . ix loc .~ v)
340 | otherwise = modify (\m -> m & registers . ix (loc .&. 7) .~ v)
341 where v = value `mod` (2 ^ 15)
343 advanceIP :: Word16 -> ProgrammedMachine ()
344 advanceIP delta = modify (\m -> m & ip %~ (+ delta))