-- 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) 2015 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. -- HGamer3D/ECS/System.hs {-# LANGUAGE ForeignFunctionInterface #-} -- | System of the Entity Component System for HGamer3D module HGamer3D.ECS.System ( SystemData (..), runSystem, addToWorld, removeFromWorld ) where import Data.Maybe import Data.Dynamic import Data.Typeable import Data.List as L import qualified Data.Map as M import Data.IORef import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as BU import Foreign import Foreign.C import Foreign.C.String import Foreign.Ptr import Control.Concurrent import Control.Applicative import HGamer3D.Binding import HGamer3D.Data import HGamer3D.ECS.Entity -- System -- ComponentListener, used internally in sytems type ComponentListener = IORef (Maybe (Entity, Entity)) componentListener :: ERef -> ComponentType a -> IO ComponentListener componentListener er@(ERef te tl) c = do tv <- newIORef Nothing let w e e' = atomicModifyIORef tv (\old -> let new = case old of Nothing -> Just (e, e') Just (o, o') -> Just (o, e') in (new, ())) addListener er c w return tv queryComponentListener :: ComponentListener -> IO (Maybe (Entity, Entity)) queryComponentListener tv = atomicModifyIORef tv (\val -> (Nothing, val)) {- 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 = (ERef, Either (ComponentListener, OnUpdateFunction) OnDeleteFunction) type SystemFunction = SystemData -> ERef -> IO [SystemRecord] -- | this data specifies the type of system data SystemData = SystemData { sdLock :: MVar (), sdNewERefs :: IORef [ERef], sdDelERefs :: IORef [ERef], sdRecords :: [SystemRecord], sdComponents :: [Word64], sdProperties :: [Word64], sdEvents :: [Word64], sdCreateItem :: Word64 -> B.ByteString -> IO ( Int, Ptr () ), sdDestroyItem :: Word64 -> (Ptr ()) -> IO ((Int)), sdGetMessageSender :: Word64 -> Word64 -> IO ((Int), (FunPtr (Ptr () -> Ptr CChar -> CInt -> IO CInt))), sdRegisterMessageReceiver :: Word64 -> Word64 -> (Ptr ()) -> (FunPtr (Ptr () -> Ptr CChar -> CInt -> IO CInt)) -> IO Int, sdErrorMessage :: (Int) -> IO ((String)) } addERef :: SystemData -> ERef -> IO () addERef sd eref = atomicModifyIORef (sdNewERefs sd) (\a -> (eref : a, ())) removeERef :: SystemData -> ERef -> IO () removeERef sd eref = atomicModifyIORef (sdDelERefs sd) (\a -> (eref : a, ())) stepRecord (er, Left (listener, updateF)) = do me <- queryComponentListener listener case me of Just (e, e') -> do updateF e e' return () -- stepRecord (er, Left (listener, updateF)) Nothing -> return () stepRecord (er, Right deleteF) = return () stepSystem :: SystemData -> IO Bool -> IO (SystemData, Bool) stepSystem sd@(SystemData lock nrefs drefs records cs ps es ci di gm rm em) stepF = do -- add and delete erefs adds <- atomicModifyIORef nrefs (\a -> ([],a)) dels <- atomicModifyIORef drefs (\a -> ([],a)) -- remove instances let delrecs = filter (\r -> (fst r) `elem` dels) records mapM (\r -> clearListeners (fst r)) delrecs mapM (\r -> case snd r of Right delF -> do delF -- execute delete function return () _ -> return ()) delrecs let records' = filter (\r -> not ((fst r) `elem` dels)) records -- add new instances newRecords <- mapM (systemFunction sd) (reverse adds) let records'' = (concat newRecords) ++ records' -- run specific stepSystem qFlag <- stepF -- run stepfunction on tuples mapM stepRecord records'' -- return new values let newSD = (SystemData lock nrefs drefs records'' cs ps es ci di gm rm em) return (newSD, qFlag) -- need to add quit condition here runS s stepF stepT = do nowT <- getTime (s', qFlag) <- stepSystem s stepF 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' stepF stepT -- | start a new thread, which runs the system runSystem :: IO Bool -> GameTime -> SystemData -> IO () runSystem stepF stepT systemData = do forkOS $ runS systemData stepF stepT return () -- called within the run loop systemFunction sd eref = do let components = sdComponents sd let properties = sdProperties sd let events = sdEvents sd let createItem = sdCreateItem sd let destroyItem = sdDestroyItem sd let getMessageSender = sdGetMessageSender sd let registerMessageReceiver = sdRegisterMessageReceiver sd let errorMessage = sdErrorMessage sd let r = [] e <- readE eref -- create system records, (ERef, Either (Listener, UdateF) DeleteF) rs <- mapM (\c -> if c `elem` components then do (res, rep) <- createItem c (e M.! c) -- create the item if res == 0 then do let ir = (eref, Right (destroyItem c rep >> return ())) -- add property records with listeners, also components can act as property prs <- mapM (\p -> if p `elem` (properties ++ components) then do (res', propF) <- getMessageSender c p if res' == 0 then do lp <- componentListener eref (ComponentType p) let uf = (\oe ne -> callMsgFunction propF rep (ne M.! p) >> return ()) uf e e -- call message function, update component with this property right away return [(eref, Left (lp, uf) )] else return [] else return [] ) (M.keys e) let prs' = concat prs -- add event writer, in case applicable mapM (\p -> if p `elem` events then do let fwrite = (\_ msgData msgLen -> do bData <- B.packCStringLen (msgData, fromIntegral msgLen) _setC' eref p bData return 0) fwritePtr <- mkMsgFunPtr fwrite registerMessageReceiver c p rep fwritePtr -- we would also need to delete the funptr later with "freeHaskellFunPtr" currently not implemented return () else return () ) (M.keys e) return $ (ir : prs') else return [] else return [] ) (M.keys e) return $ concat rs shutdownSystem :: SystemData -> IO () shutdownSystem system = print "Shutdown System received" >> return () -- management of systems -- -- | add an ERef to the world, thread safe addToWorld :: [SystemData] -> ERef -> IO () addToWorld systems e = mapM (\s -> addERef s e) systems >> return () -- | remove an ERef from the world, thread safe removeFromWorld :: [SystemData] -> ERef -> IO () removeFromWorld systems e = mapM (\s -> removeERef s e) systems >> return ()