{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Trustworthy #-}
module Games.ECS.World
( Access (..),
Props (..),
World (..),
OpticsFor,
EntRefStoringType,
EntRefField,
AnAffineTraversal,
AnAffineTraversal',
AffineTraversal,
AffineTraversal',
affine,
affine',
newUniqueEntRef,
)
where
import Control.Lens
import Control.Monad.IO.Class
import Data.IORef
import Data.IntSet qualified as IS
import Data.Kind
import GHC.Base
import GHC.Num
import Games.ECS.Entity
import Games.ECS.Prototype.PrototypeID
import Games.ECS.Slot
import System.IO.Unsafe (unsafePerformIO)
data Access
=
Storing
|
Individual
data Props
=
Normal
|
Required
|
Unique
entUniqueSource :: IORef Integer
entUniqueSource :: IORef Integer
entUniqueSource = IO (IORef Integer) -> IORef Integer
forall a. IO a -> a
unsafePerformIO (Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0)
{-# NOINLINE entUniqueSource #-}
newUniqueEntRef :: IO Entity
newUniqueEntRef :: IO Entity
newUniqueEntRef = do
Integer
r <- IORef Integer -> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
entUniqueSource ((Integer -> (Integer, Integer)) -> IO Integer)
-> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Integer
x -> let z :: Integer
z = Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 in (Integer
z, Integer
z)
pure (Int -> Entity
EntRef (Integer -> Int
integerToInt Integer
r))
{-# NOINLINE newUniqueEntRef #-}
class World (w :: Access -> Type) where
newWorld :: w Storing
createNewEntity :: (MonadIO m) => m (w Individual)
{-# INLINE createNewEntity #-}
createNewEntity = do
Entity
seed <- IO Entity -> m Entity
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Entity
newUniqueEntRef
pure (Entity -> w 'Individual
forall (w :: Access -> *). World w => Entity -> w 'Individual
createNewEntityWithRef Entity
seed)
createNewEntityWithRef :: Entity -> w Individual
entities :: IndexedTraversal' Entity (w Storing) (w Individual)
{-# INLINE entities #-}
default entities :: (HasType (EntRefStoringType) (w Storing)) => IndexedTraversal' Entity (w Storing) (w Individual)
entities p (w 'Individual) (f (w 'Individual))
p w 'Storing
world = [Entity]
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (f :: * -> *) (p :: * -> * -> *) (fol :: * -> *).
(Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (w :: Access -> *) (f :: * -> *) (p :: * -> * -> *)
(fol :: * -> *).
(World w, Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
lookupEntities ((w 'Storing
world w 'Storing
-> Getting (Endo [Entity]) (w 'Storing) Entity -> [Entity]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a s. HasType a s => Lens' s a
typed @(EntRefField Storing) ((EntRefStoringType -> Const (Endo [Entity]) EntRefStoringType)
-> w 'Storing -> Const (Endo [Entity]) (w 'Storing))
-> ((Entity -> Const (Endo [Entity]) Entity)
-> EntRefStoringType -> Const (Endo [Entity]) EntRefStoringType)
-> Getting (Endo [Entity]) (w 'Storing) Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Const (Endo [Entity]) Entity)
-> EntRefStoringType -> Const (Endo [Entity]) EntRefStoringType
forall a. IsEntityStore a => Fold a Entity
Fold EntRefStoringType Entity
knownEntities)) p (w 'Individual) (f (w 'Individual))
p w 'Storing
world
entityReference :: IndexedGetter Entity (w Individual) Entity
unsafeEntityReference :: Lens' (w Individual) Entity
entityReferences :: IndexedFold Entity (w Storing) Entity
lookupEntity :: w Storing -> Entity -> Maybe (w Individual)
prototype :: HasPrototypeID p => p -> AffineTraversal' (w Storing) (w Individual)
{-# INLINE lookupEntities #-}
lookupEntities :: forall f p fol. (Indexable Entity p, Applicative f, Foldable fol) => fol Entity -> p (w Individual) (f (w Individual)) -> w Storing -> f (w Storing)
lookupEntities fol Entity
list = p (w 'Individual) (f (w 'Individual))
-> w 'Storing -> f (w 'Storing)
IndexedTraversal' Entity (w 'Storing) (w 'Individual)
forall (w :: Access -> *).
World w =>
IndexedTraversal' Entity (w 'Storing) (w 'Individual)
entities (p (w 'Individual) (f (w 'Individual))
-> w 'Storing -> f (w 'Storing))
-> (p (w 'Individual) (f (w 'Individual))
-> p (w 'Individual) (f (w 'Individual)))
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w 'Individual -> Bool)
-> p (w 'Individual) (f (w 'Individual))
-> p (w 'Individual) (f (w 'Individual))
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\w 'Individual
ent -> Getting Any (fol Entity) Entity -> Entity -> fol Entity -> Bool
forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf Getting Any (fol Entity) Entity
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (fol Entity) Entity
folded (w 'Individual
ent w 'Individual -> Getting Entity (w 'Individual) Entity -> Entity
forall s a. s -> Getting a s a -> a
^. Getting Entity (w 'Individual) Entity
IndexedGetter Entity (w 'Individual) Entity
forall (w :: Access -> *).
World w =>
IndexedGetter Entity (w 'Individual) Entity
entityReference) fol Entity
list)
entitiesWith :: forall f p. (Indexable Entity p, Applicative f) => (forall r. (Monoid r) => Getting r (w Storing) IntersectionOfEntities) -> p (w Individual) (f (w Individual)) -> w Storing -> f (w Storing)
{-# INLINE entitiesWith #-}
entitiesWith forall r. Monoid r => Getting r (w 'Storing) IntersectionOfEntities
withComponents p (w 'Individual) (f (w 'Individual))
p w 'Storing
world = [Entity]
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (f :: * -> *) (p :: * -> * -> *) (fol :: * -> *).
(Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (w :: Access -> *) (f :: * -> *) (p :: * -> * -> *)
(fol :: * -> *).
(World w, Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
lookupEntities ((w 'Storing
world w 'Storing
-> Getting
IntersectionOfEntities (w 'Storing) IntersectionOfEntities
-> IntersectionOfEntities
forall s a. s -> Getting a s a -> a
^. Getting IntersectionOfEntities (w 'Storing) IntersectionOfEntities
forall r. Monoid r => Getting r (w 'Storing) IntersectionOfEntities
withComponents) IntersectionOfEntities
-> Getting (Endo [Entity]) IntersectionOfEntities Entity
-> [Entity]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Entity]) IntersectionOfEntities Entity
forall a. IsEntityStore a => Fold a Entity
Fold IntersectionOfEntities Entity
knownEntities) p (w 'Individual) (f (w 'Individual))
p w 'Storing
world
storeEntity :: w Individual -> w Storing -> w Storing
entity :: Entity -> AffineTraversal' (w Storing) (w Individual)
entity Entity
ent = (w 'Storing -> Maybe (w 'Individual))
-> (w 'Storing -> w 'Individual -> w 'Storing)
-> AffineTraversal' (w 'Storing) (w 'Individual)
forall s a. (s -> Maybe a) -> (s -> a -> s) -> Traversal' s a
affine' (w 'Storing -> Entity -> Maybe (w 'Individual)
forall (w :: Access -> *).
World w =>
w 'Storing -> Entity -> Maybe (w 'Individual)
`lookupEntity` Entity
ent) ((w 'Individual -> w 'Storing -> w 'Storing)
-> w 'Storing -> w 'Individual -> w 'Storing
forall a b c. (a -> b -> c) -> b -> a -> c
flip w 'Individual -> w 'Storing -> w 'Storing
forall (w :: Access -> *).
World w =>
w 'Individual -> w 'Storing -> w 'Storing
storeEntity)
{-# INLINE entity #-}
type EntRefStoringType = IS.IntSet
type family EntRefField (acc :: Access) :: Type where
EntRefField Individual = Entity
EntRefField Storing = EntRefStoringType
type family OpticsFor (name :: Symbol) (hkd :: Access -> Type) (acc :: Access) (p :: Props) (a :: Type) :: Type where
OpticsFor name hkd Individual Required a =
ReifiedIndexedLens' Entity (hkd Individual) a
OpticsFor name hkd Individual Normal a =
AnAffineTraversal' (hkd Individual) a
OpticsFor name hkd Individual Unique a = AnAffineTraversal' (hkd Individual) a
OpticsFor name hkd Storing Unique a = ReifiedIndexedTraversal' Entity (hkd Storing) a
OpticsFor name hkd Storing Normal a = ReifiedIndexedTraversal' Entity (hkd Storing) a
OpticsFor name hkd Storing Required a = ReifiedIndexedTraversal' Entity (hkd Storing) a
type AnAffineTraversal s t a b = ReifiedIndexedTraversal Entity s t a b
type AnAffineTraversal' s a = AnAffineTraversal s s a a
type AffineTraversal s t a b = Traversal s t a b
type AffineTraversal' s a = AffineTraversal s s a a
{-# INLINE affine #-}
affine :: (s -> Either t a) -> (s -> b -> t) -> Traversal s t a b
affine :: forall s t a b.
(s -> Either t a) -> (s -> b -> t) -> Traversal s t a b
affine s -> Either t a
getter s -> b -> t
setter a -> f b
f s
s = case s -> Either t a
getter s
s of
Left t
t -> t -> f t
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t
Right a
a -> (\b
b -> s -> b -> t
setter s
s b
b) (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
{-# INLINE affine' #-}
affine' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal' s a
affine' :: forall s a. (s -> Maybe a) -> (s -> a -> s) -> Traversal' s a
affine' s -> Maybe a
getter s -> a -> s
setter a -> f a
f s
s = case s -> Maybe a
getter s
s of
Maybe a
Nothing -> s -> f s
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
Just a
a -> (\a
b -> s -> a -> s
setter s
s a
b) (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
a