diff --git a/aztecs.cabal b/aztecs.cabal --- a/aztecs.cabal +++ b/aztecs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs -version: 0.16.1 +version: 0.17.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me diff --git a/src/Aztecs.hs b/src/Aztecs.hs --- a/src/Aztecs.hs +++ b/src/Aztecs.hs @@ -1,7 +1,8 @@ --- | Aztecs is a type-safe and friendly ECS for games and more. --- --- An ECS is a modern approach to organizing your application state as a database, --- providing patterns for data-oriented design and parallel processing. -module Aztecs (module Aztecs.ECS) where - -import Aztecs.ECS +-- | Aztecs is a type-safe and friendly ECS for games and more. +-- +-- An ECS is a modern approach to organizing your application state as a database, +-- providing patterns for data-oriented design and parallel processing. +module Aztecs (module Aztecs.ECS, module Aztecs.Hierarchy) where + +import Aztecs.ECS +import Aztecs.Hierarchy diff --git a/src/Aztecs/ECS/Access.hs b/src/Aztecs/ECS/Access.hs --- a/src/Aztecs/ECS/Access.hs +++ b/src/Aztecs/ECS/Access.hs @@ -1,110 +1,110 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | --- Module : Aztecs.ECS.Access --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.Access - ( Access (..), - runAccess, - runAccess_, - spawn, - spawn_, - insert, - insertUntracked, - lookup, - remove, - despawn, - system, - triggerEvent, - triggerEntityEvent, - ) -where - -import Aztecs.ECS.Access.Internal -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.System (System (..)) -import qualified Aztecs.ECS.System as S -import Aztecs.ECS.World (World) -import qualified Aztecs.ECS.World as W -import Aztecs.ECS.World.Bundle -import qualified Aztecs.ECS.World.Entities as E -import Control.Monad -import Control.Monad.State -import Prelude hiding (all, filter, lookup, map, mapM) - --- | Run an `Access` on a `World`, returning the output and updated `World`. -runAccess :: (Functor m) => Access m a -> World m -> m (a, World m) -runAccess a = runStateT $ unAccess a - --- | Run an `Access` on an empty `World`. -runAccess_ :: (Monad m) => Access m a -> m a -runAccess_ a = fmap fst . runAccess a $ W.empty - -spawn :: (Monad m) => BundleT m -> Access m EntityID -spawn b = Access $ do - !w <- get - let (e, w', hook) = W.spawn b w - put w' - unAccess hook - return e - -spawn_ :: (Monad m) => BundleT m -> Access m () -spawn_ = void . spawn - -insert :: (Monad m) => EntityID -> BundleT m -> Access m () -insert e c = Access $ do - !w <- get - let (w', hook) = W.insert e c w - put w' - unAccess hook - --- | Insert a component into an entity without running lifecycle hooks. -insertUntracked :: (Monad m) => EntityID -> BundleT m -> Access m () -insertUntracked e c = Access $ do - !w <- get - let w' = W.insertUntracked e c w - put w' - -lookup :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a) -lookup e = Access $ do - !w <- get - return $ W.lookup @m e w - -remove :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a) -remove e = Access $ do - !w <- get - let (a, w', hook) = W.remove @m e w - put w' - unAccess hook - return a - -despawn :: (Monad m) => EntityID -> Access m () -despawn e = Access $ do - !w <- get - let !(_, w') = W.despawn e w - put w' - --- | Run a `System` on the `World`. -system :: (Monad m) => System m a -> Access m a -system sys = Access $ do - !w <- get - let !es = W.entities w - !(cs', dynSys) = S.runSystem sys $ E.components es - (a, es', hook) <- lift $ S.runDynamicSystem dynSys es - put w {W.entities = es' {E.components = cs'}} - unAccess hook - return a -{-# INLINE system #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module : Aztecs.ECS.Access +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Access + ( Access (..), + runAccess, + runAccess_, + spawn, + spawn_, + insert, + insertUntracked, + lookup, + remove, + despawn, + system, + triggerEvent, + triggerEntityEvent, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.System (System (..)) +import qualified Aztecs.ECS.System as S +import Aztecs.ECS.World (World) +import qualified Aztecs.ECS.World as W +import Aztecs.ECS.World.Bundle +import qualified Aztecs.ECS.World.Entities as E +import Control.Monad +import Control.Monad.State +import Prelude hiding (all, filter, lookup, map, mapM) + +-- | Run an `Access` on a `World`, returning the output and updated `World`. +runAccess :: (Functor m) => Access m a -> World m -> m (a, World m) +runAccess a = runStateT $ unAccess a + +-- | Run an `Access` on an empty `World`. +runAccess_ :: (Monad m) => Access m a -> m a +runAccess_ a = fmap fst . runAccess a $ W.empty + +spawn :: (Monad m) => BundleT m -> Access m EntityID +spawn b = Access $ do + !w <- get + let (e, w', hook) = W.spawn b w + put w' + unAccess hook + return e + +spawn_ :: (Monad m) => BundleT m -> Access m () +spawn_ = void . spawn + +insert :: (Monad m) => EntityID -> BundleT m -> Access m () +insert e c = Access $ do + !w <- get + let (w', hook) = W.insert e c w + put w' + unAccess hook + +-- | Insert a component into an entity without running lifecycle hooks. +insertUntracked :: (Monad m) => EntityID -> BundleT m -> Access m () +insertUntracked e c = Access $ do + !w <- get + let w' = W.insertUntracked e c w + put w' + +lookup :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a) +lookup e = Access $ do + !w <- get + return $ W.lookup @m e w + +remove :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a) +remove e = Access $ do + !w <- get + let (a, w', hook) = W.remove @m e w + put w' + unAccess hook + return a + +despawn :: (Monad m) => EntityID -> Access m () +despawn e = Access $ do + !w <- get + let !(_, w') = W.despawn e w + put w' + +-- | Run a `System` on the `World`. +system :: (Monad m) => System m a -> Access m a +system sys = Access $ do + !w <- get + let !es = W.entities w + !(cs', dynSys) = S.runSystem sys $ E.components es + (a, es', hook) <- lift $ S.runDynamicSystem dynSys es + put w {W.entities = es' {E.components = cs'}} + unAccess hook + return a +{-# INLINE system #-} diff --git a/src/Aztecs/ECS/Access/Internal.hs b/src/Aztecs/ECS/Access/Internal.hs --- a/src/Aztecs/ECS/Access/Internal.hs +++ b/src/Aztecs/ECS/Access/Internal.hs @@ -1,76 +1,76 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Aztecs.ECS.Access.Internal --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.Access.Internal - ( Access (..), - runAccessWith, - evalAccess, - triggerEvent, - triggerEntityEvent, - ) -where - -import Aztecs.ECS.Entity -import Aztecs.ECS.Event -import Aztecs.ECS.World.Internal -import qualified Aztecs.ECS.World.Observers as O -import Aztecs.ECS.World.Observers.Internal -import Control.Monad -import Control.Monad.Fix -import Control.Monad.State -import Data.Dynamic -import Data.Maybe -import qualified Data.Set as Set -import Data.Typeable - --- | Access into a `World`. -newtype Access m a = Access {unAccess :: StateT (World m) m a} - deriving (Functor, Applicative, Monad, MonadFix, MonadIO) - --- | Run an `Access` with a given `World`, returning the result and updated world. -runAccessWith :: Access m a -> World m -> m (a, World m) -runAccessWith a = runStateT (unAccess a) - --- | Run an `Access` with a given `World`, returning only the result. -evalAccess :: (Monad m) => Access m a -> World m -> m a -evalAccess a = evalStateT (unAccess a) - --- | Trigger an event. -triggerEvent :: forall m e. (Monad m, Event e) => e -> Access m () -triggerEvent evt = Access $ do - !w <- get - let eventTypeRep = typeOf (Proxy @e) - globalOs = O.lookupGlobalObservers eventTypeRep $ observers w - callbacks = mapMaybe (\oId -> O.lookupCallback oId (observers w)) $ Set.toList globalOs - dynEvt = toDyn evt - forM_ callbacks $ \cb -> case cb of - DynEventObserver f -> f dynEvt - DynEntityObserver _ -> pure () - --- | Trigger an event for a specific entity. -triggerEntityEvent :: - forall m e. - (Monad m, Event e) => - EntityID -> - e -> - Access m () -triggerEntityEvent targetEntity evt = Access $ do - !w <- get - let eventTypeRep = typeOf $ Proxy @e - entityOs = O.lookupEntityObservers eventTypeRep targetEntity $ observers w - callbacks = mapMaybe (\oId -> O.lookupCallback oId (observers w)) $ Set.toList entityOs - dynEvt = toDyn evt - forM_ callbacks $ \cb -> case cb of - DynEntityObserver f -> f targetEntity dynEvt - DynEventObserver _ -> pure () +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Aztecs.ECS.Access.Internal +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Access.Internal + ( Access (..), + runAccessWith, + evalAccess, + triggerEvent, + triggerEntityEvent, + ) +where + +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import Aztecs.ECS.World.Internal +import qualified Aztecs.ECS.World.Observers as O +import Aztecs.ECS.World.Observers.Internal +import Control.Monad +import Control.Monad.Fix +import Control.Monad.State +import Data.Dynamic +import Data.Maybe +import qualified Data.Set as Set +import Data.Typeable + +-- | Access into a `World`. +newtype Access m a = Access {unAccess :: StateT (World m) m a} + deriving (Functor, Applicative, Monad, MonadFix, MonadIO) + +-- | Run an `Access` with a given `World`, returning the result and updated world. +runAccessWith :: Access m a -> World m -> m (a, World m) +runAccessWith a = runStateT (unAccess a) + +-- | Run an `Access` with a given `World`, returning only the result. +evalAccess :: (Monad m) => Access m a -> World m -> m a +evalAccess a = evalStateT (unAccess a) + +-- | Trigger an event. +triggerEvent :: forall m e. (Monad m, Event e) => e -> Access m () +triggerEvent evt = Access $ do + !w <- get + let eventTypeRep = typeOf (Proxy @e) + globalOs = O.lookupGlobalObservers eventTypeRep $ observers w + callbacks = mapMaybe (\oId -> O.lookupCallback oId (observers w)) $ Set.toList globalOs + dynEvt = toDyn evt + forM_ callbacks $ \cb -> case cb of + DynEventObserver f -> f dynEvt + DynEntityObserver _ -> pure () + +-- | Trigger an event for a specific entity. +triggerEntityEvent :: + forall m e. + (Monad m, Event e) => + EntityID -> + e -> + Access m () +triggerEntityEvent targetEntity evt = Access $ do + !w <- get + let eventTypeRep = typeOf $ Proxy @e + entityOs = O.lookupEntityObservers eventTypeRep targetEntity $ observers w + callbacks = mapMaybe (\oId -> O.lookupCallback oId (observers w)) $ Set.toList entityOs + dynEvt = toDyn evt + forM_ callbacks $ \cb -> case cb of + DynEntityObserver f -> f targetEntity dynEvt + DynEventObserver _ -> pure () diff --git a/src/Aztecs/ECS/Observer.hs b/src/Aztecs/ECS/Observer.hs --- a/src/Aztecs/ECS/Observer.hs +++ b/src/Aztecs/ECS/Observer.hs @@ -1,102 +1,102 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.Observer --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.Observer - ( Observer (..), - ObserverID (..), - ObserverKind (..), - observer, - observerFor, - observerGlobal, - ) -where - -import Aztecs.ECS.Access.Internal -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.Event -import qualified Aztecs.ECS.World as W -import Aztecs.ECS.World.Bundle -import Aztecs.ECS.World.Internal (World (..)) -import qualified Aztecs.ECS.World.Observers as O -import Aztecs.ECS.World.Observers.Internal -import Control.Monad.State -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Typeable -import Data.Vector (Vector) - --- | The kind of observer - either entity-specific or global. -data ObserverKind m e - = -- | Observe events on specific entities (callback receives EntityID and event). - EntityObserver !(Set EntityID) !(EntityID -> e -> Access m ()) - | -- | Observe all events of this type globally (callback receives just the event). - EventObserver !(e -> Access m ()) - --- | Observer component -data Observer m e = Observer - { -- | The kind and callback for this observer. - observerKind :: !(ObserverKind m e), - -- | The ObserverID assigned after registration (Nothing before registration). - observerId :: !(Maybe ObserverID) - } - -instance Show (ObserverKind m e) where - show (EntityObserver targets _) = "EntityObserver " ++ show targets - show (EventObserver _) = "EventObserver" - -instance Show (Observer m e) where - show o = "Observer { kind = " ++ show (observerKind o) ++ ", id = " ++ show (observerId o) ++ " }" - -instance (Monad m, Typeable m, Event e) => Component m (Observer m e) where - type StorageT (Observer m e) = Vector (Observer m e) - - componentOnInsert ownerEntity o = Access $ do - !w <- get - (oId, observers') <- case observerKind o of - EntityObserver targets f -> do - let f' eId evt = unAccess $ f eId evt - (oId, observers') = O.insertEntityObserver @e f' $ observers w - observers'' = foldr (\e os -> O.addEntityObserver @_ @e e oId os) observers' targets - return (oId, observers'') - EventObserver callback -> do - let wrappedCallback evt = unAccess $ callback evt - (oId, observers') = O.insertEventObserver @e wrappedCallback (observers w) - observers'' = O.addGlobalObserver @_ @e oId observers' - return (oId, observers'') - let o' = o {observerId = Just oId} - w' = W.insertUntracked ownerEntity (bundleUntracked o') w {observers = observers'} - put w' - - componentOnRemove _ownerEntity o = Access $ case observerId o of - Just oId -> do - !w <- get - put w {observers = O.removeObserver oId (observers w)} - Nothing -> pure () - --- | Create an observer for specific entities. -observerFor :: forall m e. (Event e) => Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e -observerFor targets callback = Observer {observerKind = EntityObserver targets callback, observerId = Nothing} - --- | Create a global observer (observes all events of this type). -observerGlobal :: forall m e. (Event e) => (e -> Access m ()) -> Observer m e -observerGlobal callback = Observer {observerKind = EventObserver callback, observerId = Nothing} - --- | Create an observer for a single entity. -observer :: forall m e. (Event e) => EntityID -> (EntityID -> e -> Access m ()) -> Observer m e -observer e = observerFor (Set.singleton e) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Observer +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Observer + ( Observer (..), + ObserverID (..), + ObserverKind (..), + observer, + observerFor, + observerGlobal, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import qualified Aztecs.ECS.World as W +import Aztecs.ECS.World.Bundle +import Aztecs.ECS.World.Internal (World (..)) +import qualified Aztecs.ECS.World.Observers as O +import Aztecs.ECS.World.Observers.Internal +import Control.Monad.State +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable +import Data.Vector (Vector) + +-- | The kind of observer - either entity-specific or global. +data ObserverKind m e + = -- | Observe events on specific entities (callback receives EntityID and event). + EntityObserver !(Set EntityID) !(EntityID -> e -> Access m ()) + | -- | Observe all events of this type globally (callback receives just the event). + EventObserver !(e -> Access m ()) + +-- | Observer component +data Observer m e = Observer + { -- | The kind and callback for this observer. + observerKind :: !(ObserverKind m e), + -- | The ObserverID assigned after registration (Nothing before registration). + observerId :: !(Maybe ObserverID) + } + +instance Show (ObserverKind m e) where + show (EntityObserver targets _) = "EntityObserver " ++ show targets + show (EventObserver _) = "EventObserver" + +instance Show (Observer m e) where + show o = "Observer { kind = " ++ show (observerKind o) ++ ", id = " ++ show (observerId o) ++ " }" + +instance (Monad m, Typeable m, Event e) => Component m (Observer m e) where + type StorageT (Observer m e) = Vector (Observer m e) + + componentOnInsert ownerEntity o = Access $ do + !w <- get + (oId, observers') <- case observerKind o of + EntityObserver targets f -> do + let f' eId evt = unAccess $ f eId evt + (oId, observers') = O.insertEntityObserver @e f' $ observers w + observers'' = foldr (\e os -> O.addEntityObserver @_ @e e oId os) observers' targets + return (oId, observers'') + EventObserver callback -> do + let wrappedCallback evt = unAccess $ callback evt + (oId, observers') = O.insertEventObserver @e wrappedCallback (observers w) + observers'' = O.addGlobalObserver @_ @e oId observers' + return (oId, observers'') + let o' = o {observerId = Just oId} + w' = W.insertUntracked ownerEntity (bundleUntracked o') w {observers = observers'} + put w' + + componentOnRemove _ownerEntity o = Access $ case observerId o of + Just oId -> do + !w <- get + put w {observers = O.removeObserver oId (observers w)} + Nothing -> pure () + +-- | Create an observer for specific entities. +observerFor :: forall m e. (Event e) => Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e +observerFor targets callback = Observer {observerKind = EntityObserver targets callback, observerId = Nothing} + +-- | Create a global observer (observes all events of this type). +observerGlobal :: forall m e. (Event e) => (e -> Access m ()) -> Observer m e +observerGlobal callback = Observer {observerKind = EventObserver callback, observerId = Nothing} + +-- | Create an observer for a single entity. +observer :: forall m e. (Event e) => EntityID -> (EntityID -> e -> Access m ()) -> Observer m e +observer e = observerFor (Set.singleton e) diff --git a/src/Aztecs/ECS/Query/Dynamic.hs b/src/Aztecs/ECS/Query/Dynamic.hs --- a/src/Aztecs/ECS/Query/Dynamic.hs +++ b/src/Aztecs/ECS/Query/Dynamic.hs @@ -1,288 +1,288 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.Query.Dynamic --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.Query.Dynamic - ( -- * Dynamic queries - DynamicQuery (..), - DynamicQueryF (..), - - -- ** Running - readQueryDyn, - readQueryFilteredDyn, - readQuerySingleDyn, - readQuerySingleMaybeDyn, - runQueryDyn, - runQueryFilteredDyn, - runQuerySingleDyn, - runQuerySingleMaybeDyn, - - -- * Dynamic query filters - DynamicQueryFilter (..), - ) -where - -import Aztecs.ECS.Access.Internal (Access) -import Aztecs.ECS.Component -import Aztecs.ECS.Query.Dynamic.Class -import Aztecs.ECS.World.Archetype (Archetype) -import qualified Aztecs.ECS.World.Archetype as A -import Aztecs.ECS.World.Archetypes (Node (..)) -import qualified Aztecs.ECS.World.Archetypes as AS -import Aztecs.ECS.World.Entities (Entities (..)) -import Aztecs.ECS.World.Storage.Dynamic -import Data.Foldable -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Vector (Vector) -import qualified Data.Vector as V -import GHC.Stack - --- | Dynamic query for components by ID. -newtype DynamicQuery m a - = DynamicQuery - { -- | Run a dynamic query. - -- - -- @since 0.10 - runDynQuery :: Archetype m -> m (Vector a, Archetype m, Access m ()) - } - deriving (Functor) - -instance (Monad m) => Applicative (DynamicQuery m) where - pure a = DynamicQuery $ \arch -> pure (V.replicate (length $ A.entities arch) a, arch, return ()) - {-# INLINE pure #-} - - f <*> g = DynamicQuery $ \arch -> do - x <- runDynQuery g arch - y <- runDynQuery f arch - return $ - let (as, arch', hook1) = x - (bs, arch'', hook2) = y - in (V.zipWith ($) bs as, arch' <> arch'', hook1 >> hook2) - {-# INLINE (<*>) #-} - -instance (Monad m) => DynamicQueryF m (DynamicQuery m) where - entity = DynamicQuery $ \arch -> pure (V.fromList . Set.toList $ A.entities arch, arch, return ()) - {-# INLINE entity #-} - - queryDyn cId = DynamicQuery $ \arch -> pure (A.lookupComponentsAsc cId arch, arch, return ()) - {-# INLINE queryDyn #-} - - queryMaybeDyn cId = DynamicQuery $ \arch -> case A.lookupComponentsAscMaybe cId arch of - Just as -> pure (V.map Just as, arch, return ()) - Nothing -> pure (V.replicate (length $ A.entities arch) Nothing, arch, return ()) - {-# INLINE queryMaybeDyn #-} - - queryMapDyn f cId = DynamicQuery $ \arch -> do - let (cs, arch', hook) = A.zipWith (V.replicate (length $ A.entities arch) ()) (const f) cId arch - return (cs, arch', hook) - {-# INLINE queryMapDyn #-} - - queryMapDyn_ f cId = DynamicQuery $ \arch -> do - let (arch', hook) = A.zipWith_ (V.replicate (length $ A.entities arch) ()) (const f) cId arch - return (V.replicate (length $ A.entities arch) (), arch', hook) - {-# INLINE queryMapDyn_ #-} - - queryMapDynM f cId = DynamicQuery $ \arch -> do - (cs, arch', hook) <- A.zipWithM (V.replicate (length $ A.entities arch) ()) (const f) cId arch - return (cs, arch', hook) - {-# INLINE queryMapDynM #-} - - queryMapDynWith f cId q = DynamicQuery $ \arch -> do - (as, arch', hook1) <- runDynQuery q arch - let (cs, arch'', hook2) = A.zipWith as f cId arch' - return (cs, arch'', hook1 >> hook2) - {-# INLINE queryMapDynWith #-} - - queryMapDynWith_ f cId q = DynamicQuery $ \arch -> do - (as, arch', hook1) <- runDynQuery q arch - let (arch'', hook2) = A.zipWith_ as f cId arch' - return (V.map (const ()) as, arch'', hook1 >> hook2) - {-# INLINE queryMapDynWith_ #-} - - queryMapDynWithM f cId q = DynamicQuery $ \arch -> do - (as, arch', hook1) <- runDynQuery q arch - (cs, arch'', hook2) <- A.zipWithM as f cId arch' - return (cs, arch'', hook1 >> hook2) - {-# INLINE queryMapDynWithM #-} - - queryMapDynWithAccum f cId q = DynamicQuery $ \arch -> do - (bs, arch', hook1) <- runDynQuery q arch - let (pairs, arch'', hook2) = A.zipWithAccum bs f cId arch' - return (pairs, arch'', hook1 >> hook2) - {-# INLINE queryMapDynWithAccum #-} - - queryMapDynWithAccumM f cId q = DynamicQuery $ \arch -> do - (bs, arch', hook1) <- runDynQuery q arch - (pairs, arch'', hook2) <- A.zipWithAccumM bs f cId arch' - return (pairs, arch'', hook1 >> hook2) - {-# INLINE queryMapDynWithAccumM #-} - - queryUntracked q = DynamicQuery $ \arch -> do - (as, arch', _hooks) <- runDynQuery q arch - return (as, arch', return ()) - {-# INLINE queryUntracked #-} - - queryFilterMap p q = DynamicQuery $ \arch -> do - (as, _, _) <- runDynQuery q arch - let eIds = V.fromList . Set.toList $ A.entities arch - mapped = V.map p as - (filteredEIds, indices, filteredBs) = V.unzip3 . V.imapMaybe (\i (e, mb) -> (\b -> (e, i, b)) <$> mb) $ V.zip eIds mapped - filteredArch = filterArchetype indices arch - (_, filteredArch', hook) <- runDynQuery q filteredArch {A.entities = Set.fromList $ V.toList filteredEIds} - let resultArch = unfilterArchetype indices arch filteredArch' - return (filteredBs, resultArch, hook) - where - filterArchetype indices arch = - arch {A.storages = IntMap.map (filterStorage indices) $ A.storages arch} - filterStorage indices s = - let allVec = toAscVectorDyn s - filteredVec = V.map (allVec V.!) indices - in fromAscVectorDyn filteredVec s - unfilterArchetype indices original filtered = - original {A.storages = IntMap.mapWithKey go $ A.storages original} - where - go cId s = case IntMap.lookup cId (A.storages filtered) of - Just filteredStorage -> - let origVec = toAscVectorDyn s - filteredVec = toAscVectorDyn filteredStorage - mergedVec = V.accum (\_ new -> new) origVec (V.toList $ V.zip indices filteredVec) - in fromAscVectorDyn mergedVec s - Nothing -> s - {-# INLINE queryFilterMap #-} - --- | Match all entities. -readQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a) -readQueryDyn cIds q es = - if Set.null cIds - then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} - else do - let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) - results <- mapM go . Map.elems $ AS.find cIds $ archetypes es - return $ V.concat results - --- | Match all entities with a filter. -readQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a) -readQueryFilteredDyn cIds f q es = - if Set.null cIds - then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} - else do - let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) - results <- mapM go . Map.elems . Map.filter f $ AS.find cIds $ archetypes es - return $ V.concat results - --- | Match a single entity. -readQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m a -readQuerySingleDyn cIds q es = do - res <- readQuerySingleMaybeDyn cIds q es - case res of - Just a -> return a - _ -> error "readQuerySingleDyn: expected a single entity" - --- | Match a single entity, or `Nothing`. -readQuerySingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Maybe a) -readQuerySingleMaybeDyn cIds q es = - if Set.null cIds - then case Map.keys $ entities es of - [eId] -> do - (v, _, _) <- runDynQuery q $ A.singleton eId - return $ if V.length v == 1 then Just (V.head v) else Nothing - _ -> return Nothing - else case Map.elems $ AS.find cIds $ archetypes es of - [n] -> do - (v, _, _) <- runDynQuery q $ AS.nodeArchetype n - return $ if V.length v == 1 then Just (V.head v) else Nothing - _ -> return Nothing - --- | Map all matched entities. -runQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) -runQueryDyn cIds q es = - let go = runDynQuery q - in if Set.null cIds - then do - (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es} - return (as, es, hook) - else - let go' (acc, esAcc, hooks) (aId, n) = do - (as', arch', hook) <- go $ nodeArchetype n - let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc - return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) - in foldlM go' (V.empty, es, return ()) $ Map.toList . AS.find cIds $ archetypes es -{-# INLINE runQueryDyn #-} - --- | Map all matched entities. -runQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) -runQueryFilteredDyn cIds f q es = - let go = runDynQuery q - in if Set.null cIds - then do - (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es} - return (as, es, hook) - else - let go' (acc, esAcc, hooks) (aId, n) = do - (as', arch', hook) <- go $ nodeArchetype n - let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc - return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) - in foldlM go' (V.empty, es, return ()) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es -{-# INLINE runQueryFilteredDyn #-} - --- | Map a single matched entity. -runQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (a, Entities m, Access m ()) -runQuerySingleDyn cIds q es = do - res <- runQuerySingleMaybeDyn cIds q es - return $ case res of - (Just a, es', hook) -> (a, es', hook) - _ -> error "querySingleDyn: expected single matching entity" - --- | Map a single matched entity, or @Nothing@. -runQuerySingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Maybe a, Entities m, Access m ()) -runQuerySingleMaybeDyn cIds q es = - if Set.null cIds - then case Map.keys $ entities es of - [eId] -> do - res <- runDynQuery q $ A.singleton eId - return $ case res of - (v, _, hook) | V.length v == 1 -> (Just (V.head v), es, hook) - _ -> (Nothing, es, return ()) - _ -> pure (Nothing, es, return ()) - else case Map.toList $ AS.find cIds $ archetypes es of - [(aId, n)] -> do - res <- runDynQuery q $ AS.nodeArchetype n - return $ case res of - (v, arch', hook) - | V.length v == 1 -> - let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es - in (Just (V.head v), es {archetypes = (archetypes es) {AS.nodes = nodes}}, hook) - _ -> (Nothing, es, return ()) - _ -> pure (Nothing, es, return ()) -{-# INLINE runQuerySingleMaybeDyn #-} - --- | Dynamic query filter. -data DynamicQueryFilter = DynamicQueryFilter - { -- | `ComponentID`s to include. - filterWith :: !(Set ComponentID), - -- | `ComponentID`s to exclude. - filterWithout :: !(Set ComponentID) - } - -instance Semigroup DynamicQueryFilter where - DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB = - DynamicQueryFilter (withA <> withB) (withoutA <> withoutB) - {-# INLINE (<>) #-} - -instance Monoid DynamicQueryFilter where - mempty = DynamicQueryFilter mempty mempty - {-# INLINE mempty #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Query.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Query.Dynamic + ( -- * Dynamic queries + DynamicQuery (..), + DynamicQueryF (..), + + -- ** Running + readQueryDyn, + readQueryFilteredDyn, + readQuerySingleDyn, + readQuerySingleMaybeDyn, + runQueryDyn, + runQueryFilteredDyn, + runQuerySingleDyn, + runQuerySingleMaybeDyn, + + -- * Dynamic query filters + DynamicQueryFilter (..), + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Query.Dynamic.Class +import Aztecs.ECS.World.Archetype (Archetype) +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Archetypes (Node (..)) +import qualified Aztecs.ECS.World.Archetypes as AS +import Aztecs.ECS.World.Entities (Entities (..)) +import Aztecs.ECS.World.Storage.Dynamic +import Data.Foldable +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Stack + +-- | Dynamic query for components by ID. +newtype DynamicQuery m a + = DynamicQuery + { -- | Run a dynamic query. + -- + -- @since 0.10 + runDynQuery :: Archetype m -> m (Vector a, Archetype m, Access m ()) + } + deriving (Functor) + +instance (Monad m) => Applicative (DynamicQuery m) where + pure a = DynamicQuery $ \arch -> pure (V.replicate (length $ A.entities arch) a, arch, return ()) + {-# INLINE pure #-} + + f <*> g = DynamicQuery $ \arch -> do + x <- runDynQuery g arch + y <- runDynQuery f arch + return $ + let (as, arch', hook1) = x + (bs, arch'', hook2) = y + in (V.zipWith ($) bs as, arch' <> arch'', hook1 >> hook2) + {-# INLINE (<*>) #-} + +instance (Monad m) => DynamicQueryF m (DynamicQuery m) where + entity = DynamicQuery $ \arch -> pure (V.fromList . Set.toList $ A.entities arch, arch, return ()) + {-# INLINE entity #-} + + queryDyn cId = DynamicQuery $ \arch -> pure (A.lookupComponentsAsc cId arch, arch, return ()) + {-# INLINE queryDyn #-} + + queryMaybeDyn cId = DynamicQuery $ \arch -> case A.lookupComponentsAscMaybe cId arch of + Just as -> pure (V.map Just as, arch, return ()) + Nothing -> pure (V.replicate (length $ A.entities arch) Nothing, arch, return ()) + {-# INLINE queryMaybeDyn #-} + + queryMapDyn f cId = DynamicQuery $ \arch -> do + let (cs, arch', hook) = A.zipWith (V.replicate (length $ A.entities arch) ()) (const f) cId arch + return (cs, arch', hook) + {-# INLINE queryMapDyn #-} + + queryMapDyn_ f cId = DynamicQuery $ \arch -> do + let (arch', hook) = A.zipWith_ (V.replicate (length $ A.entities arch) ()) (const f) cId arch + return (V.replicate (length $ A.entities arch) (), arch', hook) + {-# INLINE queryMapDyn_ #-} + + queryMapDynM f cId = DynamicQuery $ \arch -> do + (cs, arch', hook) <- A.zipWithM (V.replicate (length $ A.entities arch) ()) (const f) cId arch + return (cs, arch', hook) + {-# INLINE queryMapDynM #-} + + queryMapDynWith f cId q = DynamicQuery $ \arch -> do + (as, arch', hook1) <- runDynQuery q arch + let (cs, arch'', hook2) = A.zipWith as f cId arch' + return (cs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWith #-} + + queryMapDynWith_ f cId q = DynamicQuery $ \arch -> do + (as, arch', hook1) <- runDynQuery q arch + let (arch'', hook2) = A.zipWith_ as f cId arch' + return (V.map (const ()) as, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWith_ #-} + + queryMapDynWithM f cId q = DynamicQuery $ \arch -> do + (as, arch', hook1) <- runDynQuery q arch + (cs, arch'', hook2) <- A.zipWithM as f cId arch' + return (cs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWithM #-} + + queryMapDynWithAccum f cId q = DynamicQuery $ \arch -> do + (bs, arch', hook1) <- runDynQuery q arch + let (pairs, arch'', hook2) = A.zipWithAccum bs f cId arch' + return (pairs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWithAccum #-} + + queryMapDynWithAccumM f cId q = DynamicQuery $ \arch -> do + (bs, arch', hook1) <- runDynQuery q arch + (pairs, arch'', hook2) <- A.zipWithAccumM bs f cId arch' + return (pairs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWithAccumM #-} + + queryUntracked q = DynamicQuery $ \arch -> do + (as, arch', _hooks) <- runDynQuery q arch + return (as, arch', return ()) + {-# INLINE queryUntracked #-} + + queryFilterMap p q = DynamicQuery $ \arch -> do + (as, _, _) <- runDynQuery q arch + let eIds = V.fromList . Set.toList $ A.entities arch + mapped = V.map p as + (filteredEIds, indices, filteredBs) = V.unzip3 . V.imapMaybe (\i (e, mb) -> (\b -> (e, i, b)) <$> mb) $ V.zip eIds mapped + filteredArch = filterArchetype indices arch + (_, filteredArch', hook) <- runDynQuery q filteredArch {A.entities = Set.fromList $ V.toList filteredEIds} + let resultArch = unfilterArchetype indices arch filteredArch' + return (filteredBs, resultArch, hook) + where + filterArchetype indices arch = + arch {A.storages = IntMap.map (filterStorage indices) $ A.storages arch} + filterStorage indices s = + let allVec = toAscVectorDyn s + filteredVec = V.map (allVec V.!) indices + in fromAscVectorDyn filteredVec s + unfilterArchetype indices original filtered = + original {A.storages = IntMap.mapWithKey go $ A.storages original} + where + go cId s = case IntMap.lookup cId (A.storages filtered) of + Just filteredStorage -> + let origVec = toAscVectorDyn s + filteredVec = toAscVectorDyn filteredStorage + mergedVec = V.accum (\_ new -> new) origVec (V.toList $ V.zip indices filteredVec) + in fromAscVectorDyn mergedVec s + Nothing -> s + {-# INLINE queryFilterMap #-} + +-- | Match all entities. +readQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a) +readQueryDyn cIds q es = + if Set.null cIds + then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} + else do + let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) + results <- mapM go . Map.elems $ AS.find cIds $ archetypes es + return $ V.concat results + +-- | Match all entities with a filter. +readQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a) +readQueryFilteredDyn cIds f q es = + if Set.null cIds + then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} + else do + let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) + results <- mapM go . Map.elems . Map.filter f $ AS.find cIds $ archetypes es + return $ V.concat results + +-- | Match a single entity. +readQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m a +readQuerySingleDyn cIds q es = do + res <- readQuerySingleMaybeDyn cIds q es + case res of + Just a -> return a + _ -> error "readQuerySingleDyn: expected a single entity" + +-- | Match a single entity, or `Nothing`. +readQuerySingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Maybe a) +readQuerySingleMaybeDyn cIds q es = + if Set.null cIds + then case Map.keys $ entities es of + [eId] -> do + (v, _, _) <- runDynQuery q $ A.singleton eId + return $ if V.length v == 1 then Just (V.head v) else Nothing + _ -> return Nothing + else case Map.elems $ AS.find cIds $ archetypes es of + [n] -> do + (v, _, _) <- runDynQuery q $ AS.nodeArchetype n + return $ if V.length v == 1 then Just (V.head v) else Nothing + _ -> return Nothing + +-- | Map all matched entities. +runQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) +runQueryDyn cIds q es = + let go = runDynQuery q + in if Set.null cIds + then do + (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es} + return (as, es, hook) + else + let go' (acc, esAcc, hooks) (aId, n) = do + (as', arch', hook) <- go $ nodeArchetype n + let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc + return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) + in foldlM go' (V.empty, es, return ()) $ Map.toList . AS.find cIds $ archetypes es +{-# INLINE runQueryDyn #-} + +-- | Map all matched entities. +runQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) +runQueryFilteredDyn cIds f q es = + let go = runDynQuery q + in if Set.null cIds + then do + (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es} + return (as, es, hook) + else + let go' (acc, esAcc, hooks) (aId, n) = do + (as', arch', hook) <- go $ nodeArchetype n + let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc + return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) + in foldlM go' (V.empty, es, return ()) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es +{-# INLINE runQueryFilteredDyn #-} + +-- | Map a single matched entity. +runQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (a, Entities m, Access m ()) +runQuerySingleDyn cIds q es = do + res <- runQuerySingleMaybeDyn cIds q es + return $ case res of + (Just a, es', hook) -> (a, es', hook) + _ -> error "querySingleDyn: expected single matching entity" + +-- | Map a single matched entity, or @Nothing@. +runQuerySingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Maybe a, Entities m, Access m ()) +runQuerySingleMaybeDyn cIds q es = + if Set.null cIds + then case Map.keys $ entities es of + [eId] -> do + res <- runDynQuery q $ A.singleton eId + return $ case res of + (v, _, hook) | V.length v == 1 -> (Just (V.head v), es, hook) + _ -> (Nothing, es, return ()) + _ -> pure (Nothing, es, return ()) + else case Map.toList $ AS.find cIds $ archetypes es of + [(aId, n)] -> do + res <- runDynQuery q $ AS.nodeArchetype n + return $ case res of + (v, arch', hook) + | V.length v == 1 -> + let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es + in (Just (V.head v), es {archetypes = (archetypes es) {AS.nodes = nodes}}, hook) + _ -> (Nothing, es, return ()) + _ -> pure (Nothing, es, return ()) +{-# INLINE runQuerySingleMaybeDyn #-} + +-- | Dynamic query filter. +data DynamicQueryFilter = DynamicQueryFilter + { -- | `ComponentID`s to include. + filterWith :: !(Set ComponentID), + -- | `ComponentID`s to exclude. + filterWithout :: !(Set ComponentID) + } + +instance Semigroup DynamicQueryFilter where + DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB = + DynamicQueryFilter (withA <> withB) (withoutA <> withoutB) + {-# INLINE (<>) #-} + +instance Monoid DynamicQueryFilter where + mempty = DynamicQueryFilter mempty mempty + {-# INLINE mempty #-} diff --git a/src/Aztecs/ECS/System/Dynamic.hs b/src/Aztecs/ECS/System/Dynamic.hs --- a/src/Aztecs/ECS/System/Dynamic.hs +++ b/src/Aztecs/ECS/System/Dynamic.hs @@ -1,145 +1,145 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | --- Module : Aztecs.ECS.System --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.System.Dynamic - ( -- * Dynamic systems - DynamicSystem (..), - runDynamicSystem, - - -- ** Queries - runQuery, - runQueryFiltered, - runQuerySingle, - runQuerySingleMaybe, - readQuery, - readQueryFiltered, - readQuerySingle, - readQuerySingleMaybe, - ) -where - -import Aztecs.ECS.Access.Internal (Access) -import Aztecs.ECS.Component -import Aztecs.ECS.Query.Dynamic (DynamicQuery) -import qualified Aztecs.ECS.Query.Dynamic as DQ -import Aztecs.ECS.World.Archetypes (Node (..)) -import Aztecs.ECS.World.Entities (Entities) -import Data.Set (Set) -import Data.Vector (Vector) -import Prelude hiding (all, filter, map, mapM) - --- | Query operation. -data Op m a where - RunQuery :: DynamicQuery m a -> Op m (Vector a) - RunFiltered :: (Node m -> Bool) -> DynamicQuery m a -> Op m (Vector a) - RunQuerySingle :: DynamicQuery m a -> Op m a - RunQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) - ReadQuery :: DynamicQuery m a -> Op m (Vector a) - ReadQueryFiltered :: DynamicQuery m a -> (Node m -> Bool) -> Op m (Vector a) - ReadQuerySingle :: DynamicQuery m a -> Op m a - ReadQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) - --- | Run a query operation on entities. -runOp :: (Monad m) => Set ComponentID -> Op m a -> Entities m -> m (a, Entities m, Access m ()) -runOp cIds (RunQuery q) es = DQ.runQueryDyn cIds q es -runOp cIds (RunFiltered flt q) es = DQ.runQueryFilteredDyn cIds flt q es -runOp cIds (RunQuerySingle q) es = DQ.runQuerySingleDyn cIds q es -runOp cIds (RunQuerySingleMaybe q) es = DQ.runQuerySingleMaybeDyn cIds q es -runOp cIds (ReadQuery q) es = do - as <- DQ.readQueryDyn cIds q es - return (as, es, return ()) -runOp cIds (ReadQueryFiltered q flt) es = do - as <- DQ.readQueryFilteredDyn cIds flt q es - return (as, es, return ()) -runOp cIds (ReadQuerySingle q) es = do - a <- DQ.readQuerySingleDyn cIds q es - return (a, es, return ()) -runOp cIds (ReadQuerySingleMaybe q) es = do - a <- DQ.readQuerySingleMaybeDyn cIds q es - return (a, es, return ()) -{-# INLINE runOp #-} - --- | Dynamic system. -data DynamicSystem m a where - -- | Pure value. - Pure :: a -> DynamicSystem m a - -- | Functor map. - Map :: (b -> a) -> DynamicSystem m b -> DynamicSystem m a - -- | Applicative apply. - Ap :: DynamicSystem m (b -> a) -> DynamicSystem m b -> DynamicSystem m a - -- | Query operation. - Op :: Set ComponentID -> Op m a -> DynamicSystem m a - -instance Functor (DynamicSystem m) where - fmap f (Pure a) = Pure (f a) - fmap f s = Map f s - {-# INLINE fmap #-} - -instance Applicative (DynamicSystem m) where - pure = Pure - {-# INLINE pure #-} - - Pure f <*> s = fmap f s - f <*> Pure a = fmap ($ a) f - f <*> s = Ap f s - {-# INLINE (<*>) #-} - --- | Run a dynamic system on entities, returning results, updated entities, and hooks to run. -runDynamicSystem :: (Monad m) => DynamicSystem m a -> Entities m -> m (a, Entities m, Access m ()) -runDynamicSystem (Pure a) es = return (a, es, return ()) -runDynamicSystem (Map f s) es = do - (b, es', hook) <- runDynamicSystem s es - return (f b, es', hook) -runDynamicSystem (Ap sf sa) es = do - (f, es', hook1) <- runDynamicSystem sf es - (a, es'', hook2) <- runDynamicSystem sa es' - return (f a, es'', hook1 >> hook2) -runDynamicSystem (Op cIds op) es = runOp cIds op es -{-# INLINE runDynamicSystem #-} - -runQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) -runQuery cIds q = Op cIds (RunQuery q) -{-# INLINE runQuery #-} - -runQueryFiltered :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> DynamicSystem m (Vector a) -runQueryFiltered cIds q flt = Op cIds (RunFiltered flt q) -{-# INLINE runQueryFiltered #-} - -runQuerySingle :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m a -runQuerySingle cIds q = Op cIds (RunQuerySingle q) -{-# INLINE runQuerySingle #-} - -runQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Maybe a) -runQuerySingleMaybe cIds q = Op cIds (RunQuerySingleMaybe q) -{-# INLINE runQuerySingleMaybe #-} - -readQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) -readQuery cIds q = Op cIds (ReadQuery q) -{-# INLINE readQuery #-} - -readQueryFiltered :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> DynamicSystem m (Vector a) -readQueryFiltered cIds flt q = Op cIds (ReadQueryFiltered q flt) -{-# INLINE readQueryFiltered #-} - -readQuerySingle :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m a -readQuerySingle cIds q = Op cIds (ReadQuerySingle q) - -readQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Maybe a) -readQuerySingleMaybe cIds q = Op cIds (ReadQuerySingleMaybe q) -{-# INLINE readQuerySingleMaybe #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module : Aztecs.ECS.System +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.System.Dynamic + ( -- * Dynamic systems + DynamicSystem (..), + runDynamicSystem, + + -- ** Queries + runQuery, + runQueryFiltered, + runQuerySingle, + runQuerySingleMaybe, + readQuery, + readQueryFiltered, + readQuerySingle, + readQuerySingleMaybe, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Query.Dynamic (DynamicQuery) +import qualified Aztecs.ECS.Query.Dynamic as DQ +import Aztecs.ECS.World.Archetypes (Node (..)) +import Aztecs.ECS.World.Entities (Entities) +import Data.Set (Set) +import Data.Vector (Vector) +import Prelude hiding (all, filter, map, mapM) + +-- | Query operation. +data Op m a where + RunQuery :: DynamicQuery m a -> Op m (Vector a) + RunFiltered :: (Node m -> Bool) -> DynamicQuery m a -> Op m (Vector a) + RunQuerySingle :: DynamicQuery m a -> Op m a + RunQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) + ReadQuery :: DynamicQuery m a -> Op m (Vector a) + ReadQueryFiltered :: DynamicQuery m a -> (Node m -> Bool) -> Op m (Vector a) + ReadQuerySingle :: DynamicQuery m a -> Op m a + ReadQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) + +-- | Run a query operation on entities. +runOp :: (Monad m) => Set ComponentID -> Op m a -> Entities m -> m (a, Entities m, Access m ()) +runOp cIds (RunQuery q) es = DQ.runQueryDyn cIds q es +runOp cIds (RunFiltered flt q) es = DQ.runQueryFilteredDyn cIds flt q es +runOp cIds (RunQuerySingle q) es = DQ.runQuerySingleDyn cIds q es +runOp cIds (RunQuerySingleMaybe q) es = DQ.runQuerySingleMaybeDyn cIds q es +runOp cIds (ReadQuery q) es = do + as <- DQ.readQueryDyn cIds q es + return (as, es, return ()) +runOp cIds (ReadQueryFiltered q flt) es = do + as <- DQ.readQueryFilteredDyn cIds flt q es + return (as, es, return ()) +runOp cIds (ReadQuerySingle q) es = do + a <- DQ.readQuerySingleDyn cIds q es + return (a, es, return ()) +runOp cIds (ReadQuerySingleMaybe q) es = do + a <- DQ.readQuerySingleMaybeDyn cIds q es + return (a, es, return ()) +{-# INLINE runOp #-} + +-- | Dynamic system. +data DynamicSystem m a where + -- | Pure value. + Pure :: a -> DynamicSystem m a + -- | Functor map. + Map :: (b -> a) -> DynamicSystem m b -> DynamicSystem m a + -- | Applicative apply. + Ap :: DynamicSystem m (b -> a) -> DynamicSystem m b -> DynamicSystem m a + -- | Query operation. + Op :: Set ComponentID -> Op m a -> DynamicSystem m a + +instance Functor (DynamicSystem m) where + fmap f (Pure a) = Pure (f a) + fmap f s = Map f s + {-# INLINE fmap #-} + +instance Applicative (DynamicSystem m) where + pure = Pure + {-# INLINE pure #-} + + Pure f <*> s = fmap f s + f <*> Pure a = fmap ($ a) f + f <*> s = Ap f s + {-# INLINE (<*>) #-} + +-- | Run a dynamic system on entities, returning results, updated entities, and hooks to run. +runDynamicSystem :: (Monad m) => DynamicSystem m a -> Entities m -> m (a, Entities m, Access m ()) +runDynamicSystem (Pure a) es = return (a, es, return ()) +runDynamicSystem (Map f s) es = do + (b, es', hook) <- runDynamicSystem s es + return (f b, es', hook) +runDynamicSystem (Ap sf sa) es = do + (f, es', hook1) <- runDynamicSystem sf es + (a, es'', hook2) <- runDynamicSystem sa es' + return (f a, es'', hook1 >> hook2) +runDynamicSystem (Op cIds op) es = runOp cIds op es +{-# INLINE runDynamicSystem #-} + +runQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) +runQuery cIds q = Op cIds (RunQuery q) +{-# INLINE runQuery #-} + +runQueryFiltered :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> DynamicSystem m (Vector a) +runQueryFiltered cIds q flt = Op cIds (RunFiltered flt q) +{-# INLINE runQueryFiltered #-} + +runQuerySingle :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m a +runQuerySingle cIds q = Op cIds (RunQuerySingle q) +{-# INLINE runQuerySingle #-} + +runQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Maybe a) +runQuerySingleMaybe cIds q = Op cIds (RunQuerySingleMaybe q) +{-# INLINE runQuerySingleMaybe #-} + +readQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) +readQuery cIds q = Op cIds (ReadQuery q) +{-# INLINE readQuery #-} + +readQueryFiltered :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> DynamicSystem m (Vector a) +readQueryFiltered cIds flt q = Op cIds (ReadQueryFiltered q flt) +{-# INLINE readQueryFiltered #-} + +readQuerySingle :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m a +readQuerySingle cIds q = Op cIds (ReadQuerySingle q) + +readQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Maybe a) +readQuerySingleMaybe cIds q = Op cIds (ReadQuerySingleMaybe q) +{-# INLINE readQuerySingleMaybe #-} diff --git a/src/Aztecs/ECS/World.hs b/src/Aztecs/ECS/World.hs --- a/src/Aztecs/ECS/World.hs +++ b/src/Aztecs/ECS/World.hs @@ -1,89 +1,89 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World - ( World (..), - empty, - spawn, - spawnEmpty, - insert, - insertUntracked, - lookup, - remove, - removeWithId, - despawn, - ) -where - -import Aztecs.ECS.Access.Internal (Access) -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Bundle -import qualified Aztecs.ECS.World.Entities as E -import Aztecs.ECS.World.Internal (World (..)) -import qualified Aztecs.ECS.World.Observers as O -import Data.Dynamic -import Data.IntMap (IntMap) -import Prelude hiding (lookup) - --- | Empty `World`. -empty :: World m -empty = - World - { entities = E.empty, - nextEntityId = EntityID 0, - observers = O.empty - } - --- | Spawn a `Bundle` into the `World`. Returns the entity ID, updated world, and onInsert hook. -spawn :: (Monad m) => BundleT m -> World m -> (EntityID, World m, Access m ()) -spawn b w = - let e = nextEntityId w - (es', hook) = E.spawn e b $ entities w - in (e, w {entities = es', nextEntityId = EntityID $ unEntityId e + 1}, hook) - --- | Spawn an empty entity. -spawnEmpty :: World m -> (EntityID, World m) -spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID $ unEntityId e + 1}) - --- | Insert a `Bundle` into an entity. Returns updated world and onInsert hook. -insert :: (Monad m) => EntityID -> BundleT m -> World m -> (World m, Access m ()) -insert e c w = - let (es', hook) = E.insert e c (entities w) - in (w {entities = es'}, hook) - --- | Insert a `Bundle` into an entity without running lifecycle hooks. -insertUntracked :: (Monad m) => EntityID -> BundleT m -> World m -> World m -insertUntracked e c w = - let es' = E.insertUntracked e c (entities w) - in w {entities = es'} - --- | Lookup a component in an entity. -lookup :: forall m a. (Component m a) => EntityID -> World m -> Maybe a -lookup e w = E.lookup e $ entities w - --- | Remove a component from an entity. Returns the component (if found), updated world, and onRemove hook. -remove :: forall m a. (Component m a) => EntityID -> World m -> (Maybe a, World m, Access m ()) -remove e w = - let (a, es, hook) = E.remove e (entities w) - in (a, w {entities = es}, hook) - --- | Remove a component from an entity with its `ComponentID`. Returns the component (if found), updated world, and onRemove hook. -removeWithId :: forall m a. (Component m a) => EntityID -> ComponentID -> World m -> (Maybe a, World m, Access m ()) -removeWithId e cId w = - let (a, es, hook) = E.removeWithId e cId (entities w) - in (a, w {entities = es}, hook) - --- | Despawn an entity, returning its components. -despawn :: EntityID -> World m -> (IntMap Dynamic, World m) -despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es}) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World + ( World (..), + empty, + spawn, + spawnEmpty, + insert, + insertUntracked, + lookup, + remove, + removeWithId, + despawn, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Bundle +import qualified Aztecs.ECS.World.Entities as E +import Aztecs.ECS.World.Internal (World (..)) +import qualified Aztecs.ECS.World.Observers as O +import Data.Dynamic +import Data.IntMap (IntMap) +import Prelude hiding (lookup) + +-- | Empty `World`. +empty :: World m +empty = + World + { entities = E.empty, + nextEntityId = EntityID 0, + observers = O.empty + } + +-- | Spawn a `Bundle` into the `World`. Returns the entity ID, updated world, and onInsert hook. +spawn :: (Monad m) => BundleT m -> World m -> (EntityID, World m, Access m ()) +spawn b w = + let e = nextEntityId w + (es', hook) = E.spawn e b $ entities w + in (e, w {entities = es', nextEntityId = EntityID $ unEntityId e + 1}, hook) + +-- | Spawn an empty entity. +spawnEmpty :: World m -> (EntityID, World m) +spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID $ unEntityId e + 1}) + +-- | Insert a `Bundle` into an entity. Returns updated world and onInsert hook. +insert :: (Monad m) => EntityID -> BundleT m -> World m -> (World m, Access m ()) +insert e c w = + let (es', hook) = E.insert e c (entities w) + in (w {entities = es'}, hook) + +-- | Insert a `Bundle` into an entity without running lifecycle hooks. +insertUntracked :: (Monad m) => EntityID -> BundleT m -> World m -> World m +insertUntracked e c w = + let es' = E.insertUntracked e c (entities w) + in w {entities = es'} + +-- | Lookup a component in an entity. +lookup :: forall m a. (Component m a) => EntityID -> World m -> Maybe a +lookup e w = E.lookup e $ entities w + +-- | Remove a component from an entity. Returns the component (if found), updated world, and onRemove hook. +remove :: forall m a. (Component m a) => EntityID -> World m -> (Maybe a, World m, Access m ()) +remove e w = + let (a, es, hook) = E.remove e (entities w) + in (a, w {entities = es}, hook) + +-- | Remove a component from an entity with its `ComponentID`. Returns the component (if found), updated world, and onRemove hook. +removeWithId :: forall m a. (Component m a) => EntityID -> ComponentID -> World m -> (Maybe a, World m, Access m ()) +removeWithId e cId w = + let (a, es, hook) = E.removeWithId e cId (entities w) + in (a, w {entities = es}, hook) + +-- | Despawn an entity, returning its components. +despawn :: EntityID -> World m -> (IntMap Dynamic, World m) +despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es}) diff --git a/src/Aztecs/ECS/World/Archetype/Internal.hs b/src/Aztecs/ECS/World/Archetype/Internal.hs --- a/src/Aztecs/ECS/World/Archetype/Internal.hs +++ b/src/Aztecs/ECS/World/Archetype/Internal.hs @@ -1,41 +1,41 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} - --- | --- Module : Aztecs.ECS.World.Archetype.Internal --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Archetype.Internal (Archetype (..), empty) where - -import Aztecs.ECS.Entity (EntityID) -import Aztecs.ECS.World.Storage.Dynamic (DynamicStorage) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Kind (Type) -import Data.Set (Set) -import qualified Data.Set as Set -import GHC.Generics - --- | Archetype of entities and components. --- An archetype is guranteed to contain one of each stored component per entity. -data Archetype (m :: Type -> Type) = Archetype - { -- | Component storages. - storages :: !(IntMap DynamicStorage), - -- | Entities stored in this archetype. - entities :: !(Set EntityID) - } - deriving (Show, Generic) - -instance Semigroup (Archetype m) where - a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b} - -instance Monoid (Archetype m) where - mempty = empty - --- | Empty archetype. -empty :: Archetype m -empty = Archetype {storages = IntMap.empty, entities = Set.empty} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- Module : Aztecs.ECS.World.Archetype.Internal +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Archetype.Internal (Archetype (..), empty) where + +import Aztecs.ECS.Entity (EntityID) +import Aztecs.ECS.World.Storage.Dynamic (DynamicStorage) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Kind (Type) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics + +-- | Archetype of entities and components. +-- An archetype is guranteed to contain one of each stored component per entity. +data Archetype (m :: Type -> Type) = Archetype + { -- | Component storages. + storages :: !(IntMap DynamicStorage), + -- | Entities stored in this archetype. + entities :: !(Set EntityID) + } + deriving (Show, Generic) + +instance Semigroup (Archetype m) where + a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b} + +instance Monoid (Archetype m) where + mempty = empty + +-- | Empty archetype. +empty :: Archetype m +empty = Archetype {storages = IntMap.empty, entities = Set.empty} diff --git a/src/Aztecs/ECS/World/Archetypes.hs b/src/Aztecs/ECS/World/Archetypes.hs --- a/src/Aztecs/ECS/World/Archetypes.hs +++ b/src/Aztecs/ECS/World/Archetypes.hs @@ -1,204 +1,204 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - --- | --- Module : Aztecs.ECS.World.Archetypes --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Archetypes - ( ArchetypeID (..), - Node (..), - Archetypes (..), - empty, - insertArchetype, - lookupArchetypeId, - findArchetypeIds, - lookup, - find, - map, - adjustArchetype, - insert, - remove, - ) -where - -import Aztecs.ECS.Access.Internal -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.Event -import Aztecs.ECS.World.Archetype (Archetype (..)) -import qualified Aztecs.ECS.World.Archetype as A -import Aztecs.ECS.World.Archetypes.Internal -import Aztecs.ECS.World.Bundle.Dynamic -import Aztecs.ECS.World.Storage.Dynamic -import Data.Dynamic -import Data.Foldable hiding (find) -import qualified Data.IntMap.Strict as IntMap -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Vector as V -import Prelude hiding (all, lookup, map) - --- | Empty `Archetypes`. -empty :: Archetypes m -empty = - Archetypes - { nodes = mempty, - archetypeIds = mempty, - nextArchetypeId = ArchetypeID 0, - componentIds = mempty - } - --- | Insert an archetype by its set of `ComponentID`s. -insertArchetype :: Set ComponentID -> Node m -> Archetypes m -> (ArchetypeID, Archetypes m) -insertArchetype cIds n arches = - let aId = nextArchetypeId arches - in ( aId, - arches - { nodes = Map.insert aId n (nodes arches), - archetypeIds = Map.insert cIds aId (archetypeIds arches), - nextArchetypeId = ArchetypeID (unArchetypeId aId + 1), - componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches) - } - ) - --- | Adjust an `Archetype` by its `ArchetypeID`. -adjustArchetype :: ArchetypeID -> (Archetype m -> Archetype m) -> Archetypes m -> Archetypes m -adjustArchetype aId f arches = - arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)} - --- | Find `ArchetypeID`s containing a set of `ComponentID`s. -findArchetypeIds :: Set ComponentID -> Archetypes m -> Set ArchetypeID -findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of - (aId : aIds') -> foldl' Set.intersection aId aIds' - [] -> Set.empty - --- | Lookup `Archetype`s containing a set of `ComponentID`s. -find :: Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m) -find cIds arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds cIds arches) - --- | Map over `Archetype`s containing a set of `ComponentID`s. -map :: Set ComponentID -> (Archetype m -> (a, Archetype m)) -> Archetypes m -> ([a], Archetypes m) -map cIds f arches = - let go (acc, archAcc) aId = - let !node = nodes archAcc Map.! aId - !(a, arch') = f (nodeArchetype node) - nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc) - in (a : acc, archAcc {nodes = nodes'}) - in foldl' go ([], arches) $ findArchetypeIds cIds arches - --- | Lookup an `ArchetypeID` by its set of `ComponentID`s. -lookupArchetypeId :: Set ComponentID -> Archetypes m -> Maybe ArchetypeID -lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches) - --- | Lookup an `Archetype` by its `ArchetypeID`. -lookup :: ArchetypeID -> Archetypes m -> Maybe (Node m) -lookup aId arches = Map.lookup aId (nodes arches) - --- | Insert a component into an entity with its `ComponentID`. -insert :: - (Monad m) => - EntityID -> - ArchetypeID -> - Set ComponentID -> - DynamicBundle m -> - Archetypes m -> - (Maybe ArchetypeID, Archetypes m, Access m ()) -insert e aId cIds b arches = case lookup aId arches of - Just node -> - if Set.isSubsetOf cIds $ nodeComponentIds node - then - let go n = - let (arch', hook) = runDynamicBundle b e $ nodeArchetype n - in (n {nodeArchetype = arch'}, hook) - (hooks, nodes') = - Map.alterF - ( \maybeN -> case maybeN of - Just n -> let (n', hook) = go n in (hook, Just n') - Nothing -> (return (), Nothing) - ) - aId - $ nodes arches - in (Nothing, arches {nodes = nodes'}, hooks) - else - let cIds' = cIds <> nodeComponentIds node - in case lookupArchetypeId cIds' arches of - Just nextAId -> - let !(cs, arch) = A.remove e $ nodeArchetype node - node' = node {nodeArchetype = arch} - !nodes' = Map.insert aId node' $ nodes arches - adjustNode nextNode = - let nextArch = nodeArchetype nextNode - nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch} - !nextArch'' = A.insertComponents e cs nextArch' - (finalArch, hook) = runDynamicBundle b e nextArch'' - in (nextNode {nodeArchetype = finalArch}, hook) - (hooks, nodes'') = - Map.alterF - ( \maybeN -> case maybeN of - Just n -> let (n', hook) = adjustNode n in (hook, Just n') - Nothing -> (return (), Nothing) - ) - nextAId - nodes' - in (Just nextAId, arches {nodes = nodes''}, hooks) - Nothing -> - let !(s, arch) = A.removeStorages e $ nodeArchetype node - nodes' = Map.insert aId node {nodeArchetype = arch} $ nodes arches - (nextArch, hook) = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e} - !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch} - !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'} - in (Just nextAId, arches', hook) - Nothing -> (Nothing, arches, return ()) - --- | Remove a component from an entity with its `ComponentID`. -remove :: - (Component m a) => - EntityID -> - ArchetypeID -> - ComponentID -> - Archetypes m -> - (Maybe (a, ArchetypeID), Archetypes m, Access m ()) -remove e aId cId arches = case lookup aId arches of - Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of - Just nextAId -> - let !(cs, arch') = A.remove e (nodeArchetype node) - !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)} - (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs - go' archAcc (itemCId, dyn) = - let adjustStorage s = fromAscVectorDyn (V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) . V.toList $ toAscVectorDyn s) s - in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)} - go nextNode = - nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')} - maybeA = a >>= fromDynamic - hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA - in ( (,nextAId) <$> maybeA, - arches' {nodes = Map.adjust go nextAId (nodes arches')}, - hook - ) - Nothing -> - let !(cs, arch') = A.removeStorages e (nodeArchetype node) - (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs - destCIds = Set.delete cId (nodeComponentIds node) - !n = - Node - { nodeComponentIds = destCIds, - nodeArchetype = Archetype {storages = cs', entities = Set.singleton e} - } - !(nextAId, arches') = insertArchetype destCIds n arches - node' = node {nodeArchetype = arch'} - maybeA = a >>= (\dynS -> V.headM (toAscVectorDyn dynS) >>= fromDynamic) - hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA - in ( (,nextAId) <$> maybeA, - arches' {nodes = Map.insert aId node' (nodes arches')}, - hook - ) - Nothing -> (Nothing, arches, return ()) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Aztecs.ECS.World.Archetypes +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Archetypes + ( ArchetypeID (..), + Node (..), + Archetypes (..), + empty, + insertArchetype, + lookupArchetypeId, + findArchetypeIds, + lookup, + find, + map, + adjustArchetype, + insert, + remove, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import Aztecs.ECS.World.Archetype (Archetype (..)) +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Archetypes.Internal +import Aztecs.ECS.World.Bundle.Dynamic +import Aztecs.ECS.World.Storage.Dynamic +import Data.Dynamic +import Data.Foldable hiding (find) +import qualified Data.IntMap.Strict as IntMap +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector as V +import Prelude hiding (all, lookup, map) + +-- | Empty `Archetypes`. +empty :: Archetypes m +empty = + Archetypes + { nodes = mempty, + archetypeIds = mempty, + nextArchetypeId = ArchetypeID 0, + componentIds = mempty + } + +-- | Insert an archetype by its set of `ComponentID`s. +insertArchetype :: Set ComponentID -> Node m -> Archetypes m -> (ArchetypeID, Archetypes m) +insertArchetype cIds n arches = + let aId = nextArchetypeId arches + in ( aId, + arches + { nodes = Map.insert aId n (nodes arches), + archetypeIds = Map.insert cIds aId (archetypeIds arches), + nextArchetypeId = ArchetypeID (unArchetypeId aId + 1), + componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches) + } + ) + +-- | Adjust an `Archetype` by its `ArchetypeID`. +adjustArchetype :: ArchetypeID -> (Archetype m -> Archetype m) -> Archetypes m -> Archetypes m +adjustArchetype aId f arches = + arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)} + +-- | Find `ArchetypeID`s containing a set of `ComponentID`s. +findArchetypeIds :: Set ComponentID -> Archetypes m -> Set ArchetypeID +findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of + (aId : aIds') -> foldl' Set.intersection aId aIds' + [] -> Set.empty + +-- | Lookup `Archetype`s containing a set of `ComponentID`s. +find :: Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m) +find cIds arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds cIds arches) + +-- | Map over `Archetype`s containing a set of `ComponentID`s. +map :: Set ComponentID -> (Archetype m -> (a, Archetype m)) -> Archetypes m -> ([a], Archetypes m) +map cIds f arches = + let go (acc, archAcc) aId = + let !node = nodes archAcc Map.! aId + !(a, arch') = f (nodeArchetype node) + nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc) + in (a : acc, archAcc {nodes = nodes'}) + in foldl' go ([], arches) $ findArchetypeIds cIds arches + +-- | Lookup an `ArchetypeID` by its set of `ComponentID`s. +lookupArchetypeId :: Set ComponentID -> Archetypes m -> Maybe ArchetypeID +lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches) + +-- | Lookup an `Archetype` by its `ArchetypeID`. +lookup :: ArchetypeID -> Archetypes m -> Maybe (Node m) +lookup aId arches = Map.lookup aId (nodes arches) + +-- | Insert a component into an entity with its `ComponentID`. +insert :: + (Monad m) => + EntityID -> + ArchetypeID -> + Set ComponentID -> + DynamicBundle m -> + Archetypes m -> + (Maybe ArchetypeID, Archetypes m, Access m ()) +insert e aId cIds b arches = case lookup aId arches of + Just node -> + if Set.isSubsetOf cIds $ nodeComponentIds node + then + let go n = + let (arch', hook) = runDynamicBundle b e $ nodeArchetype n + in (n {nodeArchetype = arch'}, hook) + (hooks, nodes') = + Map.alterF + ( \maybeN -> case maybeN of + Just n -> let (n', hook) = go n in (hook, Just n') + Nothing -> (return (), Nothing) + ) + aId + $ nodes arches + in (Nothing, arches {nodes = nodes'}, hooks) + else + let cIds' = cIds <> nodeComponentIds node + in case lookupArchetypeId cIds' arches of + Just nextAId -> + let !(cs, arch) = A.remove e $ nodeArchetype node + node' = node {nodeArchetype = arch} + !nodes' = Map.insert aId node' $ nodes arches + adjustNode nextNode = + let nextArch = nodeArchetype nextNode + nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch} + !nextArch'' = A.insertComponents e cs nextArch' + (finalArch, hook) = runDynamicBundle b e nextArch'' + in (nextNode {nodeArchetype = finalArch}, hook) + (hooks, nodes'') = + Map.alterF + ( \maybeN -> case maybeN of + Just n -> let (n', hook) = adjustNode n in (hook, Just n') + Nothing -> (return (), Nothing) + ) + nextAId + nodes' + in (Just nextAId, arches {nodes = nodes''}, hooks) + Nothing -> + let !(s, arch) = A.removeStorages e $ nodeArchetype node + nodes' = Map.insert aId node {nodeArchetype = arch} $ nodes arches + (nextArch, hook) = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e} + !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch} + !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'} + in (Just nextAId, arches', hook) + Nothing -> (Nothing, arches, return ()) + +-- | Remove a component from an entity with its `ComponentID`. +remove :: + (Component m a) => + EntityID -> + ArchetypeID -> + ComponentID -> + Archetypes m -> + (Maybe (a, ArchetypeID), Archetypes m, Access m ()) +remove e aId cId arches = case lookup aId arches of + Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of + Just nextAId -> + let !(cs, arch') = A.remove e (nodeArchetype node) + !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)} + (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs + go' archAcc (itemCId, dyn) = + let adjustStorage s = fromAscVectorDyn (V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) . V.toList $ toAscVectorDyn s) s + in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)} + go nextNode = + nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')} + maybeA = a >>= fromDynamic + hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA + in ( (,nextAId) <$> maybeA, + arches' {nodes = Map.adjust go nextAId (nodes arches')}, + hook + ) + Nothing -> + let !(cs, arch') = A.removeStorages e (nodeArchetype node) + (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs + destCIds = Set.delete cId (nodeComponentIds node) + !n = + Node + { nodeComponentIds = destCIds, + nodeArchetype = Archetype {storages = cs', entities = Set.singleton e} + } + !(nextAId, arches') = insertArchetype destCIds n arches + node' = node {nodeArchetype = arch'} + maybeA = a >>= (\dynS -> V.headM (toAscVectorDyn dynS) >>= fromDynamic) + hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA + in ( (,nextAId) <$> maybeA, + arches' {nodes = Map.insert aId node' (nodes arches')}, + hook + ) + Nothing -> (Nothing, arches, return ()) diff --git a/src/Aztecs/ECS/World/Bundle/Dynamic.hs b/src/Aztecs/ECS/World/Bundle/Dynamic.hs --- a/src/Aztecs/ECS/World/Bundle/Dynamic.hs +++ b/src/Aztecs/ECS/World/Bundle/Dynamic.hs @@ -1,39 +1,39 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Aztecs.ECS.World.Bundle.Dynamic --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), MonoidDynamicBundle (..)) where - -import Aztecs.ECS.Access.Internal (Access) -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Archetype -import Aztecs.ECS.World.Bundle.Dynamic.Class - --- | Dynamic bundle of components. -newtype DynamicBundle m = DynamicBundle - { -- | Insert components into an archetype. - runDynamicBundle :: EntityID -> Archetype m -> (Archetype m, Access m ()) - } - -instance (Monad m) => Semigroup (DynamicBundle m) where - DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle go - where - go eId arch = - let (arch', hook1) = d1 eId arch - (arch'', hook2) = d2 eId arch' - in (arch'', hook1 >> hook2) - -instance (Monad m) => Monoid (DynamicBundle m) where - mempty = DynamicBundle (\_ arch -> (arch, return ())) - -instance (Monad m) => MonoidDynamicBundle m (DynamicBundle m) where - dynBundle cId a = DynamicBundle (\eId arch -> insertComponent eId cId a arch) - dynBundleUntracked cId a = DynamicBundle (\eId arch -> (insertComponentUntracked eId cId a arch, return ())) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Aztecs.ECS.World.Bundle.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), MonoidDynamicBundle (..)) where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Archetype +import Aztecs.ECS.World.Bundle.Dynamic.Class + +-- | Dynamic bundle of components. +newtype DynamicBundle m = DynamicBundle + { -- | Insert components into an archetype. + runDynamicBundle :: EntityID -> Archetype m -> (Archetype m, Access m ()) + } + +instance (Monad m) => Semigroup (DynamicBundle m) where + DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle go + where + go eId arch = + let (arch', hook1) = d1 eId arch + (arch'', hook2) = d2 eId arch' + in (arch'', hook1 >> hook2) + +instance (Monad m) => Monoid (DynamicBundle m) where + mempty = DynamicBundle (\_ arch -> (arch, return ())) + +instance (Monad m) => MonoidDynamicBundle m (DynamicBundle m) where + dynBundle cId a = DynamicBundle (\eId arch -> insertComponent eId cId a arch) + dynBundleUntracked cId a = DynamicBundle (\eId arch -> (insertComponentUntracked eId cId a arch, return ())) diff --git a/src/Aztecs/ECS/World/Entities.hs b/src/Aztecs/ECS/World/Entities.hs --- a/src/Aztecs/ECS/World/Entities.hs +++ b/src/Aztecs/ECS/World/Entities.hs @@ -1,187 +1,187 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World.Entities --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Entities - ( Entities (..), - empty, - spawn, - spawnWithArchetypeId, - insert, - insertDyn, - insertUntracked, - lookup, - remove, - removeWithId, - despawn, - ) -where - -import Aztecs.ECS.Access.Internal (Access) -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import qualified Aztecs.ECS.World.Archetype as A -import Aztecs.ECS.World.Archetypes (ArchetypeID, Node (..)) -import qualified Aztecs.ECS.World.Archetypes as AS -import Aztecs.ECS.World.Bundle -import Aztecs.ECS.World.Bundle.Dynamic -import qualified Aztecs.ECS.World.Components as CS -import Aztecs.ECS.World.Entities.Internal (Entities (..)) -import Data.Dynamic -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import Prelude hiding (lookup) - --- | Empty `World`. -empty :: Entities m -empty = - Entities - { archetypes = AS.empty, - components = CS.empty, - entities = mempty - } - --- | Spawn a `Bundle`. Returns the updated entities and the onInsert hook to run. -spawn :: (Monad m) => EntityID -> BundleT m -> Entities m -> (Entities m, Access m ()) -spawn eId b w = - let (cIds, components', dynB) = unBundle b (components w) - in case AS.lookupArchetypeId cIds (archetypes w) of - Just aId -> case AS.lookup aId $ archetypes w of - Just node -> - let (arch', hook) = - runDynamicBundle - dynB - eId - ( (nodeArchetype node) - { A.entities = Set.insert eId . A.entities $ nodeArchetype node - } - ) - in ( w - { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, - components = components', - entities = Map.insert eId aId (entities w) - }, - hook - ) - Nothing -> (w, return ()) - Nothing -> - let (arch', hook) = runDynamicBundle dynB eId $ A.singleton eId - node' = Node {nodeComponentIds = cIds, nodeArchetype = arch'} - (aId, arches) = AS.insertArchetype cIds node' $ archetypes w - in ( w - { archetypes = arches, - entities = Map.insert eId aId (entities w), - components = components' - }, - hook - ) - --- | Spawn a `DynamicBundle` with a specified `ArchetypeID`. Returns the updated entities and the onInsert hook. -spawnWithArchetypeId :: - (Monad m) => - EntityID -> - ArchetypeID -> - DynamicBundle m -> - Entities m -> - (Entities m, Access m ()) -spawnWithArchetypeId e aId b w = - let f n = - let (arch', hook) = runDynamicBundle b e ((nodeArchetype n) {A.entities = Set.insert e . A.entities $ nodeArchetype n}) - in (n {nodeArchetype = arch'}, hook) - (hooks, nodes') = - Map.alterF - ( \maybeN -> case maybeN of - Just n -> let (n', hook) = f n in (hook, Just n') - Nothing -> (return (), Nothing) - ) - aId - (AS.nodes $ archetypes w) - in ( w - { archetypes = (archetypes w) {AS.nodes = nodes'}, - entities = Map.insert e aId (entities w) - }, - hooks - ) - --- | Insert a component into an entity. Returns the updated entities and the onInsert hook. -insert :: (Monad m) => EntityID -> BundleT m -> Entities m -> (Entities m, Access m ()) -insert e b w = - let !(cIds, components', dynB) = unBundle b (components w) - in insertDyn e cIds dynB w {components = components'} - --- | Insert a component into an entity with its `ComponentID`. Returns the updated entities and the onInsert hook. -insertDyn :: (Monad m) => EntityID -> Set ComponentID -> DynamicBundle m -> Entities m -> (Entities m, Access m ()) -insertDyn e cIds b w = case Map.lookup e $ entities w of - Just aId -> - let (maybeNextAId, arches, hook) = AS.insert e aId cIds b $ archetypes w - es = case maybeNextAId of - Just nextAId -> Map.insert e nextAId $ entities w - Nothing -> entities w - in (w {archetypes = arches, entities = es}, hook) - Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of - Just aId -> spawnWithArchetypeId e aId b w - Nothing -> - let (arch, hook) = runDynamicBundle b e $ A.singleton e - node = Node {nodeComponentIds = cIds, nodeArchetype = arch} - (aId, arches) = AS.insertArchetype cIds node $ archetypes w - in (w {archetypes = arches, entities = Map.insert e aId (entities w)}, hook) - --- | Insert a component into an entity without running lifecycle hooks. -insertUntracked :: (Monad m) => EntityID -> BundleT m -> Entities m -> Entities m -insertUntracked e b w = fst $ insert e b w - --- | Lookup a component in an entity. -lookup :: forall m a. (Component m a) => EntityID -> Entities m -> Maybe a -lookup e w = do - !cId <- CS.lookup @a $ components w - !aId <- Map.lookup e $ entities w - !node <- AS.lookup aId $ archetypes w - A.lookupComponent e cId $ nodeArchetype node - --- | Remove a component from an entity. Returns the component (if found), updated entities, and the onRemove hook. -remove :: forall m a. (Component m a) => EntityID -> Entities m -> (Maybe a, Entities m, Access m ()) -remove e w = - let !(cId, components') = CS.insert @a @m (components w) - in removeWithId e cId w {components = components'} - --- | Remove a component from an entity with its `ComponentID`. Returns the component (if found), updated entities, and the onRemove hook. -removeWithId :: forall m a. (Component m a) => EntityID -> ComponentID -> Entities m -> (Maybe a, Entities m, Access m ()) -removeWithId e cId w = case Map.lookup e (entities w) of - Just aId -> - let (res, as, hook) = AS.remove @m @a e aId cId $ archetypes w - (maybeA, es) = case res of - Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w)) - Nothing -> (Nothing, entities w) - in (maybeA, w {archetypes = as, entities = es}, hook) - Nothing -> (Nothing, w, return ()) - --- | Despawn an entity, returning its components. -despawn :: EntityID -> Entities m -> (IntMap Dynamic, Entities m) -despawn e w = - let res = do - !aId <- Map.lookup e $ entities w - !node <- AS.lookup aId $ archetypes w - return (aId, node) - in case res of - Just (aId, node) -> - let !(dynAcc, arch') = A.remove e (nodeArchetype node) - in ( dynAcc, - w - { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, - entities = Map.delete e (entities w) - } - ) - Nothing -> (IntMap.empty, w) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Entities +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Entities + ( Entities (..), + empty, + spawn, + spawnWithArchetypeId, + insert, + insertDyn, + insertUntracked, + lookup, + remove, + removeWithId, + despawn, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Archetypes (ArchetypeID, Node (..)) +import qualified Aztecs.ECS.World.Archetypes as AS +import Aztecs.ECS.World.Bundle +import Aztecs.ECS.World.Bundle.Dynamic +import qualified Aztecs.ECS.World.Components as CS +import Aztecs.ECS.World.Entities.Internal (Entities (..)) +import Data.Dynamic +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (lookup) + +-- | Empty `World`. +empty :: Entities m +empty = + Entities + { archetypes = AS.empty, + components = CS.empty, + entities = mempty + } + +-- | Spawn a `Bundle`. Returns the updated entities and the onInsert hook to run. +spawn :: (Monad m) => EntityID -> BundleT m -> Entities m -> (Entities m, Access m ()) +spawn eId b w = + let (cIds, components', dynB) = unBundle b (components w) + in case AS.lookupArchetypeId cIds (archetypes w) of + Just aId -> case AS.lookup aId $ archetypes w of + Just node -> + let (arch', hook) = + runDynamicBundle + dynB + eId + ( (nodeArchetype node) + { A.entities = Set.insert eId . A.entities $ nodeArchetype node + } + ) + in ( w + { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, + components = components', + entities = Map.insert eId aId (entities w) + }, + hook + ) + Nothing -> (w, return ()) + Nothing -> + let (arch', hook) = runDynamicBundle dynB eId $ A.singleton eId + node' = Node {nodeComponentIds = cIds, nodeArchetype = arch'} + (aId, arches) = AS.insertArchetype cIds node' $ archetypes w + in ( w + { archetypes = arches, + entities = Map.insert eId aId (entities w), + components = components' + }, + hook + ) + +-- | Spawn a `DynamicBundle` with a specified `ArchetypeID`. Returns the updated entities and the onInsert hook. +spawnWithArchetypeId :: + (Monad m) => + EntityID -> + ArchetypeID -> + DynamicBundle m -> + Entities m -> + (Entities m, Access m ()) +spawnWithArchetypeId e aId b w = + let f n = + let (arch', hook) = runDynamicBundle b e ((nodeArchetype n) {A.entities = Set.insert e . A.entities $ nodeArchetype n}) + in (n {nodeArchetype = arch'}, hook) + (hooks, nodes') = + Map.alterF + ( \maybeN -> case maybeN of + Just n -> let (n', hook) = f n in (hook, Just n') + Nothing -> (return (), Nothing) + ) + aId + (AS.nodes $ archetypes w) + in ( w + { archetypes = (archetypes w) {AS.nodes = nodes'}, + entities = Map.insert e aId (entities w) + }, + hooks + ) + +-- | Insert a component into an entity. Returns the updated entities and the onInsert hook. +insert :: (Monad m) => EntityID -> BundleT m -> Entities m -> (Entities m, Access m ()) +insert e b w = + let !(cIds, components', dynB) = unBundle b (components w) + in insertDyn e cIds dynB w {components = components'} + +-- | Insert a component into an entity with its `ComponentID`. Returns the updated entities and the onInsert hook. +insertDyn :: (Monad m) => EntityID -> Set ComponentID -> DynamicBundle m -> Entities m -> (Entities m, Access m ()) +insertDyn e cIds b w = case Map.lookup e $ entities w of + Just aId -> + let (maybeNextAId, arches, hook) = AS.insert e aId cIds b $ archetypes w + es = case maybeNextAId of + Just nextAId -> Map.insert e nextAId $ entities w + Nothing -> entities w + in (w {archetypes = arches, entities = es}, hook) + Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of + Just aId -> spawnWithArchetypeId e aId b w + Nothing -> + let (arch, hook) = runDynamicBundle b e $ A.singleton e + node = Node {nodeComponentIds = cIds, nodeArchetype = arch} + (aId, arches) = AS.insertArchetype cIds node $ archetypes w + in (w {archetypes = arches, entities = Map.insert e aId (entities w)}, hook) + +-- | Insert a component into an entity without running lifecycle hooks. +insertUntracked :: (Monad m) => EntityID -> BundleT m -> Entities m -> Entities m +insertUntracked e b w = fst $ insert e b w + +-- | Lookup a component in an entity. +lookup :: forall m a. (Component m a) => EntityID -> Entities m -> Maybe a +lookup e w = do + !cId <- CS.lookup @a $ components w + !aId <- Map.lookup e $ entities w + !node <- AS.lookup aId $ archetypes w + A.lookupComponent e cId $ nodeArchetype node + +-- | Remove a component from an entity. Returns the component (if found), updated entities, and the onRemove hook. +remove :: forall m a. (Component m a) => EntityID -> Entities m -> (Maybe a, Entities m, Access m ()) +remove e w = + let !(cId, components') = CS.insert @a @m (components w) + in removeWithId e cId w {components = components'} + +-- | Remove a component from an entity with its `ComponentID`. Returns the component (if found), updated entities, and the onRemove hook. +removeWithId :: forall m a. (Component m a) => EntityID -> ComponentID -> Entities m -> (Maybe a, Entities m, Access m ()) +removeWithId e cId w = case Map.lookup e (entities w) of + Just aId -> + let (res, as, hook) = AS.remove @m @a e aId cId $ archetypes w + (maybeA, es) = case res of + Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w)) + Nothing -> (Nothing, entities w) + in (maybeA, w {archetypes = as, entities = es}, hook) + Nothing -> (Nothing, w, return ()) + +-- | Despawn an entity, returning its components. +despawn :: EntityID -> Entities m -> (IntMap Dynamic, Entities m) +despawn e w = + let res = do + !aId <- Map.lookup e $ entities w + !node <- AS.lookup aId $ archetypes w + return (aId, node) + in case res of + Just (aId, node) -> + let !(dynAcc, arch') = A.remove e (nodeArchetype node) + in ( dynAcc, + w + { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, + entities = Map.delete e (entities w) + } + ) + Nothing -> (IntMap.empty, w) diff --git a/src/Aztecs/ECS/World/Internal.hs b/src/Aztecs/ECS/World/Internal.hs --- a/src/Aztecs/ECS/World/Internal.hs +++ b/src/Aztecs/ECS/World/Internal.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE DeriveGeneric #-} - --- | --- Module : Aztecs.ECS.World.Internal --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Internal (World (..)) where - -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Entities.Internal -import Aztecs.ECS.World.Observers.Internal -import Control.Monad.State - --- | World of entities and their components. -data World m = World - { -- | Entities and their components. - entities :: !(Entities m), - -- | Next unique entity identifier. - nextEntityId :: !EntityID, - -- | Observers for events. - observers :: !(Observers (StateT (World m) m)) - } +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module : Aztecs.ECS.World.Internal +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Internal (World (..)) where + +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Entities.Internal +import Aztecs.ECS.World.Observers.Internal +import Control.Monad.State + +-- | World of entities and their components. +data World m = World + { -- | Entities and their components. + entities :: !(Entities m), + -- | Next unique entity identifier. + nextEntityId :: !EntityID, + -- | Observers for events. + observers :: !(Observers (StateT (World m) m)) + } diff --git a/src/Aztecs/ECS/World/Storage/Dynamic.hs b/src/Aztecs/ECS/World/Storage/Dynamic.hs --- a/src/Aztecs/ECS/World/Storage/Dynamic.hs +++ b/src/Aztecs/ECS/World/Storage/Dynamic.hs @@ -1,70 +1,70 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World.Storage.Dynamic --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Storage.Dynamic - ( DynamicStorage (..), - dynStorage, - singletonDyn, - fromAscVectorDyn, - toAscVectorDyn, - ) -where - -import qualified Aztecs.ECS.World.Storage as S -import Data.Dynamic -import Data.Maybe -import Data.Vector (Vector) -import qualified Data.Vector as V - --- | Dynamic storage of components. -data DynamicStorage = DynamicStorage - { -- | Dynamic storage. - storageDyn :: !Dynamic, - -- | Singleton storage. - singletonDyn' :: !(Dynamic -> Dynamic), - -- | Convert this storage to an ascending vector. - toAscVectorDyn' :: !(Dynamic -> Vector Dynamic), - -- | Convert from an ascending vector. - fromAscVectorDyn' :: !(Vector Dynamic -> Dynamic) - } - -instance Show DynamicStorage where - show s = "DynamicStorage " ++ show (storageDyn s) - --- | Create a dynamic storage from a storage. -dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage -dynStorage s = - DynamicStorage - { storageDyn = toDyn s, - singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic, - toAscVectorDyn' = \d -> V.map toDyn (S.toAscVector @a @s (fromMaybe (error "TODO") $ fromDynamic d)), - fromAscVectorDyn' = toDyn . S.fromAscVector @a @s . V.map (fromMaybe (error "TODO") . fromDynamic) - } -{-# INLINE dynStorage #-} - --- | Singleton dynamic storage. -singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage -singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} - --- | Convert from an ascending vector. -fromAscVectorDyn :: Vector Dynamic -> DynamicStorage -> DynamicStorage -fromAscVectorDyn dyns s = s {storageDyn = fromAscVectorDyn' s dyns} - --- | Convert this storage to an ascending vector. -toAscVectorDyn :: DynamicStorage -> Vector Dynamic -toAscVectorDyn = toAscVectorDyn' <*> storageDyn +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Storage.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Storage.Dynamic + ( DynamicStorage (..), + dynStorage, + singletonDyn, + fromAscVectorDyn, + toAscVectorDyn, + ) +where + +import qualified Aztecs.ECS.World.Storage as S +import Data.Dynamic +import Data.Maybe +import Data.Vector (Vector) +import qualified Data.Vector as V + +-- | Dynamic storage of components. +data DynamicStorage = DynamicStorage + { -- | Dynamic storage. + storageDyn :: !Dynamic, + -- | Singleton storage. + singletonDyn' :: !(Dynamic -> Dynamic), + -- | Convert this storage to an ascending vector. + toAscVectorDyn' :: !(Dynamic -> Vector Dynamic), + -- | Convert from an ascending vector. + fromAscVectorDyn' :: !(Vector Dynamic -> Dynamic) + } + +instance Show DynamicStorage where + show s = "DynamicStorage " ++ show (storageDyn s) + +-- | Create a dynamic storage from a storage. +dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage +dynStorage s = + DynamicStorage + { storageDyn = toDyn s, + singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic, + toAscVectorDyn' = \d -> V.map toDyn (S.toAscVector @a @s (fromMaybe (error "TODO") $ fromDynamic d)), + fromAscVectorDyn' = toDyn . S.fromAscVector @a @s . V.map (fromMaybe (error "TODO") . fromDynamic) + } +{-# INLINE dynStorage #-} + +-- | Singleton dynamic storage. +singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage +singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} + +-- | Convert from an ascending vector. +fromAscVectorDyn :: Vector Dynamic -> DynamicStorage -> DynamicStorage +fromAscVectorDyn dyns s = s {storageDyn = fromAscVectorDyn' s dyns} + +-- | Convert this storage to an ascending vector. +toAscVectorDyn :: DynamicStorage -> Vector Dynamic +toAscVectorDyn = toAscVectorDyn' <*> storageDyn diff --git a/src/Aztecs/Hierarchy.hs b/src/Aztecs/Hierarchy.hs --- a/src/Aztecs/Hierarchy.hs +++ b/src/Aztecs/Hierarchy.hs @@ -24,7 +24,6 @@ module Aztecs.Hierarchy ( Parent (..), Children (..), - update, Hierarchy (..), toList, foldWithKey, @@ -32,8 +31,6 @@ mapWithAccum, hierarchy, hierarchies, - ParentState (..), - ChildState (..), ) where @@ -41,7 +38,6 @@ import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S -import Control.Monad import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -58,80 +54,52 @@ } deriving (Eq, Ord, Show, Generic) -instance (Monad m) => Component m Parent +instance (Monad m) => Component m Parent where + componentOnInsert e (Parent parent) = do + -- Add this entity to the parent's children. + maybeChildren <- A.lookup parent + let parentChildren = maybe mempty unChildren maybeChildren + A.insertUntracked parent . bundle . Children $ Set.insert e parentChildren --- | Parent internal state component. -newtype ParentState = ParentState {unParentState :: EntityID} - deriving (Show, Generic) + componentOnChange e (Parent oldParent) (Parent newParent) = do + -- Remove this entity from the old parent's children. + maybeOldChildren <- A.lookup oldParent + let oldChildren = maybe mempty unChildren maybeOldChildren + let oldChildren' = Set.filter (/= e) oldChildren + A.insertUntracked oldParent . bundle . Children $ oldChildren' -instance (Monad m) => Component m ParentState + -- Add this entity to the new parent's children. + maybeNewChildren <- A.lookup newParent + let newChildren = maybe mempty unChildren maybeNewChildren + A.insertUntracked newParent . bundle . Children $ Set.insert e newChildren + componentOnRemove e (Parent parent) = do + -- Remove this entity from the parent's children. + maybeChildren <- A.lookup parent + let parentChildren = maybe mempty unChildren maybeChildren + let parentChildren' = Set.filter (/= e) parentChildren + A.insertUntracked parent . bundle . Children $ parentChildren' + -- | Children component. newtype Children = Children {unChildren :: Set EntityID} deriving (Eq, Ord, Show, Semigroup, Monoid, Generic) -instance (Monad m) => Component m Children - --- | Child internal state component. -newtype ChildState = ChildState {unChildState :: Set EntityID} - deriving (Show, Generic) - -instance (Monad m) => Component m ChildState - --- | Update the parent-child relationships. -update :: (Monad m) => Access m () -update = do - parents <- A.system . S.readQuery $ do - e <- Q.entity - parent <- Q.query - maybeParentState <- Q.queryMaybe @_ @ParentState - return (e, unParent parent, maybeParentState) - - children <- A.system . S.readQuery $ do - e <- Q.entity - cs <- Q.query - maybeChildState <- Q.queryMaybe @_ @ChildState - return (e, unChildren cs, maybeChildState) - - let go = do - mapM_ - ( \(e, parent, maybeParentState) -> case maybeParentState of - Just (ParentState parentState) -> do - when (parent /= parentState) $ do - A.insert parent . bundle $ ParentState parent +instance (Monad m) => Component m Children where + componentOnInsert e (Children cs) = do + -- Set parent on all children. + mapM_ (\child -> A.insertUntracked child . bundle $ Parent e) cs - -- Remove this entity from the previous parent's children. - maybeLastChildren <- A.lookup parentState - let lastChildren = maybe mempty unChildren maybeLastChildren - let lastChildren' = Set.filter (/= e) lastChildren - A.insert parentState . bundle . Children $ lastChildren' + componentOnChange e (Children oldCs) (Children newCs) = do + let added = Set.difference newCs oldCs + removed = Set.difference oldCs newCs + -- Set parent on added children. + mapM_ (\child -> A.insertUntracked child . bundle $ Parent e) added + -- Remove parent from removed children. + mapM_ (\child -> A.remove @_ @Parent child) removed - -- Add this entity to the new parent's children. - maybeChildren <- A.lookup parent - let parentChildren = maybe mempty unChildren maybeChildren - A.insert parent . bundle . Children $ Set.insert e parentChildren - Nothing -> do - A.spawn_ . bundle $ ParentState parent - maybeChildren <- A.lookup parent - let parentChildren = maybe mempty unChildren maybeChildren - A.insert parent . bundle . Children $ Set.insert e parentChildren - ) - parents - mapM_ - ( \(e, children', maybeChildState) -> case maybeChildState of - Just (ChildState childState) -> do - when (children' /= childState) $ do - A.insert e . bundle $ ChildState children' - let added = Set.difference children' childState - removed = Set.difference childState children' - mapM_ (\e' -> A.insert e' . bundle . Parent $ e') added - mapM_ (A.remove @_ @Parent) removed - Nothing -> do - A.insert e . bundle $ ChildState children' - mapM_ (\e' -> A.insert e' . bundle . Parent $ e') children' - ) - children - go + componentOnRemove _ (Children cs) = do + -- Remove parent from all children. + mapM_ (\child -> A.remove @_ @Parent child) cs -- | Hierarchy of entities. data Hierarchy a = Node