module HGamer3D.Common.ECS
where
import Data.Maybe
import Data.Dynamic
import Data.Typeable
import qualified Data.Map as M
import Data.IORef
import Control.Concurrent
import Control.Concurrent.STM
import Control.Applicative
import HGamer3D.Data
data Component = CTPos
| CTOri
| CTSiz
| CTSca
| CTFig
| CTASr
| CTALs
| CTCam
| CTLig
| CTScP
| CTGFo
| CTWin
| CTCmd
| CTEvt
deriving (Eq, Ord, Show)
type Entity = M.Map Component Dynamic
(#:) :: Typeable a => Component -> a -> (Component, Dynamic)
c #: val = (c, toDyn val)
entity :: [(Component, Dynamic)] -> Entity
entity clist = M.fromList clist
(#?) :: Entity -> Component -> Bool
e #? c = elem c $ M.keys e
(#) :: Typeable a => Entity -> Component -> a
e # c = fromJust $ M.lookup c e >>= fromDynamic
(?#) :: Typeable a => Entity -> Component -> Maybe a
e ?# c = M.lookup c e >>= fromDynamic
updateEntity :: Typeable a => Entity -> Component -> (a -> a) -> Entity
updateEntity e c f = M.insert c ((toDyn . f) (e # c)) e
_setComponent :: Typeable a => Entity -> Component -> a -> Entity
_setComponent e c val = M.insert c (toDyn val) e
type Listeners = TVar (M.Map Component [Entity -> Entity -> IO ()])
addListener :: Listeners -> Component -> (Entity -> Entity -> IO ()) -> IO ()
addListener tls c l = atomically $ do
ls <- readTVar tls
let l' = case M.lookup c ls of
Just ol -> (l:ol)
Nothing -> [l]
writeTVar tls (M.insert c l' ls)
clearAllListeners :: Listeners -> IO ()
clearAllListeners tls = atomically $ do
ls <- readTVar tls
writeTVar tls (M.fromList [])
return ()
fireListeners :: Listeners -> Component -> Entity -> Entity -> IO ()
fireListeners tls c val val' = do
ls <- atomically $ readTVar tls
case M.lookup c ls of
Just l -> mapM (\f -> f val val') l >> return ()
Nothing -> return ()
data ERef = ERef (TVar Entity) Listeners deriving (Eq)
newE :: [(Component, Dynamic)] -> IO ERef
newE inlist = do
let e = entity (inlist ++ [CTCmd #: (), CTEvt #: ()])
te <- newTVarIO e
tl <- newTVarIO (M.fromList [])
return $ ERef te tl
readE :: ERef -> IO Entity
readE (ERef te _) = atomically $ readTVar te
updateE :: Typeable a => ERef -> Component -> (a -> a) -> IO ()
updateE (ERef te tl) c f = do
(val, val') <- atomically $ do
e <- readTVar te
let e' = updateEntity e c f
seq e' (writeTVar te e')
return (e, e')
fireListeners tl c val val'
return ()
_setE :: Typeable a => ERef -> Component -> a -> IO ()
_setE (ERef te tl) c val = do
(eold, enew) <- atomically $ do
e <- readTVar te
let e' = _setComponent e c val
seq e' (writeTVar te e')
return (e, e')
fireListeners tl c eold enew
return ()
sendCmd :: Typeable a => ERef -> a -> IO ()
sendCmd eref cmd = _setE eref CTCmd cmd
sendEvt :: Typeable a => ERef -> a -> IO ()
sendEvt eref cmd = _setE eref CTEvt cmd
regEvtH :: Typeable a => ERef -> (a -> IO ()) -> IO ()
regEvtH (ERef te tl) h = addListener tl CTEvt (\_ e' -> case (e' ?# CTEvt) of
Just val -> h val
Nothing -> return () )
type ComponentListener = (TVar (Maybe (Entity, Entity)))
componentListener :: ERef -> Component -> IO ComponentListener
componentListener er@(ERef te tl) c = do
tv <- newTVarIO Nothing
let w e e' = do
seq e (atomically $ writeTVar tv (Just (e, e')))
return ()
addListener tl c w
return tv
queryComponentListener :: ComponentListener -> IO (Maybe (Entity, Entity))
queryComponentListener tv = do
atomically $ do
v <- readTVar tv
writeTVar tv Nothing
return v
type OnUpdateFunction = Entity -> Entity -> IO ()
type OnDeleteFunction = IO ()
type SystemRecord = (ComponentListener, OnUpdateFunction, OnDeleteFunction)
type SystemFunction a = a -> ERef -> IO [SystemRecord]
data SystemData a = SystemData {
sdLock :: MVar (),
sdNewERefs :: IORef [ERef],
sdDelERefs :: IORef [ERef],
sdRecords :: [SystemRecord],
sdSystem :: a,
sdSystemFunction :: SystemFunction a
}
class System a where
initializeSystem :: IO (SystemData a)
stepSystem :: (SystemData a) -> IO Bool
addERef :: (SystemData a) -> ERef -> IO ()
addERef sd eref = do
let ref = sdNewERefs sd
let lock = sdLock sd
takeMVar lock
nrefs <- readIORef ref
writeIORef ref (eref : nrefs)
putMVar lock ()
return ()
removeERef :: (SystemData a) -> ERef -> IO ()
removeERef sd eref = do
let ref = sdDelERefs sd
let lock = sdLock sd
takeMVar lock
drefs <- readIORef ref
writeIORef ref (eref : drefs)
putMVar lock ()
return ()
runSystem :: GameTime -> IO (SystemData a)
runSystem stepT = do
mv <- newEmptyMVar
forkOS $ (\mv' -> do
status <- initializeSystem
putMVar mv' status
let runS s = do
nowT <- getTime
(s', qFlag) <- stepSystem' s
if qFlag then do
shutdownSystem s'
return ()
else do
nowT' <- getTime
let timeUsed = nowT' nowT
if timeUsed < stepT then do
threadDelay ((fromIntegral . usec) (stepT timeUsed) )
else do
return ()
runS s'
runS status
) mv
status' <- takeMVar mv
return status'
shutdownSystem :: (SystemData a) -> IO ()
shutdownSystem system = return ()
stepSystem' :: (SystemData a) -> IO ((SystemData a), Bool)
stepSystem' sd@(SystemData lock nrefs drefs records system systemfunction) = do
takeMVar lock
adds <- readIORef nrefs
writeIORef nrefs []
dels <- readIORef drefs
writeIORef drefs []
putMVar lock ()
newRecords <- mapM ((sdSystemFunction sd)(sdSystem sd)) adds
let records' = (concat newRecords) ++ records
let records'' = records'
let stepRecord (listener, updateF, deleteF) = do
me <- queryComponentListener listener
case me of
Just (e, e') -> updateF e e'
Nothing -> return ()
mapM stepRecord records''
let newSD = (SystemData lock nrefs drefs records'' system systemfunction)
qFlag <- stepSystem newSD
return (newSD, qFlag)
data SomeSystem = forall a . System a => SomeSystem (SystemData a)
(#+) :: [SomeSystem] -> [SomeSystem] -> [SomeSystem]
vals #+ vals' = vals ++ vals'
infixr #+
addToWorld :: [SomeSystem] -> ERef -> IO ()
addToWorld systems e = mapM (f e) systems >> return () where
f e (SomeSystem sd) = addERef sd e >> return ()
removeFromWorld :: [SomeSystem] -> ERef -> IO ()
removeFromWorld systems e = mapM (f e) systems >> return () where
f e (SomeSystem sd) = removeERef sd e >> return ()