module ZMachine.Objects where

import ZMachine.Base

import Data.Bits
import Control.Monad (liftM)
import Control.Monad.State.Lazy (StateT) -- for a type sig

getObjectAddr :: Val -> ZM Addr
getObjectAddr 0   = error "vile object 0 from hell error"
getObjectAddr obj =
    do table <- getWord 0x0a
       return (fromIntegral $ table + 2*63 + 14*(obj-1))

getParent, getSibling, getChild :: Val -> ZM Val
getParent 0   = return 0
getParent obj =
    do objAddr <- getObjectAddr obj
       getWord (objAddr + 6)

getSibling 0   = return 0
getSibling obj =
    do objAddr <- getObjectAddr obj
       getWord (objAddr + 8)

getChild 0   = return 0
getChild obj =
    do objAddr <- getObjectAddr obj
       getWord (objAddr + 10)

putParent, putSibling, putChild :: Val -> Val -> ZM ()
putParent obj val =
    do objAddr <- getObjectAddr obj
       putWord (objAddr + 6) val

putSibling obj val =
    do objAddr <- getObjectAddr obj
       putWord (objAddr + 8) val

putChild obj val =
    do objAddr <- getObjectAddr obj
       putWord (objAddr + 10) val


-- Object motion
removeObj :: Val -> Control.Monad.State.Lazy.StateT ZState IO ()
removeObj obj =
    do parent <- getParent obj
       if parent == 0 then return () else do
       nextsibling <- getChild parent
       if nextsibling == obj
          then getSibling obj >>= putChild parent
          else loop nextsibling
       putParent obj 0
       putSibling obj 0
    where loop sibling =
              do nextsibling <- getSibling sibling
                 if nextsibling /= obj
                    then loop nextsibling
                    else do getSibling obj >>= putSibling sibling

insertObj :: Val -> Val -> StateT ZState IO ()
insertObj 0   _    = return ()
insertObj _   0    = return ()
insertObj obj dest =
    do removeObj obj
       putParent obj dest
       getChild dest >>= putSibling obj
       putChild dest obj


-- Attribute handling

attrThing :: (Addr -> Int -> ZM a) -> Val -> Val -> ZM a
attrThing f obj attr =
    do addr <- liftM (+(fromIntegral $ attr `div` 8))
                     (getObjectAddr obj)
       let bit' = 7 - (fromIntegral $ attr `mod` 8)
       f addr bit'

getAttr :: Val -> Val -> ZM Bool
getAttr = attrThing f
    where
    f addr bit' =
        do byte <- getByte addr
           return $ testBit byte bit'

setAttr :: Val -> Val -> ZM ()
setAttr 0   _    = return ()
setAttr obj attr = attrThing f obj attr
    where
    f addr bit' =
        do byte <- getByte addr
           putByte addr $ setBit byte bit'

clearAttr :: Val -> Val -> ZM ()
clearAttr 0   _    = return ()
clearAttr obj attr = attrThing f obj attr
    where
    f addr bit' =
        do byte <- getByte addr
           putByte addr $ clearBit byte bit'

-- Property handling

getPropTable :: Val -> ZM Addr
getPropTable obj =
    do objAddr <- getObjectAddr obj
       liftM fromIntegral (getWord (objAddr + 12))

getProp :: Val -> Val -> ZM Val
getProp obj prop =
    do addr <- getPropAddr obj prop
       val <- if addr == 0
              then do table <- getWord 0xa
                      getWord (fromIntegral $ table + 2*(prop-1))
              else do len <- getPropLen addr
                      ((case len of { 1 -> getByte; 2 -> getWord })
                       (fromIntegral addr))
       -- liftIO $ putStrLn (" -> " ++ show val)
       return val



putProp :: Val -> Val -> Val -> ZM ()
putProp obj prop val =
    do addr <- getPropAddr obj prop
       len <- getPropLen addr
       (case len of { 1 -> putByte ; 2 -> putWord }) (fromIntegral addr) val

getPropAddr :: Val -> Val -> ZM Val
getPropAddr 0   _   = return 0
getPropAddr obj num =
    do -- liftIO $ putStr ("@get_prop_addr " ++ show obj ++ " " ++ show num)
       table <- getPropTable obj
       shortnameWords <- getByte table
       addr <- loop (table + 1 + fromIntegral shortnameWords*2)
       -- liftIO $ putStrLn (" -> " ++ show addr)
       return addr
    where
    loop addr = do s <- getByte addr
                   let num' = s .&. 63
                   case () of
                       _ | testBit s 7 -> do t <- getByte (addr+1)
                                             let size = case t .&. 63 of
                                                        0 -> 64
                                                        n -> n
                                             loop' (addr+2) num' size
                         | testBit s 6 -> loop' (addr+1) num' 2
                         | otherwise   -> loop' (addr+1) num' 1
    loop' addr num' size
        | num' > num  = loop (addr+fromIntegral size)
        | num' == num = return (fromIntegral addr)
        | num' < num  = return 0

getPropLen :: Val -> ZM Val
getPropLen 0    = error "attempt to get length of nonexistant property"
getPropLen addr =
    do let addr' = fromIntegral addr
       x <- getByte (addr'-1)
       if testBit x 7
          then return (case x .&. 63 of
                       0 -> 64
                       n -> n)
          else return (if testBit x 6 then 2 else 1)

getNextProp :: Val -> Val -> ZM Val
getNextProp 0   _    = return 0
getNextProp obj 0    =
    do table <- getPropTable obj
       shortnameWords <- getByte table
       liftM (63 .&.) $ getByte (table + 1 + fromIntegral shortnameWords*2)
getNextProp obj prop =
    do addr <- getPropAddr obj prop
       len <- getPropLen addr
       nextprop <- liftM (63 .&.) $ getByte (fromIntegral $ addr+len)
       return nextprop