module Fresco.Entity (
(#:),
Entity (..),
newE,
delE,
idE,
readC,
updateC,
setC,
ObjectLibSystem (..),
createOLS,
stepOLS,
addEntityOLS,
CallbackSystem (..),
createCBS,
stepCBS,
registerReceiverCBS,
)
where
import Data.Maybe
import Data.ByteString.Lazy
import Data.ByteString (packCStringLen)
import qualified Data.Map as M
import Data.IORef
import Control.Concurrent
import Control.Applicative
import Foreign
import Foreign.C
import Data.Binary.Serialise.CBOR
import Data.Binary.Serialise.CBOR.Term
import Fresco.System
import Fresco.Component
import Numeric (showHex)
type EntityData = M.Map Word64 Component
(#:) :: Serialise a => ComponentType a -> a -> (Word64, Component)
(ComponentType c) #: val = (c, toMsg val)
entityData :: [(Word64, Component)] -> EntityData
entityData clist = M.fromList clist
(#?) :: EntityData -> ComponentType a -> Bool
e #? (ComponentType c) = Prelude.elem c $ M.keys e
(#!) :: Serialise a => EntityData -> ComponentType a -> a
e #! (ComponentType c) = fromJust $ M.lookup c e >>= fromMsg
(#) :: Serialise a => EntityData -> ComponentType a -> Maybe a
e # (ComponentType c) = case M.lookup c e of
Nothing -> Nothing
Just msg -> fromMsg msg
updateDataC :: Serialise a => EntityData -> ComponentType a -> (a -> a) -> EntityData
updateDataC e c'@(ComponentType c) f = M.insert c ((toMsg . f) (e #! c')) e
setDataC :: Serialise a => EntityData -> ComponentType a -> a -> EntityData
setDataC e (ComponentType c) val = M.insert c (toMsg val) e
data CallbackSystem = CallbackSystem (Ptr ())
createCBS :: IO CallbackSystem
createCBS = do
cbs <- callbackSystemCreate
return $ CallbackSystem cbs
stepCBS :: CallbackSystem -> IO ()
stepCBS (CallbackSystem cbs) = callbackSystemStep cbs
registerReceiverCBS :: Serialise a => CallbackSystem -> Entity -> ComponentType a -> (a -> IO ()) -> IO ()
registerReceiverCBS (CallbackSystem cbs) (Entity ep) (ComponentType ct) f = do
let f' = \_ _ cdata len -> do
bs <- packCStringLen (cdata, fromIntegral len)
let c = fromMsg (fromStrict bs)
f c
return 0
mf <- mkMsgEntityFnPtr f'
callbackSystemRegisterReceiver cbs ep ct mf
return ()
data ObjectLibSystem = ObjectLibSystem (Ptr ())
createOLS :: IO ObjectLibSystem
createOLS = do
ols <- objectLibSystemCreate "GIORNATA\0"
return $ ObjectLibSystem ols
stepOLS :: ObjectLibSystem -> IO ()
stepOLS (ObjectLibSystem ols) = objectLibSystemStep ols
addEntityOLS :: ObjectLibSystem -> Entity -> IO ()
addEntityOLS (ObjectLibSystem ols) (Entity ep) = objectLibSystemAddEntity ols ep
type Listeners = ()
data Entity = Entity (Ptr ()) deriving (Eq)
msgFromE :: [(Word64, Component)] -> Component
msgFromE ed = let
bs = Prelude.map (\(a, b) -> Data.ByteString.Lazy.concat [toMsg a, toMsg b]) ed
in Data.ByteString.Lazy.concat bs
prettyPrint :: ByteString -> String
prettyPrint = Prelude.concat . Prelude.map (flip showHex " ") . unpack
newE :: [(Word64, Component)] -> IO Entity
newE inlist = do
let msg = msgFromE inlist
ep <- entityCreate msg
return $ Entity ep
delE :: Entity -> IO ()
delE (Entity ep) = entityDestroy ep
idE :: Entity -> IO ByteString
idE (Entity ep) = entityId ep
readC :: Serialise a => Entity -> ComponentType a -> IO a
readC (Entity ep) (ComponentType ct) = do
bs <- entityRead ep ct
return (fromMsg bs)
updateC :: Serialise a => Entity -> ComponentType a -> (a -> a) -> IO ()
updateC er@(Entity ep) c f = do
val <- readC er c
let val' = f val
setC er c val'
return ()
setC :: Serialise a => Entity -> ComponentType a -> a -> IO ()
setC er@(Entity ep) (ComponentType ct) val = do
entityWrite ep ct (toMsg val)
return ()