module Mischief.ECS.World
(
World (..),
newWorld,
setSystemId,
setDeferred,
setPrefs,
forkPrefs,
Frame (..),
SystemTools (..),
worldGet,
worldGetRAny,
worldSet,
worldSpawnByInsert,
System (..),
SystemId (..),
runSystem,
MonadSystem,
unsafeGetWorld,
ParSystem (..),
ParWorld (..),
)
where
import Colog qualified
import Control.Concurrent.STM (TVar, newTVarIO)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Primitive (PrimMonad (..), RealWorld)
import Control.Monad.Reader.Class (MonadReader (..), asks)
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Trans.Reader (ReaderT (runReaderT))
import Data.Data
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Mischief.ECS.Archetypes (Archetypes, emptyArchetypes)
import Mischief.ECS.Collectable
import Mischief.ECS.Components
( Component (RelExclusivity),
Components,
Exclusivity (..),
Rel,
Tick (Tick),
emptyComponents,
)
import Mischief.ECS.Components.Bundle
import Mischief.ECS.Entities
( Entities,
Entity (Entity),
emptyEntities,
)
import Mischief.ECS.EventDef
import Mischief.ECS.Hidden
import Mischief.ECS.Mappable
import Mischief.ECS.Tables (Tables, emptyTables)
import Mischief.ECS.World.Prefs (WorldPrefs, newPrefs)
import Mischief.ECS.World.Query.QueryType
data World = World
{
World -> Archetypes
archetypes :: Archetypes,
World -> Components
components :: Components,
World -> Entities
entities :: Entities,
World -> Tables
tables :: Tables,
World -> IORef [ErasedEvent]
events :: IORef [ErasedEvent],
World -> IORef [System ()]
deferred :: IORef [System ()],
World -> TVar [System ()]
deferredAsync :: TVar [System ()],
World -> IORef Tick
tick :: IORef Tick,
World -> SystemId
systemId :: SystemId,
World -> IORef Frame
frame :: IORef Frame,
World -> WorldPrefs
prefs :: WorldPrefs,
World -> LogAction IO Message
logger :: Colog.LogAction IO Colog.Message,
World -> SystemTools
tools :: SystemTools
}
newtype Frame = Frame Int deriving (Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
(Int -> Frame -> ShowS)
-> (Frame -> String) -> ([Frame] -> ShowS) -> Show Frame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Frame -> ShowS
showsPrec :: Int -> Frame -> ShowS
$cshow :: Frame -> String
show :: Frame -> String
$cshowList :: [Frame] -> ShowS
showList :: [Frame] -> ShowS
Show, Frame -> Frame -> Bool
(Frame -> Frame -> Bool) -> (Frame -> Frame -> Bool) -> Eq Frame
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Frame -> Frame -> Bool
== :: Frame -> Frame -> Bool
$c/= :: Frame -> Frame -> Bool
/= :: Frame -> Frame -> Bool
Eq, Eq Frame
Eq Frame =>
(Frame -> Frame -> Ordering)
-> (Frame -> Frame -> Bool)
-> (Frame -> Frame -> Bool)
-> (Frame -> Frame -> Bool)
-> (Frame -> Frame -> Bool)
-> (Frame -> Frame -> Frame)
-> (Frame -> Frame -> Frame)
-> Ord Frame
Frame -> Frame -> Bool
Frame -> Frame -> Ordering
Frame -> Frame -> Frame
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Frame -> Frame -> Ordering
compare :: Frame -> Frame -> Ordering
$c< :: Frame -> Frame -> Bool
< :: Frame -> Frame -> Bool
$c<= :: Frame -> Frame -> Bool
<= :: Frame -> Frame -> Bool
$c> :: Frame -> Frame -> Bool
> :: Frame -> Frame -> Bool
$c>= :: Frame -> Frame -> Bool
>= :: Frame -> Frame -> Bool
$cmax :: Frame -> Frame -> Frame
max :: Frame -> Frame -> Frame
$cmin :: Frame -> Frame -> Frame
min :: Frame -> Frame -> Frame
Ord)
newtype SystemId = SystemId {SystemId -> Entity
id :: Entity} deriving (Int -> SystemId -> ShowS
[SystemId] -> ShowS
SystemId -> String
(Int -> SystemId -> ShowS)
-> (SystemId -> String) -> ([SystemId] -> ShowS) -> Show SystemId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SystemId -> ShowS
showsPrec :: Int -> SystemId -> ShowS
$cshow :: SystemId -> String
show :: SystemId -> String
$cshowList :: [SystemId] -> ShowS
showList :: [SystemId] -> ShowS
Show, SystemId -> SystemId -> Bool
(SystemId -> SystemId -> Bool)
-> (SystemId -> SystemId -> Bool) -> Eq SystemId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SystemId -> SystemId -> Bool
== :: SystemId -> SystemId -> Bool
$c/= :: SystemId -> SystemId -> Bool
/= :: SystemId -> SystemId -> Bool
Eq, Eq SystemId
Eq SystemId =>
(SystemId -> SystemId -> Ordering)
-> (SystemId -> SystemId -> Bool)
-> (SystemId -> SystemId -> Bool)
-> (SystemId -> SystemId -> Bool)
-> (SystemId -> SystemId -> Bool)
-> (SystemId -> SystemId -> SystemId)
-> (SystemId -> SystemId -> SystemId)
-> Ord SystemId
SystemId -> SystemId -> Bool
SystemId -> SystemId -> Ordering
SystemId -> SystemId -> SystemId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SystemId -> SystemId -> Ordering
compare :: SystemId -> SystemId -> Ordering
$c< :: SystemId -> SystemId -> Bool
< :: SystemId -> SystemId -> Bool
$c<= :: SystemId -> SystemId -> Bool
<= :: SystemId -> SystemId -> Bool
$c> :: SystemId -> SystemId -> Bool
> :: SystemId -> SystemId -> Bool
$c>= :: SystemId -> SystemId -> Bool
>= :: SystemId -> SystemId -> Bool
$cmax :: SystemId -> SystemId -> SystemId
max :: SystemId -> SystemId -> SystemId
$cmin :: SystemId -> SystemId -> SystemId
min :: SystemId -> SystemId -> SystemId
Ord)
newWorld :: SystemTools -> IO World
newWorld :: SystemTools -> IO World
newWorld SystemTools
tools = do
archetypes <- IO Archetypes
emptyArchetypes
components <- emptyComponents
entities <- emptyEntities
tables <- emptyTables
deferred <- newIORef []
deferredAsync <- newTVarIO []
events <- newIORef []
tick <- newIORef (Tick (0, 0))
frame <- newIORef (Frame 0)
let prefs = WorldPrefs
newPrefs
let logger = (Message -> Text) -> LogAction IO Text -> LogAction IO Message
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap Message -> Text
Colog.fmtMessage LogAction IO Text
forall (m :: * -> *). MonadIO m => LogAction m Text
Colog.logTextStdout
return
World
{ archetypes,
components,
entities,
tables,
events,
deferred,
deferredAsync,
tick,
systemId = SystemId (Entity (# 0##, 0## #)),
frame,
prefs,
logger,
tools
}
setSystemId :: SystemId -> World -> World
setSystemId :: SystemId -> World -> World
setSystemId SystemId
systemId World
world = World
world {systemId}
setDeferred :: IORef [System ()] -> World -> World
setDeferred :: IORef [System ()] -> World -> World
setDeferred IORef [System ()]
deferred World
world = World
world {deferred}
setPrefs :: WorldPrefs -> World -> World
setPrefs :: WorldPrefs -> World -> World
setPrefs WorldPrefs
prefs World
world = World
world {prefs}
newtype System a = System (ReaderT (Hidden World) IO a)
deriving newtype ((forall a b. (a -> b) -> System a -> System b)
-> (forall a b. a -> System b -> System a) -> Functor System
forall a b. a -> System b -> System a
forall a b. (a -> b) -> System a -> System b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> System a -> System b
fmap :: forall a b. (a -> b) -> System a -> System b
$c<$ :: forall a b. a -> System b -> System a
<$ :: forall a b. a -> System b -> System a
Functor, Functor System
Functor System =>
(forall a. a -> System a)
-> (forall a b. System (a -> b) -> System a -> System b)
-> (forall a b c.
(a -> b -> c) -> System a -> System b -> System c)
-> (forall a b. System a -> System b -> System b)
-> (forall a b. System a -> System b -> System a)
-> Applicative System
forall a. a -> System a
forall a b. System a -> System b -> System a
forall a b. System a -> System b -> System b
forall a b. System (a -> b) -> System a -> System b
forall a b c. (a -> b -> c) -> System a -> System b -> System c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> System a
pure :: forall a. a -> System a
$c<*> :: forall a b. System (a -> b) -> System a -> System b
<*> :: forall a b. System (a -> b) -> System a -> System b
$cliftA2 :: forall a b c. (a -> b -> c) -> System a -> System b -> System c
liftA2 :: forall a b c. (a -> b -> c) -> System a -> System b -> System c
$c*> :: forall a b. System a -> System b -> System b
*> :: forall a b. System a -> System b -> System b
$c<* :: forall a b. System a -> System b -> System a
<* :: forall a b. System a -> System b -> System a
Applicative, Applicative System
Applicative System =>
(forall a b. System a -> (a -> System b) -> System b)
-> (forall a b. System a -> System b -> System b)
-> (forall a. a -> System a)
-> Monad System
forall a. a -> System a
forall a b. System a -> System b -> System b
forall a b. System a -> (a -> System b) -> System b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. System a -> (a -> System b) -> System b
>>= :: forall a b. System a -> (a -> System b) -> System b
$c>> :: forall a b. System a -> System b -> System b
>> :: forall a b. System a -> System b -> System b
$creturn :: forall a. a -> System a
return :: forall a. a -> System a
Monad, Monad System
Monad System => (forall a. IO a -> System a) -> MonadIO System
forall a. IO a -> System a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> System a
liftIO :: forall a. IO a -> System a
MonadIO, MonadReader (Hidden World), Monad System
Monad System => (forall a. String -> System a) -> MonadFail System
forall a. String -> System a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> System a
fail :: forall a. String -> System a
MonadFail)
runSystem :: System a -> World -> IO a
runSystem :: forall a. System a -> World -> IO a
runSystem (System !ReaderT (Hidden World) IO a
r) World
w = ReaderT (Hidden World) IO a -> Hidden World -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Hidden World) IO a
r (World -> Hidden World
forall a. a -> Hidden a
hide World
w)
instance PrimMonad System where
type PrimState System = PrimState IO
primitive :: forall a.
(State# (PrimState System) -> (# State# (PrimState System), a #))
-> System a
primitive = ReaderT (Hidden World) IO a -> System a
forall a. ReaderT (Hidden World) IO a -> System a
System (ReaderT (Hidden World) IO a -> System a)
-> ((State# RealWorld -> (# State# RealWorld, a #))
-> ReaderT (Hidden World) IO a)
-> (State# RealWorld -> (# State# RealWorld, a #))
-> System a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT (Hidden World) IO a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (Hidden World) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT (Hidden World) IO a)
-> ((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)
-> (State# RealWorld -> (# State# RealWorld, a #))
-> ReaderT (Hidden World) IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
(State# (PrimState IO) -> (# State# (PrimState IO), a #)) -> IO a
forall a.
(State# (PrimState IO) -> (# State# (PrimState IO), a #)) -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive
forkPrefs :: (WorldPrefs -> WorldPrefs) -> System a -> System a
forkPrefs :: forall a. (WorldPrefs -> WorldPrefs) -> System a -> System a
forkPrefs WorldPrefs -> WorldPrefs
f System a
s = do
world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
let world' = WorldPrefs -> World -> World
setPrefs (WorldPrefs -> WorldPrefs
f World
world.prefs) World
world
liftIO $ runSystem s world'
data ParWorld = ParWorld
{
ParWorld -> Hidden World
world :: Hidden World,
ParWorld -> IORef [System ()]
parDeferred :: IORef [System ()]
}
newtype ParSystem a = ParSystem (ReaderT ParWorld IO a)
deriving newtype ((forall a b. (a -> b) -> ParSystem a -> ParSystem b)
-> (forall a b. a -> ParSystem b -> ParSystem a)
-> Functor ParSystem
forall a b. a -> ParSystem b -> ParSystem a
forall a b. (a -> b) -> ParSystem a -> ParSystem b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ParSystem a -> ParSystem b
fmap :: forall a b. (a -> b) -> ParSystem a -> ParSystem b
$c<$ :: forall a b. a -> ParSystem b -> ParSystem a
<$ :: forall a b. a -> ParSystem b -> ParSystem a
Functor, Functor ParSystem
Functor ParSystem =>
(forall a. a -> ParSystem a)
-> (forall a b. ParSystem (a -> b) -> ParSystem a -> ParSystem b)
-> (forall a b c.
(a -> b -> c) -> ParSystem a -> ParSystem b -> ParSystem c)
-> (forall a b. ParSystem a -> ParSystem b -> ParSystem b)
-> (forall a b. ParSystem a -> ParSystem b -> ParSystem a)
-> Applicative ParSystem
forall a. a -> ParSystem a
forall a b. ParSystem a -> ParSystem b -> ParSystem a
forall a b. ParSystem a -> ParSystem b -> ParSystem b
forall a b. ParSystem (a -> b) -> ParSystem a -> ParSystem b
forall a b c.
(a -> b -> c) -> ParSystem a -> ParSystem b -> ParSystem c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> ParSystem a
pure :: forall a. a -> ParSystem a
$c<*> :: forall a b. ParSystem (a -> b) -> ParSystem a -> ParSystem b
<*> :: forall a b. ParSystem (a -> b) -> ParSystem a -> ParSystem b
$cliftA2 :: forall a b c.
(a -> b -> c) -> ParSystem a -> ParSystem b -> ParSystem c
liftA2 :: forall a b c.
(a -> b -> c) -> ParSystem a -> ParSystem b -> ParSystem c
$c*> :: forall a b. ParSystem a -> ParSystem b -> ParSystem b
*> :: forall a b. ParSystem a -> ParSystem b -> ParSystem b
$c<* :: forall a b. ParSystem a -> ParSystem b -> ParSystem a
<* :: forall a b. ParSystem a -> ParSystem b -> ParSystem a
Applicative, Applicative ParSystem
Applicative ParSystem =>
(forall a b. ParSystem a -> (a -> ParSystem b) -> ParSystem b)
-> (forall a b. ParSystem a -> ParSystem b -> ParSystem b)
-> (forall a. a -> ParSystem a)
-> Monad ParSystem
forall a. a -> ParSystem a
forall a b. ParSystem a -> ParSystem b -> ParSystem b
forall a b. ParSystem a -> (a -> ParSystem b) -> ParSystem b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. ParSystem a -> (a -> ParSystem b) -> ParSystem b
>>= :: forall a b. ParSystem a -> (a -> ParSystem b) -> ParSystem b
$c>> :: forall a b. ParSystem a -> ParSystem b -> ParSystem b
>> :: forall a b. ParSystem a -> ParSystem b -> ParSystem b
$creturn :: forall a. a -> ParSystem a
return :: forall a. a -> ParSystem a
Monad, Monad ParSystem
Monad ParSystem =>
(forall a. IO a -> ParSystem a) -> MonadIO ParSystem
forall a. IO a -> ParSystem a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> ParSystem a
liftIO :: forall a. IO a -> ParSystem a
MonadIO, MonadReader ParWorld, Monad ParSystem
Monad ParSystem =>
(forall a. String -> ParSystem a) -> MonadFail ParSystem
forall a. String -> ParSystem a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> ParSystem a
fail :: forall a. String -> ParSystem a
MonadFail, Monad ParSystem
Monad ParSystem =>
(forall a.
(State# (PrimState ParSystem)
-> (# State# (PrimState ParSystem), a #))
-> ParSystem a)
-> PrimMonad ParSystem
forall a.
(State# (PrimState ParSystem)
-> (# State# (PrimState ParSystem), a #))
-> ParSystem a
forall (m :: * -> *).
Monad m =>
(forall a.
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> PrimMonad m
$cprimitive :: forall a.
(State# (PrimState ParSystem)
-> (# State# (PrimState ParSystem), a #))
-> ParSystem a
primitive :: forall a.
(State# (PrimState ParSystem)
-> (# State# (PrimState ParSystem), a #))
-> ParSystem a
PrimMonad)
class GetWorld a where
getWorld :: a -> Hidden World
instance (GetWorld (Hidden World)) where
getWorld :: Hidden World -> Hidden World
getWorld = Hidden World -> Hidden World
forall a. a -> a
id
instance (GetWorld ParWorld) where
getWorld :: ParWorld -> Hidden World
getWorld ParWorld
x = ParWorld
x.world
class (GetWorld w, MonadReader w a, Applicative a, MonadFail a, Functor a, Monad a, MonadIO a, PrimMonad a, PrimState a ~ RealWorld) => MonadSystem w a
instance MonadSystem (Hidden World) System
instance MonadSystem ParWorld ParSystem
unsafeGetWorld :: (MonadSystem w m) => m World
unsafeGetWorld :: forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld = do
(w -> World) -> m World
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Hidden World -> World
forall a. Hidden a -> a
unhide (Hidden World -> World) -> (w -> Hidden World) -> w -> World
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Hidden World
forall a. GetWorld a => a -> Hidden World
getWorld)
instance EraseIntoStorage (System ()) [System ()] where
erase :: System () -> [System ()]
erase :: System () -> [System ()]
erase System ()
x = [System ()
x]
data SystemTools = SystemTools
{ SystemTools
-> forall c (m :: * -> *) w.
(MonadSystem w m, QueryType c) =>
Proxy c -> Entity -> m (Maybe c)
get :: forall c m w. (MonadSystem w m, QueryType c) => Proxy c -> Entity -> m (Maybe c),
SystemTools
-> forall c (m :: * -> *) w.
(Component c, MonadSystem w m, RelExclusivity c ~ 'Inclusive) =>
Proxy c -> Entity -> m (Maybe [Rel c])
getRAny :: forall c m w. (Component c, MonadSystem w m, RelExclusivity c ~ Inclusive) => Proxy c -> Entity -> m (Maybe [Rel c]),
SystemTools -> forall c. Bundle c => c -> Entity -> System ()
set :: forall c. (Bundle c) => c -> Entity -> System (),
SystemTools -> forall b. Bundle b => Entity -> b -> System ()
spawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()
}
worldGet :: forall c m w. (MonadSystem w m, QueryType c) => Proxy c -> Entity -> m (Maybe c)
worldGet :: forall c (m :: * -> *) w.
(MonadSystem w m, QueryType c) =>
Proxy c -> Entity -> m (Maybe c)
worldGet Proxy c
p Entity
e = do
World {tools = SystemTools {get}} <- m World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
get p e
worldSet :: forall c. (Bundle c) => c -> Entity -> System ()
worldSet :: forall c. Bundle c => c -> Entity -> System ()
worldSet c
c Entity
e = do
World {tools = SystemTools {set}} <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
set c e
worldGetRAny :: forall c m w. (Component c, MonadSystem w m, RelExclusivity c ~ Inclusive) => Proxy c -> Entity -> m (Maybe [Rel c])
worldGetRAny :: forall c (m :: * -> *) w.
(Component c, MonadSystem w m, RelExclusivity c ~ 'Inclusive) =>
Proxy c -> Entity -> m (Maybe [Rel c])
worldGetRAny Proxy c
p Entity
e = do
World {tools = SystemTools {getRAny}} <- m World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
getRAny p e
worldSpawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()
worldSpawnByInsert :: forall b. Bundle b => Entity -> b -> System ()
worldSpawnByInsert Entity
e b
b = do
World {tools = SystemTools {spawnByInsert}} <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
spawnByInsert e b