{-# Language ExistentialQuantification #-}
{-# OPTIONS_HADDOCK hide #-}
-- This source file is part of HGamer3D
-- (A project to enable 3D game development in Haskell)
-- For the latest info, see http://www.althainz.de/HGamer3D.html
--
-- (c) 2014 Peter Althainz
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-- | The Entity Component System for HGamer3D
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
-- Components
-- | Possible Components, which are known, this list needs to be extended, if
-- additional components are introduced. Each component can occur only once in
-- an Entity.
data Component = CTPos -- ^ Position
| CTOri -- ^ Orientation
| CTSiz -- ^ Size
| CTSca -- ^ Scale
| CTFig -- ^ Figure
| CTASr -- ^ Audio Source
| CTALs -- ^ Audio Listener
| CTCam -- ^ Camera
| CTLig -- ^ Light
| CTScP -- ^ Scene Parameter
| CTGFo -- ^ GUI Form
| CTWin -- ^ Window
| CTCmd -- ^ internal, used for sending commands, created automatically
| CTEvt -- ^ internal, used for receiving events, created automatically
deriving (Eq, Ord, Show)
-- | Entities
-- | Entity, Maps from Component to Dynamic
type Entity = M.Map Component Dynamic
-- | Pair builder for nice construction syntax, allows [ ct #: val, ...] syntax
(#:) :: Typeable a => Component -> a -> (Component, Dynamic)
c #: val = (c, toDyn val)
-- | Builder for entities, allows newE = entity [ct #: val, ...] syntax
entity :: [(Component, Dynamic)] -> Entity
entity clist = M.fromList clist
-- | does the entity have the component
(#?) :: Entity -> Component -> Bool
e #? c = elem c $ M.keys e
-- | get the component, throws exception, if component not present, or wrong type
(#) :: Typeable a => Entity -> Component -> a
e # c = fromJust $ M.lookup c e >>= fromDynamic
-- | get the component as an maybe, in case wrong type
(?#) :: Typeable a => Entity -> Component -> Maybe a
e ?# c = M.lookup c e >>= fromDynamic
-- | modification function, throws exception, if component not present
updateEntity :: Typeable a => Entity -> Component -> (a -> a) -> Entity
updateEntity e c f = M.insert c ((toDyn . f) (e # c)) e
-- | modification function, sets entity component, needed for events
_setComponent :: Typeable a => Entity -> Component -> a -> Entity
_setComponent e c val = M.insert c (toDyn val) e
-- References to Entities
-- besides Entity, we need atomic references to entities, we call them ERef
-- ERefs also have listeners for updates
-- Listener Map, for each k, manages a map of writers, writers geting the old and the new value after a change
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 ()
-- ERef, composable objects, referenced Entities with listeners
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 () )
-- ComponentListener
-- | ComponentListener are tracking the change of a component of a specific entity. Ones this component changes, they contain the latest value of the entity. ComponentListener are implemented with the Listener mechanism for ERefs
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
-- System
{-
A system reacts towards changes/updates in entities and their components. The system does it by creating for each component it handles an internal represenation, which it modifies upon changes to this component and to potentially additional changes in other components. For example an entity representing a light could have a Light component, which is created and modified upon change in the light component data. The entity may well have also a position component and the light entity is moved, in case the position component is modified.
In general the system works by keeping a list of component listener on each added (each observes one component of an entity) and functions, which are called, in case the component listener exhibits a component change.
-}
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
-- to be implemented by instances
initializeSystem :: IO (SystemData a)
stepSystem :: (SystemData a) -> IO Bool
-- to be called from outside the runloop
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'
-- called within the run loop
shutdownSystem :: (SystemData a) -> IO ()
shutdownSystem system = return ()
stepSystem' :: (SystemData a) -> IO ((SystemData a), Bool)
stepSystem' sd@(SystemData lock nrefs drefs records system systemfunction) = do
-- add and delete erefs
takeMVar lock
adds <- readIORef nrefs
writeIORef nrefs []
dels <- readIORef drefs
writeIORef drefs []
putMVar lock ()
-- add new instances
newRecords <- mapM ((sdSystemFunction sd)(sdSystem sd)) adds
let records' = (concat newRecords) ++ records
-- remove instances
-- to be done
let records'' = records'
-- run stepfunction on tuples
let stepRecord (listener, updateF, deleteF) = do
me <- queryComponentListener listener
case me of
Just (e, e') -> updateF e e'
Nothing -> return ()
mapM stepRecord records''
-- run specific stepSystem
let newSD = (SystemData lock nrefs drefs records'' system systemfunction)
qFlag <- stepSystem newSD
-- return new values
return (newSD, qFlag) -- need to add quit condition here
-- management of systems
--
data SomeSystem = forall a . System a => SomeSystem (SystemData a)
(#+) :: [SomeSystem] -> [SomeSystem] -> [SomeSystem]
vals #+ vals' = vals ++ vals'
infixr #+
-- ECS World functions, to manage entities in systems
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 ()