module ZMachine.Ops where import ZMachine.Base import ZMachine.Strings import ZMachine.Objects import ZMachine.IO import Control.Monad (liftM, zipWithM_) import Control.Monad.State (get, put, modify, gets, liftIO) import Control.Monad.State.Lazy (StateT) -- for a type sig import Data.Int (Int16) import Data.Bits import Data.Array.IArray (listArray) import System.Exit (exitWith, ExitCode(..)) import System.Random (mkStdGen, setStdGen, newStdGen, randomRIO) exec :: ZM () exec = do opcode <- getNextByte let do1OP = do arg <- getArg (opcode `shiftR` 4 .&. 3) exec1OP (opcode .&. (complement 0x30)) arg do2OP = do arg1 <- arg 6 arg2 <- arg 5 exec2OP (opcode .&. (complement 0x60)) [arg1, arg2] where arg bit' = if opcode `testBit` bit' then getArg (2::Int) else getArg (1::Int) do2VAR = do args <- getVarArgs opcode exec2OP (opcode - 0xc0) args doVAR = do args <- getVarArgs opcode execVAR opcode args if opcode <= 0x7f then do2OP else do case opcode `shiftR` 4 of 0x08 -> do1OP 0x09 -> do1OP 0x0a -> do1OP 0x0b -> exec0OP opcode 0x0c -> do2VAR 0x0d -> do2VAR 0x0e -> doVAR 0x0f -> doVAR getArg :: (Num t) => t -> ZM Val getArg 0 = getNextWord getArg 1 = getNextByte getArg 2 = getNextByte >>= getVar getVarArgs :: Val -> ZM [Val] getVarArgs 0xec = get2VarArgs getVarArgs 0xfa = get2VarArgs getVarArgs _ = do x <- getNextByte let argTypes = takeWhile (/= 3) $ [x `shiftR` (2*i) .&. 3 | i <- [3,2,1,0]] mapM getArg argTypes get2VarArgs :: ZM [Val] get2VarArgs = do x <- getNextByte y <- getNextByte let argTypes = takeWhile (/= 3) $ concatMap f [x,y] f a = [a `shiftR` (2*i) .&. 3 | i <- [3,2,1,0]] mapM getArg argTypes exec2OP :: Val -> [Val] -> ZM () exec2OP 0x01 (a:bs) = {- je -} doBranch (a `elem` bs) exec2OP 0x02 [a, b] = {- jl -} doBranch ((fromIntegral a :: Int16) < fromIntegral b) exec2OP 0x03 [a, b] = {- jl -} doBranch ((fromIntegral a :: Int16) > fromIntegral b) exec2OP 0x06 [a, b] = {- jin -} liftM (b==) (getParent a) >>= doBranch exec2OP 0x08 [a, b] = {- or -} doStore (a .|. b) exec2OP 0x09 [a, b] = {- and -} doStore (a .&. b) exec2OP 0x0a [0, _] = {- test_attr 0 -} skipBranch exec2OP 0x0a [a, b] = {- test_attr -} getAttr a b >>= doBranch exec2OP 0x0b [a, b] = {- set_attr -} setAttr a b exec2OP 0x0c [a, b] = {- clear_attr -} clearAttr a b exec2OP 0x0d [a, b] = {- store -} putVar a b exec2OP 0x0e [a, b] = {- insert_obj -} insertObj a b exec2OP 0x0f [a, b] = {- loadw -} getWord (fromIntegral $ a + b*2) >>= doStore exec2OP 0x10 [a, b] = {- loadb -} getByte (fromIntegral $ a + b) >>= doStore exec2OP 0x11 [a, b] = {- get_prop -} getProp a b >>= doStore exec2OP 0x12 [a, b] = {- get_prop_addr -} getPropAddr a b >>= doStore exec2OP 0x13 [a, b] = {- get_next_prop -} getNextProp a b >>= doStore exec2OP 0x14 [a, b] = {- add -} doStore (a + b) exec2OP 0x15 [a, b] = {- sub -} doStore (a - b) exec2OP 0x16 [a, b] = {- mul -} doStore (a * b) exec2OP 0x17 [a, b] = {- div -} doStore (fromIntegral $ (fromIntegral a :: Int16) `div` fromIntegral b) exec2OP 0x18 [a, b] = {- mod -} doStore (fromIntegral $ (fromIntegral a :: Int16) `mod` fromIntegral b) exec2OP 0x19 [a, b] = {- call_2s -} liftM (Just) getNextByte >>= doCall [a,b] exec2OP 0x1a [a, b] = {- call_2n -} doCall [a,b] Nothing exec1OP :: Val -> Val -> ZM () exec1OP 0x80 a = {- jz -} doBranch (a == 0) exec1OP 0x81 obj = {- get_sibling -} getSibling obj >>= doStoreBranch exec1OP 0x82 obj = {- get_child -} getChild obj >>= doStoreBranch exec1OP 0x83 obj = {- get_parent -} getParent obj >>= doStore exec1OP 0x84 addr = {- get_prop_len -} getPropLen addr >>= doStore exec1OP 0x85 var = {- inc -} liftM (+1) (getVar var) >>= putVar var exec1OP 0x86 var = {- dec -} liftM (subtract 1) (getVar var) >>= putVar var exec1OP 0x87 addr = {- print_addr -} getString (fromIntegral addr) >>= zioWrite exec1OP 0x88 r = {- call_1s -} liftM (Just) getNextByte >>= doCall [r] exec1OP 0x89 obj = {- remove_obj -} removeObj obj exec1OP 0x8a obj = {- print_obj -} do addr <- getObjectAddr obj addr <- getPropTable obj s <- getString (addr+1) zioWrite s exec1OP 0x8b val = {- return -} doReturn val exec1OP 0x8c off = {- jump -} do let offset :: Int16 offset = fromIntegral off - 2 -- not in zpec! modify (\st -> st {ptr = ptr st + fromIntegral offset}) exec1OP 0x8d paddr = {- print_paddr -} do addr <- decodeStringAddr paddr s <- getString addr zioWrite s exec1OP 0x8f r = {- call_1n -} doCall [r] Nothing exec0OP :: Val -> ZM () exec0OP 0xb0 = {- rtrue -} doReturn 1 exec0OP 0xb1 = {- rfalse -} doReturn 0 exec0OP 0xb2 = {- print -} do s <- getNextString zioWrite s exec0OP 0xb3 = {- print_ret -} do s <- getNextString zioWrite s zioWrite "\n" doReturn 1 exec0OP 0xb8 = {- ret_popped -} getVar 0 >>= doReturn exec0OP 0xba = {- quit -} liftIO $ exitWith ExitSuccess exec0OP 0xbb = {- new_line -} zioWrite "\n" exec0OP 0xbe = doEXT where doEXT = do op <- getNextByte args <- getVarArgs 0 execEXT op args execVAR :: Val -> [Val] -> ZM () execVAR 0xE0 args = {- call_vs -} do var <- getNextByte doCall args (Just var) execVAR 0xE1 [arr, idx, val] = {- storew -} putWord (fromIntegral $ arr+idx*2) val execVAR 0xE2 [arr, idx, val] = {- storeb -} putByte (fromIntegral $ arr+idx) val execVAR 0xE3 [obj, prop, val] = {- put_prop -} putProp obj prop val execVAR 0xE4 args = {- read -} doRead args execVAR 0xE5 [c] = {- print_char -} zioWrite $ [toEnum $ fromIntegral c] execVAR 0xE6 [n] = {- print_num -} zioWrite $ show n execVAR 0xE7 [range] = {- random -} case compare (fromIntegral range :: Int16) 0 of LT -> liftIO (setStdGen $ mkStdGen $ fromIntegral range) >> doStore 0 EQ -> liftIO (newStdGen >>= setStdGen) >> doStore 0 GT -> liftIO (randomRIO (1, fromIntegral range :: Int)) >>= doStore.fromIntegral execVAR 0xE8 [val] = {- push -} putVar 0 val execVAR 0xE9 [var] = {- pull -} getVar 0 >>= putVar var execVAR 0xEA [split] = {- split_window -} zioSplitWindow split execVAR 0xEB [win] = {- set_window -} zioSetWindow win execVAR 0xEC args = {- call_vs2 -} do var <- getNextByte doCall args (Just var) execVAR 0xED [win] = {- erase_window -} zioEraseWindow win execVAR 0xEF [x,y] = {- set_cursor -} zioSetCursor x y execVAR 0xF1 _ = {- set_text_style -} {- XXX implement -} return () --execVAR 0xF3 _ = {- output_stream -} {- XXX implement -} return () execVAR 0xF6 (1:_) = {- read_char -} zioReadChar >>= doStore.fromIntegral.fromEnum execVAR 0xF9 args = {- call_vn -} doCall args Nothing execVAR 0xFA args = {- call_vn2 -} doCall args Nothing execVAR 0xFB args = {- tokenise -} do let (text:parse:0{-dictionary-}:0{-flag-}:_) = args ++ [0,0] zTokenize parse (fromIntegral text) execVAR 0xFF [c] = {- check_arg_count -} liftM (c<=) (gets argCount) >>= doBranch execEXT :: Val -> [Val] -> ZM () execEXT 9 _ = {- save_undo -} do zs <- get put (zs { zs_undo = Just zs }) doStore 1 -- Reading -- XXX implement properly! doRead :: [Val] -> Control.Monad.State.Lazy.StateT ZState IO () doRead args = do let (text:parse:_:_:_) = args ++ repeat 0 line <- zioRead let textAddr = fromIntegral text textLen <- liftM fromIntegral $ getByte textAddr let line' = take textLen line line'' = map (fromIntegral . fromEnum) line' putByte (textAddr+1) (fromIntegral $ length line') zipWithM_ putByte [textAddr+2..] line'' doStore 10 if parse == 0 then return () else zTokenize parse textAddr -- Helper routines boolVal :: (Num t) => Bool -> t boolVal b = if b then 1 else 0 doStoreBranch :: Val -> ZM () doStoreBranch val = doStore val >> doBranch (val /= 0) doStore :: Val -> ZM () doStore x = do var <- getNextByte putVar var x skipBranch :: ZM() skipBranch = do x <- getNextByte let oneByte = testBit x 6 if oneByte then return () else getNextByte >> return () doBranch :: Bool -> ZM () doBranch predic = do x <- getNextByte let dir = testBit x 7 oneByte = testBit x 6 ofs1 :: Addr ofs1 = fromIntegral $ x .&. 63 ofs <- if oneByte then return ofs1 else do ofs2 <- liftM fromIntegral getNextByte let ofs' = (ofs1 * 256 + ofs2) return (if ofs' < 8192 then ofs' else ofs' - 16384) pos <- gets ptr if predic /= dir then return () else case ofs of 0 -> doReturn 0 1 -> doReturn 1 _ -> do st <- get put (st { ptr = ptr st + (fromIntegral ofs) - 2 }) doCall :: [Val] -> Maybe Val -> ZM () doCall (routine:args) var = do st <- get let frame = ZFrame { zfReturnAddr = ptr st, zfLocals = localVars st, zfReturnVar = var, zfArgCount = argCount st, zfEvalStack = localStack st } addr <- decodeRoutineAddr routine locals <- getByte addr put (st { stack = frame:stack st, localStack = [], localVars = listArray (0,locals) $ args ++ repeat 0, argCount = fromIntegral (length args), ptr = addr+1 }) return () doReturn :: Val -> ZM () doReturn retval = do st <- get let frame:frames = stack st put (st { stack = frames, localStack = zfEvalStack frame, localVars = zfLocals frame, argCount = zfArgCount frame, ptr = zfReturnAddr frame }) case zfReturnVar frame of Nothing -> return () Just x -> putVar x retval