{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Mischief.ECS.World.Insert where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader (..))
import Data.Data
import Data.Foldable (for_)
import Data.IORef
import Data.List hiding (insert)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Set qualified as Set
import Data.Text qualified as Text
import GHC.Base (Int (..))
import GHC.Stack
import Mischief.ECS.Archetypes
import Mischief.ECS.Archetypes.Graph
( getArchetypeOnInsert,
)
import Mischief.ECS.Components
import Mischief.ECS.Components.Bundle
import Mischief.ECS.Entities
import Mischief.ECS.EntityDef
import Mischief.ECS.EventDef
import Mischief.ECS.Events
import Mischief.ECS.Log
import Mischief.ECS.Tables
import Mischief.ECS.Vec qualified as Vec
import Mischief.ECS.World
import Mischief.ECS.World.Change
import Mischief.ECS.World.Prefs
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.Queryable
import Mischief.ECS.World.Utils
data Exception' = Exception' deriving (Int -> Exception' -> ShowS
[Exception'] -> ShowS
Exception' -> String
(Int -> Exception' -> ShowS)
-> (Exception' -> String)
-> ([Exception'] -> ShowS)
-> Show Exception'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Exception' -> ShowS
showsPrec :: Int -> Exception' -> ShowS
$cshow :: Exception' -> String
show :: Exception' -> String
$cshowList :: [Exception'] -> ShowS
showList :: [Exception'] -> ShowS
Show)
instance Exception Exception'
insert :: (HasCallStack) => forall b. (Bundle b) => b -> Entity -> System ()
insert :: forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
insert b
bundle Entity
entity =
do
world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
pointer <- liftIO $ getPointer entity world.entities
case pointer of
Maybe (IORef EntityPointer)
Nothing -> Text -> System ()
forall w (m :: * -> *).
(HasCallStack, MonadSystem w m) =>
Text -> m ()
warn (Text -> System ()) -> Text -> System ()
forall a b. (a -> b) -> a -> b
$ Text
"Insertion failed: Entity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Entity -> Text
forall a. Show a => a -> Text
text Entity
entity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not alive."
Just IORef EntityPointer
currentPointer -> do
let BundleData {Set (BundleElement ErasedComponent)
elements :: Set (BundleElement ErasedComponent)
elements :: forall e. BundleData e -> Set (BundleElement e)
elements} = b -> BundleData ErasedComponent
forall b. Bundle b => b -> BundleData ErasedComponent
bundleData b
bundle
currentTick <- IO Tick -> System Tick
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Tick -> System Tick) -> IO Tick -> System Tick
forall a b. (a -> b) -> a -> b
$ IORef Tick -> IO Tick
forall a. IORef a -> IO a
readIORef World
world.tick
bundleData <- liftIO $ processBundleElements world ComponentTicks {changed = currentTick, added = currentTick} elements
let newComponents = [ComponentId] -> [ComponentId]
forall a. Ord a => [a] -> [a]
sort ([ComponentId] -> [ComponentId]) -> [ComponentId] -> [ComponentId]
forall a b. (a -> b) -> a -> b
$ (ProcessedBundleElement -> ComponentId)
-> [ProcessedBundleElement] -> [ComponentId]
forall a b. (a -> b) -> [a] -> [b]
map (\ProcessedBundleElement
x -> ProcessedBundleElement
x.id) ProcessedBundleData
bundleData.elements
(EntityPointer (# archetypeId, rowIndex #)) <- liftIO $ readIORef currentPointer
currentTable <- Vec.read world.tables.inner (I# archetypeId)
if newComponents `isSubsequenceOf` currentTable.components
then
liftIO $ replaceComponentsIntoTable bundleData (Just currentTick) (EntityPointer (# archetypeId, rowIndex #)) currentTable
else do
newArchetype <- getArchetypeOnInsert (ArchetypeId $ I# archetypeId) newComponents
ChangeResult {requiredComponentsAdded} <- changeArchetype entity newArchetype (Just bundleData)
unless world.prefs.supressEvents $
triggerInsertEvent (ProcessedBundleData requiredComponentsAdded) entity
unless world.prefs.supressEvents $
triggerInsertEvent bundleData entity
getOrInsert :: forall qd. (Updateable (Result qd), Bundle qd) => qd -> Entity -> System (Result qd)
getOrInsert :: forall qd.
(Updateable (Result qd), Bundle qd) =>
qd -> Entity -> System (Result qd)
getOrInsert qd
val Entity
entity = do
g <- Result qd -> System (Maybe (Result qd))
forall c.
Updateable (Result c) =>
Result c -> System (Maybe (Result c))
update ((qd, Entity) -> Result qd
forall c. (c, Entity) -> Result c
Result (qd
val, Entity
entity))
case g of
Just Result qd
g -> Result qd -> System (Result qd)
forall a. a -> System a
forall (m :: * -> *) a. Monad m => a -> m a
return Result qd
g
Maybe (Result qd)
Nothing -> do
qd -> Entity -> System ()
forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
forall b. Bundle b => b -> Entity -> System ()
insert qd
val Entity
entity
Result qd -> System (Result qd)
forall a. a -> System a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result qd -> System (Result qd))
-> Result qd -> System (Result qd)
forall a b. (a -> b) -> a -> b
$ (qd, Entity) -> Result qd
forall c. (c, Entity) -> Result c
Result (qd
val, Entity
entity)
insertNew :: forall b. (Bundle b) => b -> Entity -> System ()
insertNew :: forall b. Bundle b => b -> Entity -> System ()
insertNew b
bundle Entity
entity =
do
world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
pointer <- liftIO $ getPointer entity world.entities
case pointer of
Maybe (IORef EntityPointer)
Nothing -> Text -> System ()
forall w (m :: * -> *).
(HasCallStack, MonadSystem w m) =>
Text -> m ()
warn (Text -> System ()) -> Text -> System ()
forall a b. (a -> b) -> a -> b
$ Text
"Insertion failed: Entity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Entity -> Text
forall a. Show a => a -> Text
text Entity
entity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not alive."
Just IORef EntityPointer
currentPointer -> do
let BundleData {Set (BundleElement ErasedComponent)
elements :: forall e. BundleData e -> Set (BundleElement e)
elements :: Set (BundleElement ErasedComponent)
elements} = b -> BundleData ErasedComponent
forall b. Bundle b => b -> BundleData ErasedComponent
bundleData b
bundle
currentTick <- IO Tick -> System Tick
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Tick -> System Tick) -> IO Tick -> System Tick
forall a b. (a -> b) -> a -> b
$ IORef Tick -> IO Tick
forall a. IORef a -> IO a
readIORef World
world.tick
bundleData <- liftIO $ processBundleElements world ComponentTicks {changed = currentTick, added = currentTick} elements
(EntityPointer (# archetypeId, _ #)) <- liftIO $ readIORef currentPointer
currentTable <- Vec.read world.tables.inner (I# archetypeId)
let newComponents = [ProcessedBundleElement] -> ProcessedBundleData
ProcessedBundleData ([ProcessedBundleElement] -> ProcessedBundleData)
-> [ProcessedBundleElement] -> ProcessedBundleData
forall a b. (a -> b) -> a -> b
$ (ProcessedBundleElement -> Bool)
-> [ProcessedBundleElement] -> [ProcessedBundleElement]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ProcessedBundleElement
c -> ProcessedBundleElement
c.id ComponentId -> [ComponentId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Table
currentTable.components) ProcessedBundleData
bundleData.elements
unless (null newComponents.elements) $ do
newArchetype <- getArchetypeOnInsert (ArchetypeId $ I# archetypeId) $ map (\ProcessedBundleElement
x -> ProcessedBundleElement
x.id) newComponents.elements
ChangeResult {requiredComponentsAdded} <- changeArchetype entity newArchetype (Just bundleData)
unless world.prefs.supressEvents $
triggerInsertEvent (ProcessedBundleData requiredComponentsAdded) entity
unless world.prefs.supressEvents $
triggerInsertEvent newComponents entity
insertIfNeq :: (BundleEq b) => b -> Entity -> System ()
insertIfNeq :: forall b. BundleEq b => b -> Entity -> System ()
insertIfNeq b
b Entity
entity = do
let BundleData {Set (BundleElement ErasedComponentEq)
elements :: forall e. BundleData e -> Set (BundleElement e)
elements :: Set (BundleElement ErasedComponentEq)
elements} = b -> BundleData ErasedComponentEq
forall b. BundleEq b => b -> BundleData ErasedComponentEq
bundleDataEq b
b
comps <- ((BundleElement ErasedComponentEq -> System Bool)
-> [BundleElement ErasedComponentEq]
-> System [BundleElement ErasedComponentEq])
-> [BundleElement ErasedComponentEq]
-> (BundleElement ErasedComponentEq -> System Bool)
-> System [BundleElement ErasedComponentEq]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (BundleElement ErasedComponentEq -> System Bool)
-> [BundleElement ErasedComponentEq]
-> System [BundleElement ErasedComponentEq]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Set (BundleElement ErasedComponentEq)
-> [BundleElement ErasedComponentEq]
forall a. Set a -> [a]
Set.toList Set (BundleElement ErasedComponentEq)
elements) ((BundleElement ErasedComponentEq -> System Bool)
-> System [BundleElement ErasedComponentEq])
-> (BundleElement ErasedComponentEq -> System Bool)
-> System [BundleElement ErasedComponentEq]
forall a b. (a -> b) -> a -> b
$ \BundleElement {ComponentRep
rep :: ComponentRep
rep :: forall e. BundleElement e -> ComponentRep
rep, component :: forall e. BundleElement e -> e
component = ErasedComponentEq (c
val :: c)} -> do
val' <- case ComponentRep
rep of
PairRep (ComponentType
_, Entity
target) -> (Result (Rel c) -> c) -> Maybe (Result (Rel c)) -> Maybe c
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Result (Rel c)
x -> Result (Rel c)
x.comp) (Maybe (Result (Rel c)) -> Maybe c)
-> System (Maybe (Result (Rel c))) -> System (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R c Entity -> Entity -> System (Maybe (Result (Rel c)))
forall qd (m :: * -> *) w out.
(Queryable qd out, MonadSystem w m) =>
qd -> Entity -> m (Maybe out)
get (forall {k} (a :: k) b. b -> R a b
forall a b. b -> R a b
R @c Entity
target) Entity
entity
ComponentRep
_ -> (Result c -> c) -> Maybe (Result c) -> Maybe c
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result c -> c
forall c. Result c -> c
value (Maybe (Result c) -> Maybe c)
-> System (Maybe (Result c)) -> System (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> C c -> Entity -> System (Maybe (Result c))
forall qd (m :: * -> *) w out.
(Queryable qd out, MonadSystem w m) =>
qd -> Entity -> m (Maybe out)
get (forall a. C a
forall {k} (a :: k). C a
C @c) Entity
entity
case val' of
Maybe c
Nothing -> Bool -> System Bool
forall a. a -> System a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just c
val' -> Bool -> System Bool
forall a. a -> System a
forall (m :: * -> *) a. Monad m => a -> m a
return (c
val c -> c -> Bool
forall a. Eq a => a -> a -> Bool
/= c
val')
insert (bundleEqToSimple $ BundleData (Set.fromList comps)) entity
class Settable c i | c -> i where
setInner :: c -> i -> System ()
setIfNeqInner :: (Eq i) => c -> i -> System ()
class Settable' isRel c i | isRel c -> i where
setInner' :: c -> i -> System ()
setIfNeqInner' :: (Eq i) => c -> i -> System ()
instance (Component c) => Settable' False (Result (Rel c)) c where
setInner' :: Result (Rel c) -> c -> System ()
setInner' :: Result (Rel c) -> c -> System ()
setInner' !Result (Rel c)
result !c
newValue = forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
Rel c -> Entity -> System ()
forall b. Bundle b => b -> Entity -> System ()
Mischief.ECS.World.Insert.insert (c -> Entity -> Rel c
forall c. c -> Entity -> Rel c
Rel c
newValue Result (Rel c)
result.target) (Result (Rel c) -> Entity
forall c. Result c -> Entity
entityOf Result (Rel c)
result)
setIfNeqInner' :: (Component c, Eq c) => Result (Rel c) -> c -> System ()
setIfNeqInner' :: (Component c, Eq c) => Result (Rel c) -> c -> System ()
setIfNeqInner' !Result (Rel c)
result !c
newValue = do
curr <- R c Entity -> Entity -> System (Maybe (Result (Rel c)))
forall qd (m :: * -> *) w out.
(Queryable qd out, MonadSystem w m) =>
qd -> Entity -> m (Maybe out)
get (forall {k} (a :: k) b. b -> R a b
forall a b. b -> R a b
R @c Result (Rel c)
result.target) (Result (Rel c) -> Entity
forall c. Result c -> Entity
entityOf Result (Rel c)
result)
case curr of
Maybe (Result (Rel c))
Nothing -> Text -> System ()
forall w (m :: * -> *).
(HasCallStack, MonadSystem w m) =>
Text -> m ()
warn (Text -> System ()) -> Text -> System ()
forall a b. (a -> b) -> a -> b
$ Text
"SetIfNeq failed: Entity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Entity -> Text
forall a. Show a => a -> Text
text (Result (Rel c) -> Entity
forall c. Result c -> Entity
entityOf Result (Rel c)
result) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not alive."
Just Result (Rel c)
curr ->
Bool -> System () -> System ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result (Rel c)
curr.comp c -> c -> Bool
forall a. Eq a => a -> a -> Bool
/= c
newValue) (System () -> System ()) -> System () -> System ()
forall a b. (a -> b) -> a -> b
$
forall (isRel :: Bool) c i.
Settable' isRel c i =>
c -> i -> System ()
forall {k} (isRel :: k) c i.
Settable' isRel c i =>
c -> i -> System ()
setInner' @False Result (Rel c)
result c
newValue
instance (Component c, IsComponentC c ~ HTrue) => Settable' True (Result c) c where
setInner' :: Result c -> c -> System ()
setInner' :: Result c -> c -> System ()
setInner' !Result c
result !c
newValue = c -> Entity -> System ()
forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
forall b. Bundle b => b -> Entity -> System ()
Mischief.ECS.World.Insert.insert c
newValue (Result c -> Entity
forall c. Result c -> Entity
entityOf Result c
result)
setIfNeqInner' :: (Component c, Eq c) => Result c -> c -> System ()
setIfNeqInner' :: (Component c, Eq c) => Result c -> c -> System ()
setIfNeqInner' !Result c
result !c
newValue = do
curr <- C c -> Entity -> System (Maybe (Result c))
forall qd (m :: * -> *) w out.
(Queryable qd out, MonadSystem w m) =>
qd -> Entity -> m (Maybe out)
get (forall a. C a
forall {k} (a :: k). C a
C @c) (Result c -> Entity
forall c. Result c -> Entity
entityOf Result c
result)
case curr of
Maybe (Result c)
Nothing -> Text -> System ()
forall w (m :: * -> *).
(HasCallStack, MonadSystem w m) =>
Text -> m ()
warn (Text -> System ()) -> Text -> System ()
forall a b. (a -> b) -> a -> b
$ Text
"SetIfNeq failed: Entity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Entity -> Text
forall a. Show a => a -> Text
text (Result c -> Entity
forall c. Result c -> Entity
entityOf Result c
result) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not alive."
Just Result c
curr ->
Bool -> System () -> System ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result c -> c
forall c. Result c -> c
value Result c
curr c -> c -> Bool
forall a. Eq a => a -> a -> Bool
/= c
newValue) (System () -> System ()) -> System () -> System ()
forall a b. (a -> b) -> a -> b
$
forall (isRel :: Bool) c i.
Settable' isRel c i =>
c -> i -> System ()
forall {k} (isRel :: k) c i.
Settable' isRel c i =>
c -> i -> System ()
setInner' @True Result c
result c
newValue
instance (Settable' (IsComp c) (Result c) i) => Settable (Result c) i where
setInner :: Result c -> i -> System ()
setInner = forall (isRel :: Bool) c i.
Settable' isRel c i =>
c -> i -> System ()
forall {k} (isRel :: k) c i.
Settable' isRel c i =>
c -> i -> System ()
setInner' @(IsComp c)
setIfNeqInner :: Eq i => Result c -> i -> System ()
setIfNeqInner = forall (isRel :: Bool) c i.
(Settable' isRel c i, Eq i) =>
c -> i -> System ()
forall {k} (isRel :: k) c i.
(Settable' isRel c i, Eq i) =>
c -> i -> System ()
setIfNeqInner' @(IsComp c)
set :: (Settable c i) => c -> i -> System ()
set :: forall c i. Settable c i => c -> i -> System ()
set = c -> i -> System ()
forall c i. Settable c i => c -> i -> System ()
setInner
setIfNeq :: (Eq i, Settable c i) => c -> i -> System ()
setIfNeq :: forall i c. (Eq i, Settable c i) => c -> i -> System ()
setIfNeq = c -> i -> System ()
forall c i. (Settable c i, Eq i) => c -> i -> System ()
setIfNeqInner
class Updateable' flag r where
updateInner' :: r -> System (Maybe r)
instance (Component c, IsComponentC c ~ HTrue) => Updateable' True (Result c) where
updateInner' :: Result c -> System (Maybe (Result c))
updateInner' Result c
r = C c -> Entity -> System (Maybe (Result c))
forall qd (m :: * -> *) w out.
(Queryable qd out, MonadSystem w m) =>
qd -> Entity -> m (Maybe out)
get (forall a. C a
forall {k} (a :: k). C a
C @c) (Result c -> Entity
forall c. Result c -> Entity
entityOf Result c
r)
instance (Component c) => Updateable' False (Result (Rel c)) where
updateInner' :: Result (Rel c) -> System (Maybe (Result (Rel c)))
updateInner' Result (Rel c)
r = R c Entity -> Entity -> System (Maybe (Result (Rel c)))
forall qd (m :: * -> *) w out.
(Queryable qd out, MonadSystem w m) =>
qd -> Entity -> m (Maybe out)
get (forall {k} (a :: k) b. b -> R a b
forall a b. b -> R a b
R @c Result (Rel c)
r.target) (Result (Rel c) -> Entity
forall c. Result c -> Entity
entityOf Result (Rel c)
r)
class Updateable r where
updateInner :: r -> System (Maybe r)
instance (Updateable' (IsComp c) (Result c)) => Updateable (Result c) where
updateInner :: Result c -> System (Maybe (Result c))
updateInner = forall (flag :: Bool) r.
Updateable' flag r =>
r -> System (Maybe r)
forall {k} (flag :: k) r.
Updateable' flag r =>
r -> System (Maybe r)
updateInner' @(IsComp c)
update :: forall c. (Updateable (Result c)) => Result c -> System (Maybe (Result c))
update :: forall c.
Updateable (Result c) =>
Result c -> System (Maybe (Result c))
update = Result c -> System (Maybe (Result c))
forall r. Updateable r => r -> System (Maybe r)
updateInner
triggerInsertEvent :: ProcessedBundleData -> Entity -> System ()
triggerInsertEvent :: ProcessedBundleData -> Entity -> System ()
triggerInsertEvent ProcessedBundleData
bundle Entity
entity =
[ProcessedBundleElement]
-> (ProcessedBundleElement -> System ()) -> System ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ProcessedBundleData
bundle.elements ((ProcessedBundleElement -> System ()) -> System ())
-> (ProcessedBundleElement -> System ()) -> System ()
forall a b. (a -> b) -> a -> b
$ \ProcessedBundleElement
x -> do
let !(ComponentId (# Word#
id, Maybe Entity
target #)) = ProcessedBundleElement
x.id
case Maybe Entity
target of
Maybe Entity
Nothing ->
ErasedComponent -> Entity -> System ()
triggerInsertEventC ProcessedBundleElement
x.component.value Entity
entity
Just Entity
target ->
ErasedComponent -> Entity -> Entity -> System ()
triggerInsertEventR ProcessedBundleElement
x.component.value Entity
target Entity
entity
triggerInsertEventC :: ErasedComponent -> Entity -> System ()
triggerInsertEventC :: ErasedComponent -> Entity -> System ()
triggerInsertEventC (ErasedComponent (c
_ :: c)) Entity
entity =
ErasedEvent -> System ()
runEvent (ErasedEvent -> System ()) -> ErasedEvent -> System ()
forall a b. (a -> b) -> a -> b
$ OnInsert c -> ErasedEvent
forall e. Event e => e -> ErasedEvent
eraseEvent (OnInsert c -> ErasedEvent) -> OnInsert c -> ErasedEvent
forall a b. (a -> b) -> a -> b
$ forall c. Entity -> OnInsert c
forall {k} (c :: k). Entity -> OnInsert c
OnInsert @c Entity
entity
triggerInsertEventR :: ErasedComponent -> Entity -> Entity -> System ()
triggerInsertEventR :: ErasedComponent -> Entity -> Entity -> System ()
triggerInsertEventR (ErasedComponent (c
_ :: c)) Entity
target Entity
entity = do
ErasedEvent -> System ()
runEvent (ErasedEvent -> System ()) -> ErasedEvent -> System ()
forall a b. (a -> b) -> a -> b
$ OnInsertRel c -> ErasedEvent
forall e. Event e => e -> ErasedEvent
eraseEvent (OnInsertRel c -> ErasedEvent) -> OnInsertRel c -> ErasedEvent
forall a b. (a -> b) -> a -> b
$ forall c. Entity -> Entity -> OnInsertRel c
forall {k} (c :: k). Entity -> Entity -> OnInsertRel c
OnInsertRel @c Entity
entity Entity
target