aztecs 0.15.0 → 0.16.0
raw patch · 49 files changed
+2675/−2561 lines, 49 filesdep −stmdep ~basedep ~mtldep ~vectornew-component:exe:lifecyclenew-component:exe:observers
Dependencies removed: stm
Dependency ranges changed: base, mtl, vector
Files
- aztecs.cabal +31/−13
- bench/Bench.hs +17/−10
- examples/ECS.hs +30/−32
- examples/Lifecycle.hs +30/−0
- examples/Observers.hs +40/−0
- src/Aztecs/ECS.hs +117/−100
- src/Aztecs/ECS/Access.hs +78/−143
- src/Aztecs/ECS/Access/Class.hs +0/−52
- src/Aztecs/ECS/Access/Internal.hs +76/−0
- src/Aztecs/ECS/Component.hs +46/−41
- src/Aztecs/ECS/Component/Internal.hs +21/−0
- src/Aztecs/ECS/Entity.hs +0/−4
- src/Aztecs/ECS/Event.hs +44/−0
- src/Aztecs/ECS/Observer.hs +102/−0
- src/Aztecs/ECS/Query.hs +384/−306
- src/Aztecs/ECS/Query/Class.hs +0/−41
- src/Aztecs/ECS/Query/Dynamic.hs +192/−102
- src/Aztecs/ECS/Query/Dynamic/Class.hs +44/−19
- src/Aztecs/ECS/Query/Dynamic/Reader.hs +0/−148
- src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs +0/−32
- src/Aztecs/ECS/Query/Reader.hs +0/−177
- src/Aztecs/ECS/Query/Reader/Class.hs +0/−26
- src/Aztecs/ECS/System.hs +117/−131
- src/Aztecs/ECS/System/Class.hs +0/−45
- src/Aztecs/ECS/System/Dynamic.hs +145/−0
- src/Aztecs/ECS/System/Dynamic/Class.hs +0/−44
- src/Aztecs/ECS/System/Dynamic/Reader/Class.hs +0/−52
- src/Aztecs/ECS/System/Reader/Class.hs +0/−51
- src/Aztecs/ECS/View.hs +29/−50
- src/Aztecs/ECS/World.hs +35/−50
- src/Aztecs/ECS/World/Archetype.hs +264/−262
- src/Aztecs/ECS/World/Archetype/Internal.hs +41/−0
- src/Aztecs/ECS/World/Archetypes.hs +59/−108
- src/Aztecs/ECS/World/Archetypes/Internal.hs +55/−0
- src/Aztecs/ECS/World/Bundle.hs +31/−28
- src/Aztecs/ECS/World/Bundle/Class.hs +0/−23
- src/Aztecs/ECS/World/Bundle/Dynamic.hs +21/−12
- src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs +9/−6
- src/Aztecs/ECS/World/Components.hs +4/−30
- src/Aztecs/ECS/World/Components/Internal.hs +25/−0
- src/Aztecs/ECS/World/Entities.hs +78/−96
- src/Aztecs/ECS/World/Entities/Internal.hs +28/−0
- src/Aztecs/ECS/World/Internal.hs +26/−0
- src/Aztecs/ECS/World/Observers.hs +126/−0
- src/Aztecs/ECS/World/Observers/Internal.hs +53/−0
- src/Aztecs/ECS/World/Storage.hs +18/−18
- src/Aztecs/ECS/World/Storage/Dynamic.hs +0/−19
- src/Aztecs/Hierarchy.hs +217/−256
- test/Main.hs +42/−34
aztecs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs -version: 0.15.0 +version: 0.16.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me @@ -28,32 +28,33 @@ Aztecs Aztecs.ECS Aztecs.ECS.Access - Aztecs.ECS.Access.Class + Aztecs.ECS.Access.Internal Aztecs.ECS.Component + Aztecs.ECS.Component.Internal Aztecs.ECS.Entity + Aztecs.ECS.Event + Aztecs.ECS.Observer Aztecs.ECS.Query - Aztecs.ECS.Query.Class Aztecs.ECS.Query.Dynamic Aztecs.ECS.Query.Dynamic.Class - Aztecs.ECS.Query.Dynamic.Reader - Aztecs.ECS.Query.Dynamic.Reader.Class - Aztecs.ECS.Query.Reader - Aztecs.ECS.Query.Reader.Class Aztecs.ECS.System - Aztecs.ECS.System.Class - Aztecs.ECS.System.Dynamic.Class - Aztecs.ECS.System.Dynamic.Reader.Class - Aztecs.ECS.System.Reader.Class + Aztecs.ECS.System.Dynamic Aztecs.ECS.View Aztecs.ECS.World Aztecs.ECS.World.Archetype + Aztecs.ECS.World.Archetype.Internal Aztecs.ECS.World.Archetypes + Aztecs.ECS.World.Archetypes.Internal Aztecs.ECS.World.Bundle - Aztecs.ECS.World.Bundle.Class Aztecs.ECS.World.Bundle.Dynamic Aztecs.ECS.World.Bundle.Dynamic.Class Aztecs.ECS.World.Components + Aztecs.ECS.World.Components.Internal Aztecs.ECS.World.Entities + Aztecs.ECS.World.Entities.Internal + Aztecs.ECS.World.Internal + Aztecs.ECS.World.Observers + Aztecs.ECS.World.Observers.Internal Aztecs.ECS.World.Storage Aztecs.ECS.World.Storage.Dynamic Aztecs.Hierarchy @@ -65,7 +66,6 @@ base >=4.2 && <5, containers >=0.6, mtl >=2, - stm >=2, vector >=0.12 executable ecs @@ -75,6 +75,24 @@ build-depends: base, aztecs + +executable lifecycle + main-is: examples/Lifecycle.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + aztecs + +executable observers + main-is: examples/Observers.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + aztecs, + mtl, + vector test-suite aztecs-test type: exitcode-stdio-1.0
bench/Bench.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} import Aztecs.ECS import qualified Aztecs.ECS.Query as Q@@ -8,27 +10,32 @@ import qualified Aztecs.ECS.World as W import Control.DeepSeq import Criterion.Main-import Data.Function-import Data.Functor.Identity+import Data.Functor.Identity (Identity (runIdentity)) import Data.Vector (Vector) import GHC.Generics newtype Position = Position Int deriving (Show, Generic, NFData) -instance Component Position+instance (Monad m) => Component m Position newtype Velocity = Velocity Int deriving (Show, Generic, NFData) -instance Component Velocity+instance (Monad m) => Component m Velocity -query :: Query Position-query = Q.fetch & Q.adjust (\(Velocity v) (Position p) -> Position $ p + v)+move :: (Monad m) => Query m Position+move = queryMapWith (\(Velocity v) (Position p) -> (Position $ p + v)) query -run :: Query Position -> World -> Vector Position-run q = fst . runIdentity . Q.map q . entities+run :: Query Identity Position -> World Identity -> Vector Position+run q = (\(a, _, _) -> a) . runIdentity . Q.runQuery q . entities +runSys :: Query Identity Position -> World Identity -> Vector Position+runSys q = fst . runIdentity . runAccess (system $ runQuery q)+ main :: IO () main = do- let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc+ let go wAcc = (\(_, w', _) -> w') $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc !w = foldr (const go) W.empty [0 :: Int .. 10000]- defaultMain [bench "iter" $ nf (run query) w]+ defaultMain+ [ bench "iter" $ nf (run move) w,+ bench "iterSystem" $ nf (runSys move) w+ ]
examples/ECS.hs view
@@ -1,32 +1,30 @@-module Main where - -import Aztecs.ECS -import qualified Aztecs.ECS.Access as A -import qualified Aztecs.ECS.Query as Q -import qualified Aztecs.ECS.System as S -import Control.Monad.IO.Class -import Data.Function ((&)) - -newtype Position = Position Int deriving (Show) - -instance Component Position - -newtype Velocity = Velocity Int deriving (Show) - -instance Component Velocity - -move :: QueryT IO Position -move = Q.fetch & Q.adjust (\(Velocity v) (Position p) -> Position $ p + v) - -run :: AccessT IO () -run = do - positions <- S.map move - liftIO $ print positions - -app :: AccessT IO () -app = do - A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1) - run - -main :: IO () -main = runAccessT_ app +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Aztecs.ECS+import Control.Monad.IO.Class++newtype Position = Position Int deriving (Show)++instance (Monad m) => Component m Position++newtype Velocity = Velocity Int deriving (Show)++instance (Monad m) => Component m Velocity++move :: (Monad m) => Query m Position+move = queryMapWith go query+ where+ go (Velocity v) (Position p) = Position $ p + v++app :: Access IO ()+app = do+ spawn_ $ bundle (Position 0) <> bundle (Velocity 1)+ positions <- system $ runQuery move+ liftIO $ print positions++main :: IO ()+main = runAccess_ app
+ examples/Lifecycle.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Aztecs.ECS +import Control.Monad.IO.Class + +newtype X = X Int deriving (Show) + +instance Component IO X where + componentOnInsert = exampleHook "insert" + componentOnChange = exampleHook "change" + componentOnRemove = exampleHook "remove" + +exampleHook :: String -> EntityID -> X -> Access IO () +exampleHook s e x = liftIO . putStrLn $ s ++ " " ++ show e ++ ": " ++ show x + +addTen :: Query IO X +addTen = queryMap (\(X n) -> X (n + 10)) + +app :: Access IO () +app = do + e <- spawn $ bundle (X 1) + _ <- system $ runQuery addTen + _ <- remove @IO @X e + return () + +main :: IO () +main = runAccess_ app
+ examples/Observers.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Aztecs.ECS +import Control.Monad.IO.Class + +newtype Health = Health Int + deriving (Show) + +instance Component IO Health + +heal :: Query IO Health +heal = queryMap (\(Health h) -> Health (h + 10)) + +run :: Access IO () +run = do + -- Spawn a player with health + player <- spawn . bundle $ Health 100 + + -- Spawn observers that react to lifecycle events on the player's Health component + _ <- spawn . bundle . observer @IO @(OnInsert Health) player $ \e (OnInsert h) -> + observe "insert" e h + _ <- spawn . bundle . observer @IO @(OnChange Health) player $ \e (OnChange h) -> + observe "change" e h + _ <- spawn . bundle . observer @IO @(OnRemove Health) player $ \e (OnRemove h) -> + observe "remove" e h + + -- Trigger events by inserting, changing, and removing the Health component + _ <- insert player . bundle $ Health 150 + _ <- system $ runQuery heal + _ <- remove @_ @Health player + + return () + where + observe s e h = liftIO . putStrLn $ s ++ " " ++ show e ++ ": " ++ show h + +main :: IO () +main = runAccess_ run
src/Aztecs/ECS.hs view
@@ -1,100 +1,117 @@--- | 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.------ The ECS architecture is composed of three main concepts:------ === Entities--- An entity is an object comprised of zero or more components.--- In Aztecs, entities are represented by their `EntityID`, a unique identifier.------ === Components--- A `Component` holds the data for a particular aspect of an entity.--- For example, a zombie entity might have a @Health@ and a @Transform@ component.------ > newtype Position = Position Int deriving (Show)--- > instance Component Position--- >--- > newtype Velocity = Velocity Int deriving (Show)--- > instance Component Velocity------ === Systems--- A `System` is a pipeline that processes entities and their components.--- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.------ Systems can access game state in two ways:------ ==== Access--- An `Access` can be queued for full access to the `World`, after a system is complete.--- `Access` allows for spawning, inserting, and removing components.------ > setup :: System () ()--- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)------ ==== Queries--- A `Query` can read and write matching components.------ > move :: System () ()--- > move =--- > S.map--- > ( proc () -> do--- > Velocity v <- Q.fetch -< ()--- > Position p <- Q.fetch -< ()--- > Q.set -< Position $ p + v--- > )--- > >>> S.run print------ Finally, systems can be run on a `World` to produce a result.------ > main :: IO ()--- > main = runSystem_ $ setup >>> S.forever move-module Aztecs.ECS- ( Access,- AccessT,- MonadAccess,- runAccessT,- runAccessT_,- Bundle,- MonoidBundle (..),- DynamicBundle,- MonoidDynamicBundle (..),- Component (..),- EntityID,- Query,- QueryT,- QueryReader,- QueryReaderF,- QueryF,- DynamicQueryReaderF,- DynamicQueryF,- QueryFilter,- with,- without,- System,- SystemT,- MonadReaderSystem,- MonadSystem,- World,- )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Component (Component (..))-import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.Query- ( DynamicQueryF,- DynamicQueryReaderF,- Query,- QueryF,- QueryFilter,- QueryReaderF,- QueryT,- with,- without,- )-import Aztecs.ECS.Query.Reader (QueryReader)-import Aztecs.ECS.System-import Aztecs.ECS.World (World)-import Aztecs.ECS.World.Bundle (Bundle, MonoidBundle (..))-import Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle, MonoidDynamicBundle (..))+-- | 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. +-- +-- The ECS architecture is composed of three main concepts: +-- +-- === Entities +-- An entity is an object comprised of zero or more components. +-- In Aztecs, entities are represented by their `EntityID`, a unique identifier. +-- +-- === Components +-- A `Component` holds the data for a particular aspect of an entity. +-- For example, a zombie entity might have a @Health@ and a @Transform@ component. +-- +-- > newtype Position = Position Int deriving (Show) +-- > instance Component Position +-- > +-- > newtype Velocity = Velocity Int deriving (Show) +-- > instance Component Velocity +-- +-- === Systems +-- A `System` is a pipeline that processes entities and their components. +-- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access. +-- +-- Systems can access game state in two ways: +-- +-- ==== Access +-- An `Access` can be queued for full access to the `World`, after a system is complete. +-- `Access` allows for spawning, inserting, and removing components. +-- +-- > setup :: System () () +-- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1) +-- +-- ==== Queries +-- A `Query` can read and write matching components. +-- +-- > move :: System () () +-- > move = +-- > S.map +-- > ( proc () -> do +-- > Velocity v <- Q.query -< () +-- > Position p <- Q.query -< () +-- > Q.set -< Position $ p + v +-- > ) +-- > >>> S.run print +-- +-- Finally, systems can be run on a `World` to produce a result. +-- +-- > main :: IO () +-- > main = runSystem_ $ setup >>> S.forever move +module Aztecs.ECS + ( module Aztecs.ECS.Access, + module Aztecs.ECS.System, + Bundle, + BundleT, + bundle, + DynamicBundle, + MonoidDynamicBundle (..), + Component (..), + EntityID, + Query, + query, + queryMaybe, + queryMap, + queryMapM, + queryMapWith, + queryMapWith_, + queryMapWithM, + DynamicQueryF, + QueryFilter, + with, + without, + World, + + -- * Events + Event, + OnInsert (..), + OnChange (..), + OnRemove (..), + + -- * Observers + Observer, + observer, + observerFor, + observerGlobal, + ) +where + +import Aztecs.ECS.Access +import Aztecs.ECS.Component (Component (..)) +import Aztecs.ECS.Entity (EntityID) +import Aztecs.ECS.Event (Event, OnChange (..), OnInsert (..), OnRemove (..)) +import Aztecs.ECS.Observer + ( Observer (..), + observer, + observerFor, + observerGlobal, + ) +import Aztecs.ECS.Query + ( DynamicQueryF, + Query, + QueryFilter, + query, + queryMap, + queryMapM, + queryMapWith, + queryMapWithM, + queryMapWith_, + queryMaybe, + with, + without, + ) +import Aztecs.ECS.System +import Aztecs.ECS.World (World) +import Aztecs.ECS.World.Bundle (Bundle, BundleT, bundle) +import Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle, MonoidDynamicBundle (..))
src/Aztecs/ECS/Access.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Aztecs.ECS.Access@@ -12,164 +16,95 @@ -- Stability : provisional -- Portability : non-portable (GHC extensions) module Aztecs.ECS.Access- ( Access,- AccessT (..),- MonadAccess (..),- runAccessT,- runAccessT_,+ ( Access (..),+ runAccess,+ runAccess_,+ spawn,+ spawn_,+ insert,+ insertUntracked,+ lookup,+ remove,+ despawn, system,+ triggerEvent,+ triggerEntityEvent, ) where -import Aztecs.ECS.Access.Class-import Aztecs.ECS.Query (QueryT (..))-import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Dynamic (DynamicQueryT)-import qualified Aztecs.ECS.Query.Dynamic as Q-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader)-import qualified Aztecs.ECS.Query.Dynamic.Reader as Q-import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System-import Aztecs.ECS.World (World (..))+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 qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (Node (..)) import Aztecs.ECS.World.Bundle import qualified Aztecs.ECS.World.Entities as E-import Control.Concurrent.STM-import Control.Monad.Fix-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State.Strict-import qualified Data.Foldable as F---- | @since 0.9-type Access = AccessT Identity---- | Access into the `World`.------ @since 0.9-newtype AccessT m a = AccessT {unAccessT :: StateT World m a}- deriving (Functor, Applicative, MonadFix, MonadIO)---- | @since 0.9-instance (Monad m) => Monad (AccessT m) where- a >>= f = AccessT $ do- !w <- get- (a', w') <- lift $ runAccessT a w- put w'- unAccessT $ f a'+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`.------ @since 0.9-runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World)-runAccessT a = runStateT $ unAccessT a+runAccess :: (Functor m) => Access m a -> World m -> m (a, World m)+runAccess a = runStateT $ unAccess a -- | Run an `Access` on an empty `World`.------ @since 0.9-runAccessT_ :: (Functor m) => AccessT m a -> m a-runAccessT_ a = fmap fst . runAccessT a $ W.empty+runAccess_ :: (Monad m) => Access m a -> m a+runAccess_ a = fmap fst . runAccess a $ W.empty --- | @since 0.9-instance (Monad m) => MonadAccess Bundle (AccessT m) where- spawn b = AccessT $ do- !w <- get- let !(e, w') = W.spawn b w- put w'- return e- insert e c = AccessT $ do- !w <- get- let !w' = W.insert e c w- put w'- lookup e = AccessT $ do- !w <- get- return $ W.lookup e w- remove e = AccessT $ do- !w <- get- let !(a, w') = W.remove e w- put w'- return a- despawn e = AccessT $ do- !w <- get- let !(_, w') = W.despawn e w- put w'+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 --- | @since 0.9-instance (Monad m) => MonadReaderSystem QueryReader (AccessT m) where- all q = AccessT $ do- w <- get- let (cIds, cs, dynQ) = runQueryReader q . E.components $ entities w- put w {entities = (entities w) {E.components = cs}}- unAccessT $ allDyn cIds dynQ- filter q f = AccessT $ do- w <- get- let (cIds, cs, dynQ) = runQueryReader q . E.components $ entities w- (dynF, cs') = runQueryFilter f cs- put w {entities = (entities w) {E.components = cs'}}- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- unAccessT $ filterDyn cIds dynQ f'+spawn_ :: (Monad m) => BundleT m -> Access m ()+spawn_ = void . spawn --- | @since 0.9-instance (Monad m) => MonadSystem (QueryT m) (AccessT m) where- map q = AccessT $ do- !w <- get- let (rws, cs, dynQ) = runQuery q . E.components $ entities w- put w {entities = (entities w) {E.components = cs}}- unAccessT $ mapDyn (Q.reads rws <> Q.writes rws) dynQ- mapSingleMaybe q = AccessT $ do- !w <- get- let (rws, cs, dynQ) = runQuery q . E.components $ entities w- put w {entities = (entities w) {E.components = cs}}- unAccessT $ mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ- filterMap q f = AccessT $ do- !w <- get- let (rws, cs, dynQ) = runQuery q . E.components $ entities w- (dynF, cs') = runQueryFilter f cs- put w {entities = (entities w) {E.components = cs'}}- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- unAccessT $ filterMapDyn (Q.reads rws <> Q.writes rws) f' dynQ+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 --- | @since 0.9-instance (Monad m) => MonadDynamicReaderSystem DynamicQueryReader (AccessT m) where- allDyn cIds q = AccessT $ do- !w <- get- return . Q.allDyn cIds q $ entities w- filterDyn cIds q f = AccessT $ do- !w <- get- return . Q.filterDyn cIds f q $ entities w+-- | 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' --- | @since 0.9-instance (Monad m) => MonadDynamicSystem (DynamicQueryT m) (AccessT m) where- mapDyn cIds q = AccessT $ do- !w <- get- (as, es) <- lift . Q.mapDyn cIds q $ entities w- put w {entities = es}- return as- mapSingleMaybeDyn cIds q = AccessT $ do- !w <- get- (res, es) <- lift . Q.mapSingleMaybeDyn cIds q $ entities w- put w {entities = es}- return res- filterMapDyn cIds f q = AccessT $ do- !w <- get- (as, es) <- lift . Q.filterMapDyn cIds f q $ entities w- put w {entities = es}- return as+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 --- | Run a `System`.------ @since 0.9-system :: System a -> AccessT IO a-system s = AccessT $ do+remove :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a)+remove e = Access $ do !w <- get- esVar <- lift . newTVarIO $ entities w- a <- lift . atomically $ runReaderT (runSystemT s) esVar- es <- lift $ readTVarIO esVar- put w {entities = es}+ 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 #-}
− src/Aztecs/ECS/Access/Class.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.Access.Class--- 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.Class (MonadAccess (..)) where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Bundle.Class---- | Monadic access to a `World`.------ @since 0.9-class (MonoidBundle b, Monad m) => MonadAccess b m | m -> b where- -- | Spawn an entity with a component.- --- -- @since 0.9- spawn :: b -> m EntityID-- -- | Spawn an entity with a component.- --- -- @since 0.9- spawn_ :: b -> m ()- spawn_ c = do- _ <- spawn c- return ()-- -- | Insert a component into an entity.- --- -- @since 0.9- insert :: EntityID -> b -> m ()-- -- | Lookup a component on an entity.- --- -- @since 0.9- lookup :: (Component a) => EntityID -> m (Maybe a)-- -- | Remove a component from an entity.- --- -- @since 0.9- remove :: (Component a) => EntityID -> m (Maybe a)-- -- | Despawn an entity.- --- -- @since 0.9- despawn :: EntityID -> m ()
+ src/Aztecs/ECS/Access/Internal.hs view
@@ -0,0 +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 ()
src/Aztecs/ECS/Component.hs view
@@ -1,41 +1,46 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.Component--- 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.Component where--import Aztecs.ECS.World.Storage-import Data.Typeable-import Data.Vector (Vector)-import GHC.Generics---- | Unique component identifier.------ @since 0.9-newtype ComponentID = ComponentID- { -- | Unique integer identifier.- --- -- @since 0.9- unComponentId :: Int- }- deriving (Eq, Ord, Show, Generic)---- | Component that can be stored in the `World`.------ @since 0.9-class (Typeable a, Storage a (StorageT a)) => Component a where- -- | `Storage` of this component.- --- -- @since 0.9- type StorageT a-- type StorageT a = Vector a+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Component +-- 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.Component + ( ComponentID (..), + Component (..), + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component.Internal (ComponentID (..)) +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Storage +import Data.Typeable +import Data.Vector (Vector) + +-- | Component that can be stored in the `World`. +class (Monad m, Typeable a, Storage a (StorageT a)) => Component m a where + -- | `Storage` of this component. + type StorageT a + + type StorageT a = Vector a + + -- | Lifecycle hook called when a component is inserted. + componentOnInsert :: EntityID -> a -> Access m () + componentOnInsert _ _ = pure () + {-# INLINEABLE componentOnInsert #-} + + -- | Lifecycle hook called when a component is changed. + componentOnChange :: EntityID -> a -> Access m () + componentOnChange _ _ = pure () + {-# INLINEABLE componentOnChange #-} + + -- | Lifecycle hook called when a component is removed. + componentOnRemove :: EntityID -> a -> Access m () + componentOnRemove _ _ = pure () + {-# INLINEABLE componentOnRemove #-}
+ src/Aztecs/ECS/Component/Internal.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module : Aztecs.ECS.Component.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.Component.Internal (ComponentID (..)) where++import GHC.Generics++-- | Unique component identifier.+newtype ComponentID = ComponentID+ { -- | Unique integer identifier.+ unComponentId :: Int+ }+ deriving (Eq, Ord, Show, Generic)
src/Aztecs/ECS/Entity.hs view
@@ -14,12 +14,8 @@ import GHC.Generics -- | Unique entity identifier.------ @since 0.9 newtype EntityID = EntityID { -- | Unique integer identifier.- --- -- @since 0.9 unEntityId :: Int } deriving (Eq, Ord, Show, Generic)
+ src/Aztecs/ECS/Event.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Event +-- 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.Event + ( Event, + OnInsert (..), + OnChange (..), + OnRemove (..), + ) +where + +import Data.Typeable +import GHC.Generics + +-- | An event in the ECS. +class (Typeable e) => Event e + +-- | Event triggered when a component is inserted. +newtype OnInsert a = OnInsert {unOnInsert :: a} + deriving (Show, Eq, Generic) + +instance (Typeable a) => Event (OnInsert a) + +-- | Event triggered when a component is changed. +newtype OnChange a = OnChange {unOnChange :: a} + deriving (Show, Eq, Generic) + +instance (Typeable a) => Event (OnChange a) + +-- | Event triggered when a component is removed. +newtype OnRemove a = OnRemove {unOnRemove :: a} + deriving (Show, Eq, Generic) + +instance (Typeable a) => Event (OnRemove a)
+ src/Aztecs/ECS/Observer.hs view
@@ -0,0 +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)
src/Aztecs/ECS/Query.hs view
@@ -1,306 +1,384 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.Query--- 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)------ Query for matching entities.------ === Do notation:--- > move :: (ArrowQuery arr) => arr () Position--- > move = proc () -> do--- > Velocity v <- Q.fetch -< ()--- > Position p <- Q.fetch -< ()--- > Q.set -< Position $ p + v------ === Arrow combinators:--- > move :: (ArrowQuery arr) => arr () Position--- > move = Q.fetch &&& Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set------ === Applicative combinators:--- > move :: (ArrowQuery arr) => arr () Position--- > move = (,) <$> Q.fetch <*> Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set-module Aztecs.ECS.Query- ( -- * Queries- Query,- QueryT (..),- QueryReaderF (..),- QueryF (..),- DynamicQueryReaderF (..),- DynamicQueryF (..),-- -- ** Running- all,- all',- single,- single',- singleMaybe,- singleMaybe',- map,- mapSingle,- mapSingleMaybe,-- -- ** Conversion- fromReader,- toReader,-- -- * Filters- QueryFilter (..),- with,- without,-- -- * Reads and writes- ReadsWrites (..),- disjoint,- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Class-import Aztecs.ECS.Query.Dynamic-import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReader (..), with, without)-import qualified Aztecs.ECS.Query.Reader as QR-import Aztecs.ECS.Query.Reader.Class-import Aztecs.ECS.World.Components (Components)-import qualified Aztecs.ECS.World.Components as CS-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Category-import Control.Monad.Identity-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Vector (Vector)-import GHC.Stack-import Prelude hiding (all, id, map, reads, (.))---- | @since 0.10-type Query = QueryT Identity---- | Query for matching entities.------ @since 0.10-newtype QueryT m a = Query- { -- | Run a query, producing a `DynamicQueryT`.- --- -- @since 0.10- runQuery :: Components -> (ReadsWrites, Components, DynamicQueryT m a)- }- deriving (Functor)---- | @since 0.10-instance (Monad m) => Applicative (QueryT m) where- pure a = Query (mempty,,pure a)- {-# INLINE pure #-}-- (Query f) <*> (Query g) = Query $ \cs ->- let !(cIdsG, cs', aQS) = g cs- !(cIdsF, cs'', bQS) = f cs'- in (cIdsG <> cIdsF, cs'', bQS <*> aQS)- {-# INLINE (<*>) #-}---- | @since 0.10-instance (Monad m) => QueryReaderF (QueryT m) where- fetch = fromReader fetch- {-# INLINE fetch #-}-- fetchMaybe = fromReader fetchMaybe- {-# INLINE fetchMaybe #-}---- | @since 0.10-instance (Monad m) => DynamicQueryReaderF (QueryT m) where- entity = fromReader entity- {-# INLINE entity #-}-- fetchDyn = fromReader . fetchDyn- {-# INLINE fetchDyn #-}-- fetchMaybeDyn = fromReader . fetchMaybeDyn- {-# INLINE fetchMaybeDyn #-}---- | @since 0.10-instance (Monad m) => DynamicQueryF m (QueryT m) where- adjustDyn f cId q = Query $ \cs ->- let !(rws, cs', dynQ) = runQuery q cs- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', adjustDyn f cId dynQ)- {-# INLINE adjustDyn #-}-- adjustDyn_ f cId q = Query $ \cs ->- let !(rws, cs', dynQ) = runQuery q cs- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', adjustDyn_ f cId dynQ)- {-# INLINE adjustDyn_ #-}-- adjustDynM f cId q = Query $ \cs ->- let !(rws, cs', dynQ) = runQuery q cs- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', adjustDynM f cId dynQ)- {-# INLINE adjustDynM #-}-- setDyn cId q = Query $ \cs ->- let !(rws, cs', dynQ) = runQuery q cs- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', setDyn cId dynQ)- {-# INLINE setDyn #-}---- | @since 0.9-instance (Monad m) => QueryF m (QueryT m) where- adjust :: forall a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m a- adjust f q = Query $ \cs ->- let !(cId, cs') = CS.insert @a cs- !(rws, cs'', dynQ) = runQuery q cs'- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', adjustDyn f cId dynQ)- {-# INLINE adjust #-}-- adjust_ :: forall a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m ()- adjust_ f q = Query $ \cs ->- let !(cId, cs') = CS.insert @a cs- !(rws, cs'', dynQ) = runQuery q cs'- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', adjustDyn_ f cId dynQ)- {-# INLINE adjust_ #-}-- adjustM :: forall a b. (Component a, Monad m) => (b -> a -> m a) -> QueryT m b -> QueryT m a- adjustM f q = Query $ \cs ->- let !(cId, cs') = CS.insert @a cs- !(rws, cs'', dynQ) = runQuery q cs'- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', adjustDynM f cId dynQ)- {-# INLINE adjustM #-}-- set :: forall a. (Component a) => QueryT m a -> QueryT m a- set q = Query $ \cs ->- let !(cId, cs') = CS.insert @a cs- !(rws, cs'', dynQ) = runQuery q cs'- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', setDyn cId dynQ)- {-# INLINE set #-}---- | Convert a `QueryReader` to a `Query`.------ @since 0.9-fromReader :: (Monad m) => QueryReader a -> QueryT m a-fromReader (QueryReader f) = Query $ \cs ->- let !(cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ)-{-# INLINE fromReader #-}---- | Convert a `Query` to a `QueryReader`.------ @since 0.10-toReader :: Query a -> QueryReader a-toReader (Query f) = QueryReader $ \cs ->- let !(rws, cs', dynQ) = f cs in (reads rws, cs', toDynReader dynQ)-{-# INLINE toReader #-}---- | Reads and writes of a `Query`.------ @since 0.9-data ReadsWrites = ReadsWrites- { -- | Component IDs being read.- --- -- @since 0.9- reads :: !(Set ComponentID),- -- | Component IDs being written.- --- -- @since 0.9- writes :: !(Set ComponentID)- }- deriving (Show)---- | @since 0.9-instance Semigroup ReadsWrites where- ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2)---- | @since 0.9-instance Monoid ReadsWrites where- mempty = ReadsWrites mempty mempty---- | `True` if the reads and writes of two `Query`s overlap.------ @since 0.9-disjoint :: ReadsWrites -> ReadsWrites -> Bool-disjoint a b =- Set.disjoint (reads a) (writes b)- || Set.disjoint (reads b) (writes a)- || Set.disjoint (writes b) (writes a)---- | Match all entities.------ @since 0.9-all :: Query a -> Entities -> (Vector a, Entities)-all = QR.all . toReader-{-# INLINE all #-}---- | Match all entities.------ @since 0.9-all' :: Query a -> Entities -> (Vector a, Components)-all' = QR.all' . toReader-{-# INLINE all' #-}---- | Match a single entity.------ @since 0.9-single :: (HasCallStack) => Query a -> Entities -> (a, Entities)-single = QR.single . toReader-{-# INLINE single #-}---- | Match a single entity.------ @since 0.9-single' :: (HasCallStack) => Query a -> Entities -> (a, Components)-single' = QR.single' . toReader-{-# INLINE single' #-}---- | Match a single entity, or `Nothing`.------ @since 0.9-singleMaybe :: Query a -> Entities -> (Maybe a, Entities)-singleMaybe = QR.singleMaybe . toReader-{-# INLINE singleMaybe #-}---- | Match a single entity, or `Nothing`.------ @since 0.9-singleMaybe' :: Query a -> Entities -> (Maybe a, Components)-singleMaybe' = QR.singleMaybe' . toReader-{-# INLINE singleMaybe' #-}---- | Map all matched entities.------ @since 0.9-map :: (Monad m) => QueryT m o -> Entities -> m (Vector o, Entities)-map q es = do- let !(rws, cs', dynQ) = runQuery q $ components es- !cIds = reads rws <> writes rws- (as, es') <- mapDyn cIds dynQ es- return (as, es' {components = cs'})-{-# INLINE map #-}---- | Map a single matched entity.------ @since 0.9-mapSingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities)-mapSingle q es = do- let !(rws, cs', dynQ) = runQuery q $ components es- !cIds = reads rws <> writes rws- (as, es') <- mapSingleDyn cIds dynQ es- return (as, es' {components = cs'})-{-# INLINE mapSingle #-}---- | Map a single matched entity, or `Nothing`.------ @since 0.9-mapSingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities)-mapSingleMaybe q es = do- let !(rws, cs', dynQ) = runQuery q $ components es- !cIds = reads rws <> writes rws- (as, es') <- mapSingleMaybeDyn cIds dynQ es- return (as, es' {components = cs'})-{-# INLINE mapSingleMaybe #-}+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Query +-- 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) +-- +-- Query for matching entities. +module Aztecs.ECS.Query + ( -- * Queries + Query (..), + DynamicQueryF (..), + + -- ** Operations + query, + queryMaybe, + queryMap, + queryMap_, + queryMapM, + queryMapWith, + queryMapWith_, + queryMapWithM, + queryMapWithAccum, + queryMapWithAccumM, + + -- ** Running + readQuery, + readQuery', + readQuerySingle, + readQuerySingle', + readQuerySingleMaybe, + readQuerySingleMaybe', + runQuery, + runQuerySingle, + runQuerySingleMaybe, + + -- * Filters + QueryFilter (..), + with, + without, + + -- * Reads and writes + ReadsWrites (..), + disjoint, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Query.Dynamic +import Aztecs.ECS.World.Components (Components) +import qualified Aztecs.ECS.World.Components as CS +import Aztecs.ECS.World.Entities (Entities (..)) +import qualified Aztecs.ECS.World.Entities as E +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import GHC.Stack +import Prelude hiding (reads) + +-- | Query for matching entities. +newtype Query m a = Query + { -- | Run a query, producing a `DynamicQuery`. + -- + -- @since 0.10 + runQuery' :: Components -> (ReadsWrites, Components, DynamicQuery m a) + } + deriving (Functor) + +instance (Monad m) => Applicative (Query m) where + pure a = Query (mempty,,pure a) + {-# INLINE pure #-} + + (Query f) <*> (Query g) = Query $ \cs -> + let !(cIdsG, cs', aQS) = g cs + !(cIdsF, cs'', bQS) = f cs' + in (cIdsG <> cIdsF, cs'', bQS <*> aQS) + {-# INLINE (<*>) #-} + +instance (Monad m) => DynamicQueryF m (Query m) where + entity = Query (mempty,,entity) + {-# INLINE entity #-} + + queryDyn = dynQueryReader queryDyn + {-# INLINE queryDyn #-} + + queryMaybeDyn = dynQueryReader queryMaybeDyn + {-# INLINE queryMaybeDyn #-} + + queryMapDyn f = dynQueryWriter' $ queryMapDyn f + {-# INLINE queryMapDyn #-} + + queryMapDyn_ f = dynQueryWriter' $ queryMapDyn_ f + {-# INLINE queryMapDyn_ #-} + + queryMapDynM f = dynQueryWriter' $ queryMapDynM f + {-# INLINE queryMapDynM #-} + + queryMapDynWith f = dynQueryWriter $ queryMapDynWith f + {-# INLINE queryMapDynWith #-} + + queryMapDynWith_ f = dynQueryWriter $ queryMapDynWith_ f + {-# INLINE queryMapDynWith_ #-} + + queryMapDynWithM f = dynQueryWriter $ queryMapDynWithM f + {-# INLINE queryMapDynWithM #-} + + queryMapDynWithAccum f = dynQueryWriter $ queryMapDynWithAccum f + {-# INLINE queryMapDynWithAccum #-} + + queryUntracked (Query q) = Query $ \cs -> + let !(rws, cs', dynQ) = q cs + in (rws, cs', queryUntracked dynQ) + {-# INLINE queryUntracked #-} + + queryMapDynWithAccumM f = dynQueryWriter $ queryMapDynWithAccumM f + {-# INLINE queryMapDynWithAccumM #-} + + queryFilterMap p (Query q) = Query $ \cs -> + let !(rws, cs', dynQ) = q cs + in (rws, cs', queryFilterMap p dynQ) + {-# INLINE queryFilterMap #-} + +-- | Query a component. +query :: forall m a. (Monad m, Component m a) => Query m a +query = queryReader @m @a queryDyn +{-# INLINE query #-} + +-- | Optionally query a component, returning @Nothing@ if it does not exist. +queryMaybe :: forall m a. (Monad m, Component m a) => Query m (Maybe a) +queryMaybe = queryReader @m @a queryMaybeDyn +{-# INLINE queryMaybe #-} + +-- | Query a component and update it. +queryMap :: forall m a. (Monad m, Component m a) => (a -> a) -> Query m a +queryMap f = queryWriter' @m @a $ queryMapDyn f +{-# INLINE queryMap #-} + +-- | Query a component and update it, ignoring any output. +queryMap_ :: forall m a. (Monad m, Component m a) => (a -> a) -> Query m () +queryMap_ f = queryWriter' @m @a $ queryMapDyn_ f +{-# INLINE queryMap_ #-} + +-- | Query a component and update it with a monadic action. +queryMapM :: forall m a. (Monad m, Component m a) => (a -> m a) -> Query m a +queryMapM f = queryWriter' @m @a $ queryMapDynM f +{-# INLINE queryMapM #-} + +-- | Query a component with input and update it. +queryMapWith :: forall m a b. (Monad m, Component m b) => (a -> b -> b) -> Query m a -> Query m b +queryMapWith f = queryWriter @m @b $ queryMapDynWith f +{-# INLINE queryMapWith #-} + +-- | Query a component with input and update it, ignoring any output. +queryMapWith_ :: forall m a b. (Monad m, Component m b) => (a -> b -> b) -> Query m a -> Query m () +queryMapWith_ f = queryWriter @m @b $ queryMapDynWith_ f +{-# INLINE queryMapWith_ #-} + +-- | Query a component with input and update it with a monadic action. +queryMapWithM :: + forall m a b. + (Monad m, Component m b) => + (a -> b -> m b) -> + Query m a -> + Query m b +queryMapWithM f = queryWriter @m @b $ queryMapDynWithM f +{-# INLINE queryMapWithM #-} + +-- | Query a component with input, returning a tuple of the result and the updated component. +queryMapWithAccum :: + forall m a b c. + (Monad m, Component m c) => + (b -> c -> (a, c)) -> + Query m b -> + Query m (a, c) +queryMapWithAccum f = queryWriter @m @c $ queryMapDynWithAccum f +{-# INLINE queryMapWithAccum #-} + +-- | Query a component with input and update it with a monadic action, returning a tuple. +queryMapWithAccumM :: + forall m a b c. + (Monad m, Component m c) => + (b -> c -> m (a, c)) -> + Query m b -> + Query m (a, c) +queryMapWithAccumM f = queryWriter @m @c $ queryMapDynWithAccumM f +{-# INLINE queryMapWithAccumM #-} + +dynQueryReader :: (ComponentID -> DynamicQuery m a) -> ComponentID -> Query m a +dynQueryReader f cId = Query (ReadsWrites {reads = Set.singleton cId, writes = Set.empty},,f cId) +{-# INLINE dynQueryReader #-} + +dynQueryWriter :: + ( ComponentID -> + DynamicQuery m a -> + DynamicQuery m b + ) -> + ComponentID -> + Query m a -> + Query m b +dynQueryWriter f cId q = Query $ \cs -> + let !(rws, cs', dynQ) = runQuery' q cs + in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', f cId dynQ) +{-# INLINE dynQueryWriter #-} + +dynQueryWriter' :: (ComponentID -> DynamicQuery m a) -> ComponentID -> Query m a +dynQueryWriter' f cId = Query (ReadsWrites {reads = Set.empty, writes = Set.singleton cId},,f cId) +{-# INLINE dynQueryWriter' #-} + +queryReader :: forall m a b. (Component m a) => (ComponentID -> DynamicQuery m b) -> Query m b +queryReader f = Query $ \cs -> + let !(cId, cs') = CS.insert @a @m cs + in (ReadsWrites {reads = Set.singleton cId, writes = Set.empty}, cs', f cId) +{-# INLINE queryReader #-} + +queryWriter :: + forall m a b c. + (Component m a) => + ( ComponentID -> + DynamicQuery m b -> + DynamicQuery m c + ) -> + Query m b -> + Query m c +queryWriter f (Query g) = Query $ \cs -> + let !(rws, cs', dynQ) = g cs + !(cId, cs'') = CS.insert @a @m cs' + in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', f cId dynQ) +{-# INLINE queryWriter #-} + +queryWriter' :: forall m a b. (Component m a) => (ComponentID -> DynamicQuery m b) -> Query m b +queryWriter' f = Query $ \cs -> + let !(cId, cs') = CS.insert @a @m cs + in (ReadsWrites {reads = Set.empty, writes = Set.singleton cId}, cs', f cId) +{-# INLINE queryWriter' #-} + +-- | Reads and writes of a `Query`. +data ReadsWrites = ReadsWrites + { -- | Component IDs being read. + reads :: !(Set ComponentID), + -- | Component IDs being written. + writes :: !(Set ComponentID) + } + deriving (Show) + +instance Semigroup ReadsWrites where + ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2) + {-# INLINE (<>) #-} + +instance Monoid ReadsWrites where + mempty = ReadsWrites mempty mempty + {-# INLINE mempty #-} + +-- | `True` if the reads and writes of two `Query`s overlap. +disjoint :: ReadsWrites -> ReadsWrites -> Bool +disjoint a b = + Set.disjoint (reads a) (writes b) + || Set.disjoint (reads b) (writes a) + || Set.disjoint (writes b) (writes a) + +-- | Match all entities. +readQuery :: (Monad m) => Query m a -> Entities m -> m (Vector a, Entities m) +readQuery q es = do + (as, cs) <- readQuery' q es + return (as, es {E.components = cs}) +{-# INLINE readQuery #-} + +-- | Match all entities. +readQuery' :: (Monad m) => Query m a -> Entities m -> m (Vector a, Components) +readQuery' q es = do + let !(rws, cs', dynQ) = runQuery' q (E.components es) + !cIds = reads rws <> writes rws + as <- readQueryDyn cIds dynQ es + return (as, cs') +{-# INLINE readQuery' #-} + +-- | Match a single entity. +readQuerySingle :: (HasCallStack, Monad m) => Query m a -> Entities m -> m (a, Entities m) +readQuerySingle q es = do + (a, cs) <- readQuerySingle' q es + return (a, es {E.components = cs}) +{-# INLINE readQuerySingle #-} + +-- | Match a single entity. +readQuerySingle' :: (HasCallStack, Monad m) => Query m a -> Entities m -> m (a, Components) +readQuerySingle' q es = do + let !(rws, cs', dynQ) = runQuery' q (E.components es) + !cIds = reads rws <> writes rws + a <- readQuerySingleDyn cIds dynQ es + return (a, cs') +{-# INLINE readQuerySingle' #-} + +-- | Match a single entity. +readQuerySingleMaybe :: (Monad m) => Query m a -> Entities m -> m (Maybe a, Entities m) +readQuerySingleMaybe q es = do + (a, cs) <- readQuerySingleMaybe' q es + return (a, es {E.components = cs}) +{-# INLINE readQuerySingleMaybe #-} + +-- | Match a single entity. +readQuerySingleMaybe' :: (Monad m) => Query m a -> Entities m -> m (Maybe a, Components) +readQuerySingleMaybe' q es = do + let !(rws, cs', dynQ) = runQuery' q (E.components es) + !cIds = reads rws <> writes rws + a <- readQuerySingleMaybeDyn cIds dynQ es + return (a, cs') +{-# INLINE readQuerySingleMaybe' #-} + +-- | Map all matched entities. +runQuery :: (Monad m) => Query m o -> Entities m -> m (Vector o, Entities m, Access m ()) +runQuery q es = do + let !(rws, cs', dynQ) = runQuery' q $ components es + !cIds = reads rws <> writes rws + (as, es', hook) <- runQueryDyn cIds dynQ es + return (as, es' {components = cs'}, hook) +{-# INLINE runQuery #-} + +-- | Map a single matched entity. +runQuerySingle :: + (HasCallStack, Monad m) => + Query m a -> + Entities m -> + m (a, Entities m, Access m ()) +runQuerySingle q es = do + let !(rws, cs', dynQ) = runQuery' q $ components es + !cIds = reads rws <> writes rws + (as, es', hook) <- runQuerySingleDyn cIds dynQ es + return (as, es' {components = cs'}, hook) +{-# INLINE runQuerySingle #-} + +-- | Map a single matched entity, or `Nothing`. +runQuerySingleMaybe :: + (Monad m) => + Query m a -> + Entities m -> + m (Maybe a, Entities m, Access m ()) +runQuerySingleMaybe q es = do + let !(rws, cs', dynQ) = runQuery' q $ components es + !cIds = reads rws <> writes rws + (as, es', hook) <- runQuerySingleMaybeDyn cIds dynQ es + return (as, es' {components = cs'}, hook) +{-# INLINE runQuerySingleMaybe #-} + +-- | Filter for a `Query`. +newtype QueryFilter = QueryFilter + { -- | Run a query filter. + runQueryFilter :: Components -> (DynamicQueryFilter, Components) + } + +instance Semigroup QueryFilter where + a <> b = + QueryFilter + ( \cs -> + let !(withA', cs') = runQueryFilter a cs + !(withB', cs'') = runQueryFilter b cs' + in (withA' <> withB', cs'') + ) + +instance Monoid QueryFilter where + mempty = QueryFilter (mempty,) + +-- | Filter for entities containing this component. +with :: forall m a. (Component m a) => QueryFilter +with = QueryFilter $ \cs -> + let !(cId, cs') = CS.insert @a @m cs in (mempty {filterWith = Set.singleton cId}, cs') + +-- | Filter out entities containing this component. +without :: forall m a. (Component m a) => QueryFilter +without = QueryFilter $ \cs -> + let !(cId, cs') = CS.insert @a @m cs in (mempty {filterWithout = Set.singleton cId}, cs')
− src/Aztecs/ECS/Query/Class.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module : Aztecs.ECS.Query.Reader.Class--- 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.Class (QueryF (..)) where--import Aztecs.ECS.Component-import Control.Monad---- | Query functor.------ @since 0.10-class (Applicative g, Functor f) => QueryF g f | f -> g where- -- | Adjust a `Component` by its type.- --- -- @since 0.10- adjust :: (Component a) => (b -> a -> a) -> f b -> f a-- -- | Adjust a `Component` by its type, ignoring any output.- --- -- @since 0.10- adjust_ :: (Component a) => (b -> a -> a) -> f b -> f ()- adjust_ f = void . adjust f-- -- | Adjust a `Component` by its type with some `Monad` @m@.- --- -- @since 0.10- adjustM :: (Component a) => (b -> a -> g a) -> f b -> f a-- -- | Set a `Component` by its type.- --- -- @since 0.10- set :: (Component a) => f a -> f a
src/Aztecs/ECS/Query/Dynamic.hs view
@@ -15,36 +15,35 @@ -- Portability : non-portable (GHC extensions) module Aztecs.ECS.Query.Dynamic ( -- * Dynamic queries- DynamicQuery,- DynamicQueryT (..),- DynamicQueryReaderF (..),+ DynamicQuery (..), DynamicQueryF (..), - -- ** Conversion- fromDynReader,- toDynReader,- -- ** Running- mapDyn,- filterMapDyn,- mapSingleDyn,- mapSingleMaybeDyn,+ 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.Query.Dynamic.Reader 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 Control.Monad.Identity+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@@ -52,147 +51,238 @@ import qualified Data.Vector as V import GHC.Stack -type DynamicQuery = DynamicQueryT Identity- -- | Dynamic query for components by ID.------ @since 0.10-newtype DynamicQueryT f a+newtype DynamicQuery m a = DynamicQuery { -- | Run a dynamic query. -- -- @since 0.10- runDynQuery :: Archetype -> f (Vector a, Archetype)+ runDynQuery :: Archetype m -> m (Vector a, Archetype m, Access m ()) } deriving (Functor) --- | @since 0.10-instance (Applicative f) => Applicative (DynamicQueryT f) where- pure a = DynamicQuery $ \arch -> pure (V.replicate (length $ A.entities arch) a, arch)+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') = x- (bs, arch'') = y- in (V.zipWith ($) bs as, arch' <> arch'')+ let (as, arch', hook1) = x+ (bs, arch'', hook2) = y+ in (V.zipWith ($) bs as, arch' <> arch'', hook1 >> hook2) {-# INLINE (<*>) #-} --- | @since 0.10-instance DynamicQueryReaderF DynamicQuery where- entity = fromDynReader entity+instance (Monad m) => DynamicQueryF m (DynamicQuery m) where+ entity = DynamicQuery $ \arch -> pure (V.fromList . Set.toList $ A.entities arch, arch, return ()) {-# INLINE entity #-} - fetchDyn = fromDynReader . fetchDyn- {-# INLINE fetchDyn #-}+ queryDyn cId = DynamicQuery $ \arch -> pure (A.lookupComponentsAsc cId arch, arch, return ())+ {-# INLINE queryDyn #-} - fetchMaybeDyn = fromDynReader . fetchMaybeDyn- {-# INLINE fetchMaybeDyn #-}+ 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 #-} --- | @since 0.10-instance (Monad f) => DynamicQueryF f (DynamicQueryT f) where- adjustDyn f cId q =- DynamicQuery (fmap (\(bs, arch') -> A.zipWith bs f cId arch') . runDynQuery q)- {-# INLINE adjustDyn #-}+ 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 #-} - adjustDyn_ f cId q = DynamicQuery $ \arch ->- fmap (\(bs, arch') -> (V.map (const ()) bs, A.zipWith_ bs f cId arch')) (runDynQuery q arch)- {-# INLINE adjustDyn_ #-}+ 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_ #-} - adjustDynM f cId q = DynamicQuery $ \arch -> do- (bs, arch') <- runDynQuery q arch- A.zipWithM bs f cId arch'- {-# INLINE adjustDynM #-}+ 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 #-} - setDyn cId q =- DynamicQuery (fmap (\(bs, arch') -> (bs, A.insertAscVector cId bs arch')) . runDynQuery q)- {-# INLINE setDyn #-}+ 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 #-} --- | Convert a `DynamicQueryReaderT` to a `DynamicQueryT`.------ @since 0.10-fromDynReader :: (Monad m) => DynamicQueryReader a -> DynamicQueryT m a-fromDynReader q = DynamicQuery $ \arch -> do- let !os = runDynQueryReader q arch- return (os, arch)-{-# INLINE fromDynReader #-}+ 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_ #-} --- | Convert a `DynamicQueryT` to a `DynamicQueryReaderT`.------ @since 0.10-toDynReader :: DynamicQuery a -> DynamicQueryReader a-toDynReader q = DynamicQueryReader $ \arch -> fst $ runIdentity $ runDynQuery q arch-{-# INLINE toDynReader #-}+ 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.------ @since 0.10-mapDyn :: (Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (Vector a, Entities)-mapDyn cIds q es =+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, _) <- go A.empty {A.entities = Map.keysSet $ entities es}- return (as, es)+ (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es}+ return (as, es, hook) else- let go' (acc, esAcc) (aId, n) = do- (as', arch') <- go $ nodeArchetype n+ 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}})- in foldlM go' (V.empty, es) $ Map.toList . AS.find cIds $ archetypes es-{-# INLINE mapDyn #-}+ 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.------ @since 0.10-filterMapDyn :: (Monad m) => Set ComponentID -> (Node -> Bool) -> DynamicQueryT m a -> Entities -> m (Vector a, Entities)-filterMapDyn cIds f q es =+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, _) <- go A.empty {A.entities = Map.keysSet $ entities es}- return (as, es)+ (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es}+ return (as, es, hook) else- let go' (acc, esAcc) (aId, n) = do- (as', arch') <- go $ nodeArchetype n+ 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}})- in foldlM go' (V.empty, es) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es-{-# INLINE filterMapDyn #-}+ 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.------ @since 0.10-mapSingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (a, Entities)-mapSingleDyn cIds q es = do- res <- mapSingleMaybeDyn cIds q es+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') -> (a, es')- _ -> error "mapSingleDyn: expected single matching entity"+ (Just a, es', hook) -> (a, es', hook)+ _ -> error "querySingleDyn: expected single matching entity" -- | Map a single matched entity, or @Nothing@.------ @since 0.10-mapSingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (Maybe a, Entities)-mapSingleMaybeDyn cIds q es =+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, _) | V.length v == 1 -> (Just (V.head v), es)- _ -> (Nothing, es)- _ -> pure (Nothing, es)+ (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')+ (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}})- _ -> (Nothing, es)- _ -> pure (Nothing, es)-{-# INLINE mapSingleMaybeDyn #-}+ 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 #-}
src/Aztecs/ECS/Query/Dynamic/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} -- |@@ -11,29 +12,53 @@ module Aztecs.ECS.Query.Dynamic.Class (DynamicQueryF (..)) where import Aztecs.ECS.Component+import Aztecs.ECS.Entity import Control.Monad -- | Dynamic query functor.------ @since 0.10 class (Monad m, Functor f) => DynamicQueryF m f | f -> m where- -- | Adjust a `Component` by its `ComponentID`.- --- -- @since 0.10- adjustDyn :: (Component a) => (b -> a -> a) -> ComponentID -> f b -> f a+ -- | Fetch the currently matched `EntityID`.+ entity :: f EntityID - -- | Adjust a `Component` by its `ComponentID`, ignoring any output.- --- -- @since 0.10- adjustDyn_ :: (Component a) => (b -> a -> a) -> ComponentID -> f b -> f ()- adjustDyn_ f cId = void . adjustDyn f cId+ -- | Fetch a `Component` by its `ComponentID`.+ queryDyn :: (Component m a) => ComponentID -> f a - -- | Adjust a `Component` by its `ComponentID` with some applicative functor @g@.- --- -- @since 0.10- adjustDynM :: (Monad m, Component a) => (b -> a -> m a) -> ComponentID -> f b -> f a+ -- | Try to query a `Component` by its `ComponentID`.+ queryMaybeDyn :: (Component m a) => ComponentID -> f (Maybe a)+ queryMaybeDyn cId = Just <$> queryDyn cId - -- | Set a `Component` by its `ComponentID`.- --- -- @since 0.10- setDyn :: (Component a) => ComponentID -> f a -> f a+ -- | Map over a `Component` by its `ComponentID`.+ queryMapDyn :: (Component m a) => (a -> a) -> ComponentID -> f a++ -- | Map over a `Component` by its `ComponentID`, ignoring any output.+ queryMapDyn_ :: (Component m a) => (a -> a) -> ComponentID -> f ()+ queryMapDyn_ f cId = void $ queryMapDyn f cId++ -- | Map over a `Component` by its `ComponentID` with a monadic function.+ queryMapDynM :: (Monad m, Component m a) => (a -> m a) -> ComponentID -> f a++ -- | Map over a `Component` by its `ComponentID` with input.+ queryMapDynWith :: (Component m b) => (a -> b -> b) -> ComponentID -> f a -> f b++ -- | Map over a `Component` by its `ComponentID` with input, ignoring any output.+ queryMapDynWith_ :: (Component m b) => (a -> b -> b) -> ComponentID -> f a -> f ()+ queryMapDynWith_ f cId = void . queryMapDynWith f cId++ -- | Map over a `Component` by its `ComponentID` with input and a monadic function.+ queryMapDynWithM :: (Monad m, Component m b) => (a -> b -> m b) -> ComponentID -> f a -> f b++ -- | Map over a `Component` by its `ComponentID` with input, returning a tuple of the result and the updated component.+ queryMapDynWithAccum :: (Component m c) => (b -> c -> (a, c)) -> ComponentID -> f b -> f (a, c)++ -- | Map over a `Component` by its `ComponentID` with input and a monadic function, returning a tuple.+ queryMapDynWithAccumM :: (Monad m, Component m c) => (b -> c -> m (a, c)) -> ComponentID -> f b -> f (a, c)++ -- | Filter a query and map the results, constraining the query to entities that satisfy the predicate.+ queryFilterMap :: (a -> Maybe b) -> f a -> f b++ -- | Filter a query, constraining it to entities that satisfy the predicate.+ queryFilter :: (a -> Bool) -> f a -> f a+ queryFilter p fa = queryFilterMap (\a -> if p a then Just a else Nothing) fa++ -- | Run a query without tracking changes.+ queryUntracked :: f a -> f a
− src/Aztecs/ECS/Query/Dynamic/Reader.hs
@@ -1,148 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- |--- Module : Aztecs.ECS.Query.Dynamic.Reader--- 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.Reader- ( -- * Dynamic queries- DynamicQueryReader (..),- DynamicQueryReaderF (..),-- -- ** Running- allDyn,- filterDyn,- singleDyn,- singleMaybeDyn,-- -- * Dynamic query filters- DynamicQueryFilter (..),- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic.Reader.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 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 reader.------ @since 0.10-newtype DynamicQueryReader a = DynamicQueryReader- { -- | Run a dynamic query reader.- --- -- @since 0.10- runDynQueryReader :: Archetype -> Vector a- }- deriving (Functor)---- | @since 0.10-instance Applicative DynamicQueryReader where- pure a = DynamicQueryReader $ \arch -> V.replicate (length $ A.entities arch) a- {-# INLINE pure #-}-- f <*> g = DynamicQueryReader $ \arch ->- V.zipWith ($) (runDynQueryReader f arch) $ runDynQueryReader g arch- {-# INLINE (<*>) #-}---- | @since 0.10-instance DynamicQueryReaderF DynamicQueryReader where- entity = DynamicQueryReader $ \arch -> V.fromList . Set.toList $ A.entities arch- {-# INLINE entity #-}-- fetchDyn cId = DynamicQueryReader $ \arch -> A.lookupComponentsAsc cId arch- {-# INLINE fetchDyn #-}-- fetchMaybeDyn cId = DynamicQueryReader $ \arch -> case A.lookupComponentsAscMaybe cId arch of- Just as -> V.map Just as- Nothing -> V.replicate (length $ A.entities arch) Nothing- {-# INLINE fetchMaybeDyn #-}---- | Dynamic query for components by ID.------ @since 0.9---- | Dynamic query filter.------ @since 0.9-data DynamicQueryFilter = DynamicQueryFilter- { -- | `ComponentID`s to include.- --- -- @since 0.9- filterWith :: !(Set ComponentID),- -- | `ComponentID`s to exclude.- --- -- @since 0.9- filterWithout :: !(Set ComponentID)- }---- | @since 0.9-instance Semigroup DynamicQueryFilter where- DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB =- DynamicQueryFilter (withA <> withB) (withoutA <> withoutB)---- | @since 0.9-instance Monoid DynamicQueryFilter where- mempty = DynamicQueryFilter mempty mempty---- | Match all entities.------ @since 0.10-allDyn :: Set ComponentID -> DynamicQueryReader a -> Entities -> Vector a-allDyn cIds q es =- if Set.null cIds- then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities es}- else- let go n = runDynQueryReader q $ AS.nodeArchetype n- in V.concat . fmap go . Map.elems $ AS.find cIds $ archetypes es---- | Match all entities with a filter.------ @since 0.10-filterDyn :: Set ComponentID -> (Node -> Bool) -> DynamicQueryReader a -> Entities -> Vector a-filterDyn cIds f q es =- if Set.null cIds- then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities es}- else- let go n = runDynQueryReader q $ AS.nodeArchetype n- in V.concat . fmap go . Map.elems . Map.filter f $ AS.find cIds $ archetypes es---- | Match a single entity.------ @since 0.10-singleDyn :: (HasCallStack) => Set ComponentID -> DynamicQueryReader a -> Entities -> a-singleDyn cIds q es = case singleMaybeDyn cIds q es of- Just a -> a- _ -> error "singleDyn: expected a single entity"---- | Match a single entity, or `Nothing`.------ @since 0.10-singleMaybeDyn :: Set ComponentID -> DynamicQueryReader a -> Entities -> Maybe a-singleMaybeDyn cIds q es =- if Set.null cIds- then case Map.keys $ entities es of- [eId] -> case runDynQueryReader q $ A.singleton eId of- v | V.length v == 1 -> Just (V.head v)- _ -> Nothing- _ -> Nothing- else case Map.elems $ AS.find cIds $ archetypes es of- [n] -> case runDynQueryReader q $ AS.nodeArchetype n of- v | V.length v == 1 -> Just (V.head v)- _ -> Nothing- _ -> Nothing
− src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs
@@ -1,32 +0,0 @@--- |--- Module : Aztecs.ECS.Query.Dynamic.Reader.Class--- 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.Reader.Class (DynamicQueryReaderF (..)) where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity---- | Dynamic query reader functor.------ @since 0.10-class (Functor f) => DynamicQueryReaderF f where- -- | Fetch the currently matched `EntityID`.- --- -- @since 0.10- entity :: f EntityID-- -- | Fetch a `Component` by its `ComponentID`.- --- -- @since 0.10- fetchDyn :: (Component a) => ComponentID -> f a-- -- | Try to fetch a `Component` by its `ComponentID`.- --- -- @since 0.10- fetchMaybeDyn :: (Component a) => ComponentID -> f (Maybe a)- fetchMaybeDyn cId = Just <$> fetchDyn cId
− src/Aztecs/ECS/Query/Reader.hs
@@ -1,177 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# 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.Reader- ( -- * Queries- QueryReader (..),- QueryReaderF (..),- DynamicQueryReaderF (..),-- -- ** Running- all,- all',- single,- single',- singleMaybe,- singleMaybe',-- -- * Filters- QueryFilter (..),- with,- without,- DynamicQueryFilter (..),- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic.Reader-import Aztecs.ECS.Query.Reader.Class-import Aztecs.ECS.World.Components (Components)-import qualified Aztecs.ECS.World.Components as CS-import Aztecs.ECS.World.Entities (Entities (..))-import qualified Aztecs.ECS.World.Entities as E-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Vector (Vector)-import GHC.Stack-import Prelude hiding (all)---- | Query to read from entities.------ @since 0.10-newtype QueryReader a- = QueryReader- { -- | Run a query reader.- --- -- @since 0.10- runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReader a)- }- deriving (Functor)---- | @since 0.10-instance Applicative QueryReader where- pure a = QueryReader (mempty,,pure a)- {-# INLINE pure #-}-- (QueryReader f) <*> (QueryReader g) = QueryReader $ \cs ->- let !(cIdsG, cs', aQS) = g cs- !(cIdsF, cs'', bQS) = f cs'- in (cIdsG <> cIdsF, cs'', bQS <*> aQS)- {-# INLINE (<*>) #-}---- | @since 0.10-instance QueryReaderF QueryReader where- fetch :: forall a. (Component a) => QueryReader a- fetch = QueryReader $ \cs ->- let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchDyn cId)- {-# INLINE fetch #-}-- fetchMaybe :: forall a. (Component a) => QueryReader (Maybe a)- fetchMaybe = QueryReader $ \cs ->- let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchMaybeDyn cId)- {-# INLINE fetchMaybe #-}---- | @since 0.10-instance DynamicQueryReaderF QueryReader where- entity = QueryReader (mempty,,entity)- {-# INLINE entity #-}-- fetchDyn cId = QueryReader (Set.singleton cId,,fetchDyn cId)- {-# INLINE fetchDyn #-}-- fetchMaybeDyn cId = QueryReader (Set.singleton cId,,fetchMaybeDyn cId)- {-# INLINE fetchMaybeDyn #-}---- | Filter for a `Query`.------ @since 0.9-newtype QueryFilter = QueryFilter- { -- | Run a query filter.- runQueryFilter :: Components -> (DynamicQueryFilter, Components)- }---- | @since 0.9-instance Semigroup QueryFilter where- a <> b =- QueryFilter- ( \cs ->- let !(withA', cs') = runQueryFilter a cs- !(withB', cs'') = runQueryFilter b cs'- in (withA' <> withB', cs'')- )---- | @since 0.9-instance Monoid QueryFilter where- mempty = QueryFilter (mempty,)---- | Filter for entities containing this component.------ @since 0.9-with :: forall a. (Component a) => QueryFilter-with = QueryFilter $ \cs ->- let !(cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')---- | Filter out entities containing this component.------ @since 0.9-without :: forall a. (Component a) => QueryFilter-without = QueryFilter $ \cs ->- let !(cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')---- | Match all entities.------ @since 0.10-all :: QueryReader a -> Entities -> (Vector a, Entities)-all q es = let !(as, cs) = all' q es in (as, es {E.components = cs})-{-# INLINE all #-}---- | Match all entities.------ @since 0.10-all' :: QueryReader a -> Entities -> (Vector a, Components)-all' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (allDyn rs dynQ es, cs')-{-# INLINE all' #-}---- | Match a single entity.------ @since 0.10-single :: (HasCallStack) => QueryReader a -> Entities -> (a, Entities)-single q es = let !(a, cs) = single' q es in (a, es {E.components = cs})-{-# INLINE single #-}---- | Match a single entity.------ @since 0.10-single' :: (HasCallStack) => QueryReader a -> Entities -> (a, Components)-single' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleDyn rs dynQ es, cs')-{-# INLINE single' #-}---- | Match a single entity.------ @since 0.10-singleMaybe :: QueryReader a -> Entities -> (Maybe a, Entities)-singleMaybe q es = let !(a, cs) = singleMaybe' q es in (a, es {E.components = cs})-{-# INLINE singleMaybe #-}---- | Match a single entity.------ @since 0.10-singleMaybe' :: QueryReader a -> Entities -> (Maybe a, Components)-singleMaybe' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleMaybeDyn rs dynQ es, cs')-{-# INLINE singleMaybe' #-}
− src/Aztecs/ECS/Query/Reader/Class.hs
@@ -1,26 +0,0 @@--- |--- Module : Aztecs.ECS.Query.Reader.Class--- 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.Reader.Class (QueryReaderF (..)) where--import Aztecs.ECS.Component---- | Query reader functor.------ @since 0.10-class (Functor f) => QueryReaderF f where- -- | Fetch a `Component` by its type.- --- -- @since 0.10- fetch :: (Component a) => f a-- -- | Fetch a `Component` by its type, returning `Nothing` if it doesn't exist.- --- -- @since 0.10- fetchMaybe :: (Component a) => f (Maybe a)- fetchMaybe = Just <$> fetch
src/Aztecs/ECS/System.hs view
@@ -1,8 +1,13 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Aztecs.ECS.System@@ -12,151 +17,132 @@ -- Maintainer : matt@hunzinger.me -- Stability : provisional -- Portability : non-portable (GHC extensions)------ Systems to process queries in parallel. module Aztecs.ECS.System- ( System,- SystemT (..),- MonadReaderSystem (..),- MonadSystem (..),- MonadDynamicReaderSystem (..),- MonadDynamicSystem (..),+ ( -- * Systems+ System (..),++ -- * Dynamic systems+ DynamicSystem (..),+ runDynamicSystem,++ -- ** Queries+ readQuery,+ readQueryFiltered,+ readQuerySingle,+ readQuerySingleMaybe,+ runQuery,+ runQueryFiltered,+ runQuerySingle,+ runQuerySingleMaybe,++ -- ** Dynamic queries+ readQueryDyn,+ readQueryFilteredDyn,+ readQuerySingleMaybeDyn,+ runQueryDyn,+ runQueryFilteredDyn,+ runQuerySingleMaybeDyn, ) where import Aztecs.ECS.Component-import Aztecs.ECS.Query+import Aztecs.ECS.Query (Query (..), QueryFilter (..)) import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Dynamic (DynamicQueryT)-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))-import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System.Class-import Aztecs.ECS.System.Dynamic.Class-import Aztecs.ECS.System.Dynamic.Reader.Class-import Aztecs.ECS.System.Reader.Class-import qualified Aztecs.ECS.View as V+import Aztecs.ECS.Query.Dynamic (DynamicQuery, DynamicQueryFilter (..))+import Aztecs.ECS.System.Dynamic (DynamicSystem (..), runDynamicSystem)+import qualified Aztecs.ECS.System.Dynamic as DS import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Archetypes (Node (..))-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Category-import Control.Concurrent.STM-import Control.Monad.Reader+import Aztecs.ECS.World.Components (Components) import qualified Data.Foldable as F-import qualified Data.Map as Map import Data.Set (Set)-import Prelude hiding (all, filter, id, map, (.))+import Data.Vector (Vector)+import GHC.Stack+import Prelude hiding (all, filter, map, mapM) --- | @since 0.9-type System = SystemT STM+-- | System for querying entities.+newtype System m a = System {runSystem :: Components -> (Components, DynamicSystem m a)} --- | System to process queries in parallel.------ @since 0.9-newtype SystemT m a = SystemT- { -- | Run a system on a collection of `Entities`.- --- -- @since 0.9- runSystemT :: ReaderT (TVar Entities) m a- }- deriving (Functor, Applicative, Monad)+instance Functor (System m) where+ fmap f (System g) = System $ \cs ->+ let !(cs', dynS) = g cs in (cs', fmap f dynS)+ {-# INLINE fmap #-} --- | @since 0.9-instance MonadDynamicSystem (DynamicQueryT STM) System where- mapDyn cIds q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.view cIds $ archetypes w- (o, v') <- lift $ V.mapDyn q v- lift . modifyTVar wVar $ V.unview v'- return o- mapSingleMaybeDyn cIds q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- case V.viewSingle cIds $ archetypes w of- Just v -> do- (o, v') <- lift $ V.mapSingleDyn q v- lift . modifyTVar wVar $ V.unview v'- return o- Nothing -> return Nothing- filterMapDyn cIds f q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.filterView cIds f $ archetypes w- (o, v') <- lift $ V.mapDyn q v- lift . modifyTVar wVar $ V.unview v'- return o+instance Applicative (System m) where+ pure a = System (,Pure a)+ {-# INLINE pure #-} --- | @since 0.9-instance MonadSystem (QueryT STM) System where- map q = SystemT $ do- (rws, dynQ) <- runSystemT $ fromQuery q- runSystemT $ mapDyn (Q.reads rws <> Q.writes rws) dynQ- mapSingleMaybe q = SystemT $ do- (rws, dynQ) <- runSystemT $ fromQuery q- runSystemT $ mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ- filterMap q qf = SystemT $ do- wVar <- ask- let go w =- let (rws, cs', dynQ) = runQuery q $ components w- (dynF, cs'') = runQueryFilter qf cs'- in ((rws, dynQ, dynF), w {components = cs''})- (rws, dynQ, dynF) <- lift $ stateTVar wVar go- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- runSystemT $ filterMapDyn (Q.reads rws <> Q.writes rws) f' dynQ+ (System f) <*> (System g) = System $ \cs ->+ let !(cs', dynF) = f cs+ !(cs'', dynG) = g cs'+ in (cs'', dynF <*> dynG)+ {-# INLINE (<*>) #-} --- | @since 0.9-instance MonadReaderSystem QueryReader System where- all q = SystemT $ do- (cIds, dynQ) <- runSystemT $ fromQueryReader q- runSystemT $ allDyn cIds dynQ- filter q qf = SystemT $ do- wVar <- ask- let go w =- let (cIds, cs', dynQ) = runQueryReader q $ components w- (dynF, cs'') = runQueryFilter qf cs'- in ((cIds, dynQ, dynF), w {components = cs''})- (cIds, dynQ, dynF) <- lift $ stateTVar wVar go- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- runSystemT $ filterDyn cIds dynQ f'+runner :: (Set ComponentID -> DynamicQuery m a -> DynamicSystem m b) -> Query m a -> System m b+runner f q = System $ \cs ->+ let (rws, cs', dynQ) = runQuery' q cs+ in (cs', f (Q.reads rws <> Q.writes rws) dynQ) --- | @since 0.9-instance MonadDynamicReaderSystem DynamicQueryReader System where- allDyn cIds q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.view cIds $ archetypes w- return $- if V.null v- then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities w}- else V.allDyn q v- filterDyn cIds q f = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.filterView cIds f $ archetypes w- return $ V.allDyn q v+-- | Match all entities.+readQuery :: (Monad m) => Query m a -> System m (Vector a)+readQuery = runner DS.readQuery --- | Convert a `QueryReaderT` to a `System`.------ @since 0.9-fromQueryReader :: QueryReader a -> System (Set ComponentID, DynamicQueryReader a)-fromQueryReader q = SystemT $ do- wVar <- ask- let go w =- let (cIds, cs', dynQ) = runQueryReader q $ components w- in ((cIds, dynQ), w {components = cs'})- lift $ stateTVar wVar go+readQuerySingle :: (HasCallStack, Monad m) => Query m a -> System m a+readQuerySingle = runner DS.readQuerySingle --- | Convert a `QueryT` to a `System`.------ @since 0.9-fromQuery :: QueryT STM a -> System (ReadsWrites, DynamicQueryT STM a)-fromQuery q = SystemT $ do- wVar <- ask- let go w =- let (rws, cs', dynQ) = runQuery q $ components w- in ((rws, dynQ), w {components = cs'})- lift $ stateTVar wVar go+readQuerySingleMaybe :: (Monad m) => Query m a -> System m (Maybe a)+readQuerySingleMaybe = runner DS.readQuerySingleMaybe++-- | Match all entities with a filter.+readQueryFiltered :: (Monad m) => Query m a -> QueryFilter -> System m (Vector a)+readQueryFiltered q f = System $ \cs ->+ let (rws, cs', dynQ) = runQuery' q cs+ (dynF, cs'') = runQueryFilter f cs'+ flt n =+ F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+ && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+ in (cs'', DS.readQueryFiltered (Q.reads rws <> Q.writes rws) flt dynQ)++-- | Map all matching entities.+runQuery :: (Monad m) => Query m a -> System m (Vector a)+runQuery = runner DS.runQuery++runQuerySingle :: (HasCallStack, Monad m) => Query m a -> System m a+runQuerySingle = runner DS.runQuerySingle++-- | Map a single matching entity, or @Nothing@.+runQuerySingleMaybe :: (Monad m) => Query m a -> System m (Maybe a)+runQuerySingleMaybe = runner DS.runQuerySingleMaybe++-- | Filter and map all matching entities.+runQueryFiltered :: (Monad m) => Query m a -> QueryFilter -> System m (Vector a)+runQueryFiltered q f = System $ \cs ->+ let (rws, cs', dynQ) = runQuery' q cs+ (dynF, cs'') = runQueryFilter f cs'+ flt n =+ F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+ && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+ in (cs'', DS.runQueryFiltered (Q.reads rws <> Q.writes rws) dynQ flt)++-- | Match all entities with a dynamic query.+readQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m (Vector a)+readQueryDyn cIds q = System (,DS.readQuery cIds q)++readQuerySingleMaybeDyn :: Set ComponentID -> DynamicQuery m a -> System m (Maybe a)+readQuerySingleMaybeDyn cIds q = System (,DS.readQuerySingleMaybe cIds q)++-- | Match all entities with a dynamic query and filter.+readQueryFilteredDyn :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> System m (Vector a)+readQueryFilteredDyn cIds q f = System (,DS.readQueryFiltered cIds f q)++-- | Map all entities with a dynamic query.+runQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m (Vector a)+runQueryDyn cIds q = System (,DS.runQuery cIds q)++-- | Map a single entity with a dynamic query.+runQuerySingleMaybeDyn :: Set ComponentID -> DynamicQuery m a -> System m (Maybe a)+runQuerySingleMaybeDyn cIds q = System (,DS.runQuerySingleMaybe cIds q)++-- | Filter and map all entities with a dynamic query.+runQueryFilteredDyn :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> System m (Vector a)+runQueryFilteredDyn cIds f q = System (,DS.runQueryFiltered cIds q f)
− src/Aztecs/ECS/System/Class.hs
@@ -1,45 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Class--- 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.Class (MonadSystem (..)) where--import Aztecs.ECS.Query.Reader (QueryFilter (..))-import Data.Vector (Vector)-import GHC.Stack-import Prelude hiding (map)---- | Monadic system.------ @since 0.9-class (Monad m) => MonadSystem q m | m -> q where- -- | Map all matching entities with a query.- --- -- @since 0.9- map :: q a -> m (Vector a)-- -- | Map a single matching entity with a query, or @Nothing@.- --- -- @since 0.9- mapSingleMaybe :: q a -> m (Maybe a)-- -- | Map a single matching entity with a query.- --- -- @since 0.9- mapSingle :: (HasCallStack) => q a -> m a- mapSingle q = do- res <- mapSingleMaybe q- case res of- Just a -> return a- Nothing -> error "Expected a single matching entity."-- -- | Map all matching entities with a query and filter.- --- -- @since 0.9- filterMap :: q a -> QueryFilter -> m (Vector a)
+ src/Aztecs/ECS/System/Dynamic.hs view
@@ -0,0 +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 #-}
− src/Aztecs/ECS/System/Dynamic/Class.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Dynamic.Class--- 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.Class (MonadDynamicSystem (..)) where--import Aztecs.ECS.Component (ComponentID)-import Aztecs.ECS.World.Archetypes (Node (..))-import Data.Set (Set)-import Data.Vector (Vector)-import GHC.Stack---- | Monadic dynamic system.------ @since 0.9-class (Monad m) => MonadDynamicSystem q m | m -> q where- -- | Map all matching entities with a query.- --- -- @since 0.9- mapDyn :: Set ComponentID -> q a -> m (Vector a)-- -- | Map a single matching entity with a query, or @Nothing@.- --- -- @since 0.9- mapSingleMaybeDyn :: Set ComponentID -> q a -> m (Maybe a)-- -- | Map a single matching entity with a query.- mapSingleDyn :: (HasCallStack) => Set ComponentID -> q a -> m a- mapSingleDyn cIds q = do- res <- mapSingleMaybeDyn cIds q- case res of- Just a -> return a- Nothing -> error "Expected a single matching entity."-- -- | Map all matching entities with a query and filter.- --- -- @since 0.9- filterMapDyn :: Set ComponentID -> (Node -> Bool) -> q a -> m (Vector a)
− src/Aztecs/ECS/System/Dynamic/Reader/Class.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Dynamic.Reader.Class--- 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.Reader.Class (MonadDynamicReaderSystem (..)) where--import Aztecs.ECS.Component-import Aztecs.ECS.World.Archetypes (Node)-import Data.Set (Set)-import Data.Vector (Vector)-import qualified Data.Vector as V-import GHC.Stack---- | Monadic dynamic reader system.------ @since 0.9-class (Monad m) => MonadDynamicReaderSystem q m | m -> q where- -- | Match all entities with a query.- --- -- @since 0.9- allDyn :: Set ComponentID -> q a -> m (Vector a)-- -- | Match a single entity with a query.- --- -- @since 0.9- singleDyn :: (HasCallStack) => Set ComponentID -> q a -> m a- singleDyn cIds q = do- os <- allDyn cIds q- case V.length os of- 1 -> return $ V.head os- _ -> error "singleDyn: expected a single result, but got multiple"-- -- | Match a single entity with a query, or Nothing.- --- -- @since 0.9- singleMaybeDyn :: Set ComponentID -> q a -> m (Maybe a)- singleMaybeDyn cIds q = do- os <- allDyn cIds q- return $ case V.length os of- 1 -> Just (V.head os)- _ -> Nothing-- -- | Match all entities with a query and filter.- --- -- @since 0.9- filterDyn :: Set ComponentID -> q a -> (Node -> Bool) -> m (Vector a)
− src/Aztecs/ECS/System/Reader/Class.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Reader.Class--- 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.Reader.Class (MonadReaderSystem (..)) where--import Aztecs.ECS.Query.Reader (QueryFilter (..))-import Data.Vector (Vector)-import qualified Data.Vector as V-import GHC.Stack-import Prelude hiding (all)---- | Monadic reader system.------ @since 0.9-class (Monad m) => MonadReaderSystem q m | m -> q where- -- | Match all entities with a query.- --- -- @since 0.9- all :: q a -> m (Vector a)-- -- | Match a single entity with a query.- --- -- @since 0.9- single :: (HasCallStack) => q a -> m a- single q = do- os <- all q- case V.length os of- 1 -> return $ V.head os- _ -> error "single: expected a single result"-- -- | Match a single entity with a query, or @Nothing@.- --- -- @since 0.9- singleMaybe :: q a -> m (Maybe a)- singleMaybe q = do- os <- all q- return $ case V.length os of- 1 -> Just (V.head os)- _ -> Nothing-- -- | Match all entities with a query and filter.- --- -- @since 0.9- filter :: q a -> QueryFilter -> m (Vector a)
src/Aztecs/ECS/View.hs view
@@ -25,14 +25,15 @@ ) where -import Aztecs.ECS.Query.Dynamic (DynamicQueryT (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.Access.Internal (Access)+import Aztecs.ECS.Query.Dynamic (DynamicQuery (..)) import Aztecs.ECS.World.Archetypes import qualified Aztecs.ECS.World.Archetypes as AS import Aztecs.ECS.World.Components import Aztecs.ECS.World.Entities (Entities) import qualified Aztecs.ECS.World.Entities as E-import Data.Foldable (foldlM)+import Control.Monad.Identity (Identity (runIdentity))+import Data.Foldable hiding (null) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set)@@ -41,50 +42,36 @@ import Prelude hiding (null) -- | View into a `World`, containing a subset of archetypes.------ @since 0.9-newtype View = View+newtype View m = View { -- | Archetypes contained in this view.- --- -- @since 0.9- viewArchetypes :: Map ArchetypeID Node+ viewArchetypes :: Map ArchetypeID (Node m) } deriving (Show, Semigroup, Monoid) -- | View into all archetypes containing the provided component IDs.------ @since 0.9-view :: Set ComponentID -> Archetypes -> View+view :: Set ComponentID -> Archetypes m -> View m view cIds as = View $ AS.find cIds as -- | View into a single archetype containing the provided component IDs.------ @since 0.9-viewSingle :: Set ComponentID -> Archetypes -> Maybe View+viewSingle :: Set ComponentID -> Archetypes m -> Maybe (View m) viewSingle cIds as = case Map.toList $ AS.find cIds as of [a] -> Just . View $ uncurry Map.singleton a _ -> Nothing -- | View into all archetypes containing the provided component IDs and matching the provided predicate.------ @since 0.9 filterView :: Set ComponentID ->- (Node -> Bool) ->- Archetypes ->- View+ (Node m -> Bool) ->+ Archetypes m ->+ View m filterView cIds f as = View $ Map.filter f (AS.find cIds as) -- | @True@ if the `View` is empty.------ @since 0.9-null :: View -> Bool+null :: View m -> Bool null = Map.null . viewArchetypes -- | "Un-view" a `View` back into a `World`.------ @since 0.9-unview :: View -> Entities -> Entities+unview :: View m -> Entities m -> Entities m unview v es = es { E.archetypes =@@ -95,47 +82,39 @@ } -- | Query all matching entities in a `View`.------ @since 0.9-allDyn :: DynamicQueryReader a -> View -> Vector a+allDyn :: DynamicQuery Identity a -> View Identity -> Vector a allDyn q v = foldl' ( \acc n ->- let as = runDynQueryReader q $ nodeArchetype n+ let (as, _, _) = runIdentity . runDynQuery q $ nodeArchetype n in as V.++ acc ) V.empty (viewArchetypes v) -- | Query all matching entities in a `View`.------ @since 0.9-singleDyn :: DynamicQueryReader a -> View -> Maybe a+singleDyn :: DynamicQuery Identity a -> View Identity -> Maybe a singleDyn q v = case allDyn q v of as | V.length as == 1 -> Just (V.head as) _ -> Nothing --- | Map all matching entities in a `View`.------ @since 0.9-mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Vector a, View)+-- | Map all matching entities in a `View`. Returns the results, updated view, and hooks to run.+mapDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Vector a, View m, Access m ()) mapDyn q v = do- (as, arches) <-+ (as, arches, hooks) <- foldlM- ( \(acc, archAcc) (aId, n) -> do- (as', arch') <- runDynQuery q $ nodeArchetype n- return (as' V.++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)+ ( \(acc, archAcc, hooksAcc) (aId, n) -> do+ (as', arch', hook) <- runDynQuery q $ nodeArchetype n+ return (as' V.++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc, hooksAcc >> hook) )- (V.empty, Map.empty)+ (V.empty, Map.empty, return ()) (Map.toList $ viewArchetypes v)- return (as, View arches)+ return (as, View arches, hooks) --- | Map a single matching entity in a `View`.------ @since 0.9-mapSingleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a, View)+-- | Map a single matching entity in a `View`. Returns the result, updated view, and hooks to run.+mapSingleDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Maybe a, View m, Access m ()) mapSingleDyn q v = do- (as, arches) <- mapDyn q v+ (as, arches, hooks) <- mapDyn q v return $ case as of- a | V.length a == 1 -> (Just (V.head a), arches)- _ -> (Nothing, arches)+ a | V.length a == 1 -> (Just (V.head a), arches, hooks)+ _ -> (Nothing, arches, hooks)
src/Aztecs/ECS/World.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -19,6 +17,7 @@ spawn, spawnEmpty, insert,+ insertUntracked, lookup, remove, removeWithId,@@ -26,79 +25,65 @@ ) where +import Aztecs.ECS.Access.Internal (Access) import Aztecs.ECS.Component import Aztecs.ECS.Entity import Aztecs.ECS.World.Bundle-import Aztecs.ECS.World.Entities (Entities) 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 GHC.Generics import Prelude hiding (lookup) --- | World of entities and their components.------ @since 0.9-data World = World- { -- | Entities and their components.- --- -- @since 0.9- entities :: !Entities,- -- | Next unique entity identifier.- --- -- @since 0.9- nextEntityId :: !EntityID- }- deriving (Show, Generic)- -- | Empty `World`.------ @since 0.9-empty :: World+empty :: World m empty = World { entities = E.empty,- nextEntityId = EntityID 0+ nextEntityId = EntityID 0,+ observers = O.empty } --- | Spawn a `Bundle` into the `World`.------ @since 0.9-spawn :: Bundle -> World -> (EntityID, World)+-- | 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- in (e, w {entities = E.spawn e b $ entities w, nextEntityId = EntityID $ unEntityId e + 1})+ (es', hook) = E.spawn e b $ entities w+ in (e, w {entities = es', nextEntityId = EntityID $ unEntityId e + 1}, hook) -- | Spawn an empty entity.------ @since 0.9-spawnEmpty :: World -> (EntityID, World)+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.------ @since 0.9-insert :: EntityID -> Bundle -> World -> World-insert e c w = w {entities = E.insert e c (entities w)}+-- | 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.------ @since 0.9-lookup :: forall a. (Component a) => EntityID -> World -> Maybe a+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.------ @since 0.9-remove :: forall a. (Component a) => EntityID -> World -> (Maybe a, World)-remove e w = let (a, es) = E.remove e (entities w) in (a, w {entities = es})+-- | 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`.------ @since 0.9-removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> World -> (Maybe a, World)-removeWithId e cId w = let (a, es) = E.removeWithId e cId (entities w) in (a, w {entities = es})+-- | 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 -> (IntMap Dynamic, World)+despawn :: EntityID -> World m -> (IntMap Dynamic, World m) despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es})
src/Aztecs/ECS/World/Archetype.hs view
@@ -1,262 +1,264 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.World.Archetype--- 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- ( Archetype (..),- empty,- singleton,- lookupComponent,- lookupComponents,- lookupComponentsAsc,- lookupComponentsAscMaybe,- lookupStorage,- member,- remove,- removeStorages,- insertComponent,- insertComponents,- insertAscVector,- zipWith,- zipWith_,- zipWithM,- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import qualified Aztecs.ECS.World.Storage as S-import Aztecs.ECS.World.Storage.Dynamic-import qualified Aztecs.ECS.World.Storage.Dynamic as S-import Control.Monad.Writer- ( MonadWriter (..),- WriterT (..),- runWriter,- )-import Data.Dynamic-import Data.Foldable-import Data.IntMap (IntMap)-import qualified Data.IntMap.Strict as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Vector (Vector)-import qualified Data.Vector as V-import GHC.Generics-import Prelude hiding (map, zipWith)---- | Archetype of entities and components.--- An archetype is guranteed to contain one of each stored component per entity.------ @since 0.9-data Archetype = Archetype- { -- | Component storages.- --- -- @since 0.9- storages :: !(IntMap DynamicStorage),- -- | Entities stored in this archetype.- --- -- @since 0.9- entities :: !(Set EntityID)- }- deriving (Show, Generic)--instance Semigroup Archetype where- a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b}--instance Monoid Archetype where- mempty = empty---- | Empty archetype.------ @since 0.9-empty :: Archetype-empty = Archetype {storages = IntMap.empty, entities = Set.empty}---- | Archetype with a single entity.------ @since 0.9-singleton :: EntityID -> Archetype-singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e}---- | Lookup a component `Storage` by its `ComponentID`.------ @since 0.9-lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a)-lookupStorage cId w = do- !dynS <- IntMap.lookup (unComponentId cId) $ storages w- fromDynamic $ storageDyn dynS-{-# INLINE lookupStorage #-}---- | Lookup a component by its `EntityID` and `ComponentID`.------ @since 0.9-lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a-lookupComponent e cId w = lookupComponents cId w Map.!? e-{-# INLINE lookupComponent #-}---- | Lookup all components by their `ComponentID`.------ @since 0.9-lookupComponents :: (Component a) => ComponentID -> Archetype -> Map EntityID a-lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of- Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) (V.toList as)- Nothing -> Map.empty-{-# INLINE lookupComponents #-}---- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.------ @since 0.9-lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> Vector a-lookupComponentsAsc cId = fromMaybe V.empty . lookupComponentsAscMaybe cId-{-# INLINE lookupComponentsAsc #-}---- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.------ @since 0.9-lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe (Vector a)-lookupComponentsAscMaybe cId arch = S.toAscVector <$> lookupStorage @a cId arch-{-# INLINE lookupComponentsAscMaybe #-}---- | Insert a component into the archetype.--- This assumes the archetype contains one of each stored component per entity.------ @since 0.9-insertComponent ::- forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype-insertComponent e cId c arch =- let !storage =- S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch- in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}---- | @True@ if this archetype contains an entity with the provided `ComponentID`.------ @since 0.9-member :: ComponentID -> Archetype -> Bool-member cId = IntMap.member (unComponentId cId) . storages---- | Zip a vector of components with a function and a component storage.------ @since 0.9-zipWith ::- forall a c. (Component c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype -> (Vector c, Archetype)-zipWith as f cId arch =- let go maybeDyn = case maybeDyn of- Just dyn -> case fromDynamic $ storageDyn dyn of- Just s -> do- let !(cs', s') = S.zipWith @c @(StorageT c) f as s- tell cs'- return $ Just $ dyn {storageDyn = toDyn s'}- Nothing -> return maybeDyn- Nothing -> return Nothing- !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch- in (cs, arch {storages = storages'})-{-# INLINE zipWith #-}---- | Zip a vector of components with a monadic function and a component storage.------ @since 0.9-zipWithM ::- forall m a c. (Monad m, Component c) => Vector a -> (a -> c -> m c) -> ComponentID -> Archetype -> m (Vector c, Archetype)-zipWithM as f cId arch = do- let go maybeDyn = case maybeDyn of- Just dyn -> case fromDynamic $ storageDyn dyn of- Just s ->- WriterT $- fmap- (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs))- (S.zipWithM @c @(StorageT c) f as s)- Nothing -> pure maybeDyn- Nothing -> pure Nothing- res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch- return (snd res, arch {storages = fst res})---- | Zip a vector of components with a function and a component storage.------ @since 0.9-zipWith_ ::- forall a c. (Component c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype -> Archetype-zipWith_ as f cId arch =- let maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of- Just dyn -> case fromDynamic $ storageDyn dyn of- Just s ->- let !s' = S.zipWith_ @c @(StorageT c) f as s in Just $ dyn {storageDyn = toDyn s'}- Nothing -> Nothing- Nothing -> Nothing- in (empty {storages = maybe IntMap.empty (IntMap.singleton (unComponentId cId)) maybeStorage})-{-# INLINE zipWith_ #-}---- | Insert a vector of components into the archetype, sorted in ascending order by their `EntityID`.------ @since 0.9-insertAscVector :: forall a. (Component a) => ComponentID -> Vector a -> Archetype -> Archetype-insertAscVector cId as arch =- let !storage = dynStorage @a $ S.fromAscVector @a @(StorageT a) as- in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch}-{-# INLINE insertAscVector #-}---- | Remove an entity from an archetype, returning its components.------ @since 0.9-remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype)-remove e arch =- let go (dynAcc, archAcc) (cId, dynS) =- let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS- !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs- dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS- !dynAcc' = case dynA of- Just d -> IntMap.insert cId d dynAcc- Nothing -> dynAcc- in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})- arch' = arch {entities = Set.delete e $ entities arch}- in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'---- | Remove an entity from an archetype, returning its component storages.------ @since 0.9-removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype)-removeStorages e arch =- let go (dynAcc, archAcc) (cId, dynS) =- let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS- !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs- dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS- !dynAcc' = case dynA of- Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc- Nothing -> dynAcc- in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})- arch' = arch {entities = Set.delete e $ entities arch}- in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'---- | Insert a map of component storages and their `EntityID` into the archetype.------ @since 0.9-insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype-insertComponents e cs arch =- let f archAcc (itemCId, dyn) =- let storages' = IntMap.adjust go itemCId (storages archAcc)- es = Set.toList $ entities archAcc- go s =- let ecs = V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip es . V.toList $ toAscVectorDyn s- in fromAscVectorDyn ecs s- in archAcc {storages = storages', entities = Set.insert e $ entities archAcc}- in foldl' f arch (IntMap.toList cs)+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Archetype +-- 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 + ( Archetype (..), + empty, + singleton, + lookupComponent, + lookupComponents, + lookupComponentsAsc, + lookupComponentsAscMaybe, + lookupStorage, + member, + remove, + removeStorages, + insertComponent, + insertComponentUntracked, + insertComponents, + insertAscVector, + zipWith, + zipWith_, + zipWithM, + zipWithAccum, + zipWithAccumM, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import Aztecs.ECS.World.Archetype.Internal +import qualified Aztecs.ECS.World.Storage as S +import Aztecs.ECS.World.Storage.Dynamic +import qualified Aztecs.ECS.World.Storage.Dynamic as S +import Control.Monad.Writer +import Data.Dynamic +import Data.Foldable +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import Prelude hiding (map, zipWith) + +-- | Archetype with a single entity. +singleton :: EntityID -> Archetype m +singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e} + +-- | Lookup a component `Storage` by its `ComponentID`. +lookupStorage :: (Component m a) => ComponentID -> Archetype m -> Maybe (StorageT a) +lookupStorage cId w = do + !dynS <- IntMap.lookup (unComponentId cId) $ storages w + fromDynamic $ storageDyn dynS +{-# INLINE lookupStorage #-} + +-- | Lookup a component by its `EntityID` and `ComponentID`. +lookupComponent :: forall m a. (Component m a) => EntityID -> ComponentID -> Archetype m -> Maybe a +lookupComponent e cId w = lookupComponents cId w Map.!? e +{-# INLINE lookupComponent #-} + +-- | Lookup all components by their `ComponentID`. +lookupComponents :: forall m a. (Component m a) => ComponentID -> Archetype m -> Map EntityID a +lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of + Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) (V.toList as) + Nothing -> Map.empty +{-# INLINE lookupComponents #-} + +-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. +lookupComponentsAsc :: forall m a. (Component m a) => ComponentID -> Archetype m -> Vector a +lookupComponentsAsc cId = fromMaybe V.empty . lookupComponentsAscMaybe @m @a cId +{-# INLINE lookupComponentsAsc #-} + +-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. +lookupComponentsAscMaybe :: forall m a. (Component m a) => ComponentID -> Archetype m -> Maybe (Vector a) +lookupComponentsAscMaybe cId arch = S.toAscVector @a @(StorageT a) <$> lookupStorage @m @a cId arch +{-# INLINE lookupComponentsAscMaybe #-} + +-- | Insert a component into the archetype. +insertComponent :: + forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> (Archetype m, Access m ()) +insertComponent e cId c arch = + let !storage = + S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch + hook = do + componentOnInsert e c + triggerEntityEvent e (OnInsert c) + in (arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}, hook) + +-- | Insert a component into an archetype without running lifecycle hooks. +insertComponentUntracked :: + forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> Archetype m +insertComponentUntracked e cId c arch = + let !storage = + S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch + in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)} + +-- | @True@ if this archetype contains an entity with the provided `ComponentID`. +member :: ComponentID -> Archetype m -> Bool +member cId = IntMap.member (unComponentId cId) . storages + +-- | Zip a vector of components with a function and a component storage. +-- Returns the result vector, updated archetype, and the onChange hooks to run. +zipWith :: + forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Vector c, Archetype m, Access m ()) +zipWith as f cId arch = + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + let !(cs', s') = S.zipWith @c @(StorageT c) f as s + tell cs' + return $ Just $ dyn {storageDyn = toDyn s'} + Nothing -> return maybeDyn + Nothing -> return Nothing + (storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, c) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds cs) + in (cs, arch {storages = storages'}, hooks) +{-# INLINE zipWith #-} + +-- | Zip a vector of components with a monadic function and a component storage. +-- Returns the result vector, updated archetype, and the onChange hooks to run. +zipWithM :: + forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> m c) -> ComponentID -> Archetype m -> m (Vector c, Archetype m, Access m ()) +zipWithM as f cId arch = do + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> + WriterT $ + fmap + (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs)) + (S.zipWithM @c @(StorageT c) f as s) + Nothing -> pure maybeDyn + Nothing -> pure Nothing + res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch + let cs = snd res + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, c) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds cs) + return (cs, arch {storages = fst res}, hooks) + +-- | Zip a vector of components with a function and a component storage. +-- Returns the updated archetype and the onChange hooks to run. +zipWith_ :: + forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Archetype m, Access m ()) +zipWith_ as f cId arch = + let maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> + let !(cs, s') = S.zipWith @c @(StorageT c) f as s in Just (cs, dyn {storageDyn = toDyn s'}) + Nothing -> Nothing + Nothing -> Nothing + in case maybeStorage of + Just (cs, s) -> + let eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, c) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds cs) + in (empty {storages = IntMap.singleton (unComponentId cId) s}, hooks) + Nothing -> (empty {storages = IntMap.empty}, return ()) +{-# INLINE zipWith_ #-} + +-- | Zip a vector of components with a function returning a tuple. +zipWithAccum :: + forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> (o, c)) -> ComponentID -> Archetype m -> (Vector (o, c), Archetype m, Access m ()) +zipWithAccum as f cId arch = + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + let !(pairs', s') = S.zipWithAccum @c @(StorageT c) f as s + tell pairs' + return $ Just $ dyn {storageDyn = toDyn s'} + Nothing -> return maybeDyn + Nothing -> return Nothing + (storages', pairs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, (_, c)) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds pairs) + in (pairs, arch {storages = storages'}, hooks) +{-# INLINE zipWithAccum #-} + +-- | Zip a vector of components with a monadic function returning a tuple. +zipWithAccumM :: + forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> m (o, c)) -> ComponentID -> Archetype m -> m (Vector (o, c), Archetype m, Access m ()) +zipWithAccumM as f cId arch = do + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> + WriterT $ + fmap + (\(pairs, s') -> (Just dyn {storageDyn = toDyn s'}, pairs)) + (S.zipWithAccumM @c @(StorageT c) f as s) + Nothing -> pure maybeDyn + Nothing -> pure Nothing + res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch + let pairs = snd res + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, (_, c)) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds pairs) + return (pairs, arch {storages = fst res}, hooks) +{-# INLINE zipWithAccumM #-} + +-- | Insert a vector of components into the archetype, sorted in ascending order by their `EntityID`. +insertAscVector :: forall m a. (Component m a) => ComponentID -> Vector a -> Archetype m -> Archetype m +insertAscVector cId as arch = + let !storage = dynStorage @a $ S.fromAscVector @a @(StorageT a) as + in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch} +{-# INLINE insertAscVector #-} + +-- | Remove an entity from an archetype, returning its components. +remove :: EntityID -> Archetype m -> (IntMap Dynamic, Archetype m) +remove e arch = + let go (dynAcc, archAcc) (cId, dynS) = + let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS + !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs + dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS + !dynAcc' = case dynA of + Just d -> IntMap.insert cId d dynAcc + Nothing -> dynAcc + in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc}) + arch' = arch {entities = Set.delete e $ entities arch} + in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch' + +-- | Remove an entity from an archetype, returning its component storages. +removeStorages :: EntityID -> Archetype m -> (IntMap DynamicStorage, Archetype m) +removeStorages e arch = + let go (dynAcc, archAcc) (cId, dynS) = + let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS + !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs + dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS + !dynAcc' = case dynA of + Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc + Nothing -> dynAcc + in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc}) + arch' = arch {entities = Set.delete e $ entities arch} + in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch' + +-- | Insert a map of component storages and their `EntityID` into the archetype. +insertComponents :: EntityID -> IntMap Dynamic -> Archetype m -> Archetype m +insertComponents e cs arch = + let f archAcc (itemCId, dyn) = + let storages' = IntMap.adjust go itemCId (storages archAcc) + es = Set.toList $ entities archAcc + go s = + let ecs = V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip es . V.toList $ toAscVectorDyn s + in fromAscVectorDyn ecs s + in archAcc {storages = storages', entities = Set.insert e $ entities archAcc} + in foldl' f arch (IntMap.toList cs)
+ src/Aztecs/ECS/World/Archetype/Internal.hs view
@@ -0,0 +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}
src/Aztecs/ECS/World/Archetypes.hs view
@@ -1,15 +1,6 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-} -- | -- Module : Aztecs.ECS.World.Archetypes@@ -36,13 +27,17 @@ ) 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@@ -50,60 +45,10 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Vector as V-import GHC.Generics import Prelude hiding (all, lookup, map) --- | `Archetype` ID.------ @since 0.9-newtype ArchetypeID = ArchetypeID- { -- | Unique integer identifier.- --- -- @since 0.9- unArchetypeId :: Int- }- deriving newtype (Eq, Ord, Show)---- | Node in `Archetypes`.------ @since 0.9-data Node = Node- { -- | Unique set of `ComponentID`s of this `Node`.- --- -- @since 0.9- nodeComponentIds :: !(Set ComponentID),- -- | `Archetype` of this `Node`.- --- -- @since 0.9- nodeArchetype :: !Archetype- }- deriving (Show, Generic)---- | `Archetype` map.-data Archetypes = Archetypes- { -- | Archetype nodes in the map.- --- -- @since 0.9- nodes :: !(Map ArchetypeID Node),- -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.- --- -- @since 0.9- archetypeIds :: !(Map (Set ComponentID) ArchetypeID),- -- | Next unique `ArchetypeID`.- --- -- @since 0.9- nextArchetypeId :: !ArchetypeID,- -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.- --- -- @since 0.9- componentIds :: !(Map ComponentID (Set ArchetypeID))- }- deriving (Show, Generic)- -- | Empty `Archetypes`.------ @since 0.9-empty :: Archetypes+empty :: Archetypes m empty = Archetypes { nodes = mempty,@@ -113,9 +58,7 @@ } -- | Insert an archetype by its set of `ComponentID`s.------ @since 0.9-insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)+insertArchetype :: Set ComponentID -> Node m -> Archetypes m -> (ArchetypeID, Archetypes m) insertArchetype cIds n arches = let aId = nextArchetypeId arches in ( aId,@@ -128,30 +71,22 @@ ) -- | Adjust an `Archetype` by its `ArchetypeID`.------ @since 0.9-adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes+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.------ @since 0.9-findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID+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.------ @since 0.9-find :: Set ComponentID -> Archetypes -> Map ArchetypeID Node+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.------ @since 0.9-map :: Set ComponentID -> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes)+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@@ -161,33 +96,38 @@ in foldl' go ([], arches) $ findArchetypeIds cIds arches -- | Lookup an `ArchetypeID` by its set of `ComponentID`s.------ @since 0.9-lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID+lookupArchetypeId :: Set ComponentID -> Archetypes m -> Maybe ArchetypeID lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches) -- | Lookup an `Archetype` by its `ArchetypeID`.------ @since 0.9-lookup :: ArchetypeID -> Archetypes -> Maybe Node+lookup :: ArchetypeID -> Archetypes m -> Maybe (Node m) lookup aId arches = Map.lookup aId (nodes arches) -- | Insert a component into an entity with its `ComponentID`.------ @since 0.9 insert ::+ (Monad m) => EntityID -> ArchetypeID -> Set ComponentID ->- DynamicBundle ->- Archetypes ->- (Maybe ArchetypeID, Archetypes)+ 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 = n {nodeArchetype = runDynamicBundle b e $ nodeArchetype n}- in (Nothing, arches {nodes = Map.adjust go aId $ nodes arches})+ 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@@ -199,27 +139,34 @@ let nextArch = nodeArchetype nextNode nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch} !nextArch'' = A.insertComponents e cs nextArch'- in nextNode {nodeArchetype = runDynamicBundle b e nextArch''}- in (Just nextAId, arches {nodes = Map.adjust adjustNode nextAId nodes'})+ (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 = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e}+ (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')- Nothing -> (Nothing, arches)+ in (Just nextAId, arches', hook)+ Nothing -> (Nothing, arches, return ()) -- | Remove a component from an entity with its `ComponentID`.------ @since 0.9 remove ::- (Component a) =>+ (Component m a) => EntityID -> ArchetypeID -> ComponentID ->- Archetypes ->- (Maybe (a, ArchetypeID), Archetypes)+ 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 ->@@ -231,23 +178,27 @@ in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)} go nextNode = nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')}- in ( (,nextAId) <$> (a >>= fromDynamic),- arches' {nodes = Map.adjust go nextAId (nodes arches')}+ 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 = Set.insert cId (nodeComponentIds node),+ { nodeComponentIds = destCIds, nodeArchetype = Archetype {storages = cs', entities = Set.singleton e} }- !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches+ !(nextAId, arches') = insertArchetype destCIds n arches node' = node {nodeArchetype = arch'}- removeDyn s =- let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') . V.toList $ toAscVectorDyn s- in (res, fromAscVectorDyn . V.fromList $ Map.elems dyns)- in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)),- arches' {nodes = Map.insert aId node' (nodes arches')}+ 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)+ Nothing -> (Nothing, arches, return ())
+ src/Aztecs/ECS/World/Archetypes/Internal.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}++-- |+-- Module : Aztecs.ECS.World.Archetypes.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.Archetypes.Internal+ ( ArchetypeID (..),+ Node (..),+ Archetypes (..),+ )+where++import Aztecs.ECS.Component.Internal (ComponentID)+import Aztecs.ECS.World.Archetype.Internal (Archetype)+import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Set (Set)+import GHC.Generics++-- | `Archetype` ID.+newtype ArchetypeID = ArchetypeID+ { -- | Unique integer identifier.+ unArchetypeId :: Int+ }+ deriving newtype (Eq, Ord, Show)++-- | Node in `Archetypes`.+data Node (m :: Type -> Type) = Node+ { -- | Unique set of `ComponentID`s of this `Node`.+ nodeComponentIds :: !(Set ComponentID),+ -- | `Archetype` of this `Node`.+ nodeArchetype :: !(Archetype m)+ }+ deriving (Show, Generic)++-- | `Archetype` map.+data Archetypes (m :: Type -> Type) = Archetypes+ { -- | Archetype nodes in the map.+ nodes :: !(Map ArchetypeID (Node m)),+ -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.+ archetypeIds :: !(Map (Set ComponentID) ArchetypeID),+ -- | Next unique `ArchetypeID`.+ nextArchetypeId :: !ArchetypeID,+ -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.+ componentIds :: !(Map ComponentID (Set ArchetypeID))+ }+ deriving (Show, Generic)
src/Aztecs/ECS/World/Bundle.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -16,59 +18,60 @@ -- Stability : provisional -- Portability : non-portable (GHC extensions) module Aztecs.ECS.World.Bundle- ( Bundle (..),- MonoidBundle (..),+ ( BundleT (..),+ Bundle, MonoidDynamicBundle (..),+ bundle,+ bundleUntracked, runBundle, ) where +import Aztecs.ECS.Access.Internal (Access) import Aztecs.ECS.Component import Aztecs.ECS.Entity import Aztecs.ECS.World.Archetype-import Aztecs.ECS.World.Bundle.Class import Aztecs.ECS.World.Bundle.Dynamic import Aztecs.ECS.World.Components import qualified Aztecs.ECS.World.Components as CS+import Control.Monad.Identity import Data.Set (Set) import qualified Data.Set as Set -- | Bundle of components.------ @since 0.9-newtype Bundle = Bundle+newtype BundleT m = BundleT { -- | Unwrap the bundle.- --- -- @since 0.9- unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)+ unBundle :: Components -> (Set ComponentID, Components, DynamicBundle m) } --- | @since 0.9-instance Monoid Bundle where- mempty = Bundle (Set.empty,,mempty)+-- | Pure bundle of components.+type Bundle = BundleT Identity --- | @since 0.9-instance Semigroup Bundle where- Bundle b1 <> Bundle b2 = Bundle $ \cs ->+instance (Monad m) => Monoid (BundleT m) where+ mempty = BundleT (Set.empty,,mempty)++instance (Monad m) => Semigroup (BundleT m) where+ BundleT b1 <> BundleT b2 = BundleT $ \cs -> let (cIds1, cs', d1) = b1 cs (cIds2, cs'', d2) = b2 cs' in (cIds1 <> cIds2, cs'', d1 <> d2) --- | @since 0.9-instance MonoidBundle Bundle where- bundle :: forall a. (Component a) => a -> Bundle- bundle a = Bundle $ \cs ->- let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', dynBundle cId a)+bundle :: forall m a. (Component m a) => a -> BundleT m+bundle a = BundleT $ \cs ->+ let (cId, cs') = CS.insert @a @m cs in (Set.singleton cId, cs', dynBundle @m cId a) --- | @since 0.9-instance MonoidDynamicBundle Bundle where- dynBundle cId c = Bundle (Set.singleton cId,,dynBundle cId c)+-- | Create a bundle that inserts without running lifecycle hooks.+bundleUntracked :: forall m a. (Component m a) => a -> BundleT m+bundleUntracked a = BundleT $ \cs ->+ let (cId, cs') = CS.insert @a @m cs in (Set.singleton cId, cs', dynBundleUntracked @m cId a) +instance (Monad m) => MonoidDynamicBundle m (BundleT m) where+ dynBundle cId c = BundleT (Set.singleton cId,,dynBundle @m cId c)+ dynBundleUntracked cId c = BundleT (Set.singleton cId,,dynBundleUntracked @m cId c)+ -- | Insert a bundle of components into an archetype.------ @since 0.9-runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype)+runBundle :: (Monad m) => BundleT m -> Components -> EntityID -> Archetype m -> (Components, Archetype m, Access m ()) runBundle b cs eId arch = let !(_, cs', d) = unBundle b cs- !arch' = runDynamicBundle d eId arch- in (cs', arch')+ !(arch', hook) = runDynamicBundle d eId arch+ in (cs', arch', hook)
− src/Aztecs/ECS/World/Bundle/Class.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---- |--- Module : Aztecs.ECS.World.Bundle.Class--- 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.Class (MonoidBundle (..)) where--import Aztecs.ECS.Component---- | Monoid bundle of components.------ @since 0.9-class (Monoid a) => MonoidBundle a where- -- | Add a component to the bundle.- --- -- @since 0.9- bundle :: forall c. (Component c) => c -> a
src/Aztecs/ECS/World/Bundle/Dynamic.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ -- | -- Module : Aztecs.ECS.World.Bundle.Dynamic -- Copyright : (c) Matt Hunzinger, 2025@@ -8,23 +12,28 @@ -- 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.------ @since 0.9-newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}+newtype DynamicBundle m = DynamicBundle+ { -- | Insert components into an archetype.+ runDynamicBundle :: EntityID -> Archetype m -> (Archetype m, Access m ())+ } --- | @since 0.9-instance Semigroup DynamicBundle where- DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch)+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) --- | @since 0.9-instance Monoid DynamicBundle where- mempty = DynamicBundle $ \_ arch -> arch+instance (Monad m) => Monoid (DynamicBundle m) where+ mempty = DynamicBundle (\_ arch -> (arch, return ())) --- | @since 0.9-instance MonoidDynamicBundle DynamicBundle where- dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch+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 ()))
src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ -- | -- Module : Aztecs.ECS.World.Bundle.Dynamic.Class -- Copyright : (c) Matt Hunzinger, 2025@@ -11,10 +15,9 @@ import Aztecs.ECS.Component -- | Monoid bundle of dynamic components.------ @since 0.9-class MonoidDynamicBundle a where+class MonoidDynamicBundle m a where -- | Add a component to the bundle by its `ComponentID`.- --- -- @since 0.9- dynBundle :: (Component c) => ComponentID -> c -> a+ dynBundle :: (Component m c) => ComponentID -> c -> a++ -- | Add a component to the bundle by its `ComponentID` without running lifecycle hooks.+ dynBundleUntracked :: (Component m c) => ComponentID -> c -> a
src/Aztecs/ECS/World/Components.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -24,30 +22,12 @@ where import Aztecs.ECS.Component-import Data.Map.Strict (Map)+import Aztecs.ECS.World.Components.Internal (Components (..)) import qualified Data.Map.Strict as Map import Data.Typeable-import GHC.Generics import Prelude hiding (lookup) --- | Component ID map.------ @since 0.9-data Components = Components- { -- | Map of component types to identifiers.- --- -- @since 0.9- componentIds :: !(Map TypeRep ComponentID),- -- | Next unique component identifier.- --- -- @since 0.9- nextComponentId :: !ComponentID- }- deriving (Show, Generic)- -- | Empty `Components`.------ @since 0.9 empty :: Components empty = Components@@ -56,23 +36,17 @@ } -- | Lookup a component ID by type.------ @since 0.9 lookup :: forall a. (Typeable a) => Components -> Maybe ComponentID lookup cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs) -- | Insert a component ID by type, if it does not already exist.------ @since 0.9-insert :: forall a. (Component a) => Components -> (ComponentID, Components)+insert :: forall a m. (Component m a) => Components -> (ComponentID, Components) insert cs = case lookup @a cs of Just cId -> (cId, cs)- Nothing -> insert' @a cs+ Nothing -> insert' @a @m cs -- | Insert a component ID by type.------ @since 0.9-insert' :: forall c. (Component c) => Components -> (ComponentID, Components)+insert' :: forall c m. (Component m c) => Components -> (ComponentID, Components) insert' cs = let !cId = nextComponentId cs in ( cId,
+ src/Aztecs/ECS/World/Components/Internal.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module : Aztecs.ECS.World.Components.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.Components.Internal (Components (..)) where++import Aztecs.ECS.Component.Internal+import Data.Map.Strict (Map)+import Data.Typeable+import GHC.Generics++-- | Component ID map.+data Components = Components+ { -- | Map of component types to identifiers.+ componentIds :: !(Map TypeRep ComponentID),+ -- | Next unique component identifier.+ nextComponentId :: !ComponentID+ }+ deriving (Show, Generic)
src/Aztecs/ECS/World/Entities.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -20,6 +18,7 @@ spawnWithArchetypeId, insert, insertDyn,+ insertUntracked, lookup, remove, removeWithId,@@ -27,49 +26,27 @@ ) 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, Archetypes, Node (..))+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 Aztecs.ECS.World.Components (Components (..)) 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 Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set-import GHC.Generics import Prelude hiding (lookup) --- | World of entities and their components.------ @since 0.9-data Entities = Entities- { -- | Archetypes.- --- -- @since 0.9- archetypes :: !Archetypes,- -- | Components.- --- -- @since 0.9- components :: !Components,- -- | Entities and their archetype identifiers.- --- -- @since 0.9- entities :: !(Map EntityID ArchetypeID)- }- deriving (Show, Generic)- -- | Empty `World`.------ @since 0.9-empty :: Entities+empty :: Entities m empty = Entities { archetypes = AS.empty,@@ -77,117 +54,122 @@ entities = mempty } --- | Spawn a `Bundle`.------ @since 0.9-spawn :: EntityID -> Bundle -> Entities -> Entities+-- | 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 -> fromMaybe w $ do- node <- AS.lookup aId $ archetypes w- let arch' =- runDynamicBundle- dynB- eId- ( (nodeArchetype node)- { A.entities = Set.insert eId . A.entities $ nodeArchetype node- }- )- return- 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)- }+ 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' = runDynamicBundle dynB eId $ A.singleton eId+ 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'- }+ in ( w+ { archetypes = arches,+ entities = Map.insert eId aId (entities w),+ components = components'+ },+ hook+ ) --- | Spawn a `DynamicBundle` with a specified `ArchetypeID`.------ @since 0.9+-- | Spawn a `DynamicBundle` with a specified `ArchetypeID`. Returns the updated entities and the onInsert hook. spawnWithArchetypeId ::+ (Monad m) => EntityID -> ArchetypeID ->- DynamicBundle ->- Entities ->- Entities+ DynamicBundle m ->+ Entities m ->+ (Entities m, Access m ()) spawnWithArchetypeId e aId b w =- let f n = n {nodeArchetype = runDynamicBundle b e ((nodeArchetype n) {A.entities = Set.insert e . A.entities $ nodeArchetype n})}- in w- { archetypes = (archetypes w) {AS.nodes = Map.adjust f aId (AS.nodes $ archetypes w)},- entities = Map.insert e aId (entities 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.------ @since 0.9-insert :: EntityID -> Bundle -> Entities -> Entities+-- | 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`.------ @since 0.9-insertDyn :: EntityID -> Set ComponentID -> DynamicBundle -> Entities -> Entities+-- | 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) = AS.insert e aId cIds b $ archetypes w+ 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}+ 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 = runDynamicBundle b e $ A.singleton e+ 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)}+ 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.------ @since 0.9-lookup :: forall a. (Component a) => EntityID -> Entities -> Maybe a+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 --- | Insert a component into an entity.------ @since 0.9-remove :: forall a. (Component a) => EntityID -> Entities -> (Maybe a, Entities)+-- | 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 (components w)- in removeWithId @a e cId w {components = components'}+ 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`.------ @since 0.9-removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> Entities -> (Maybe a, Entities)+-- | 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) = AS.remove @a e aId cId $ archetypes w+ 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})- Nothing -> (Nothing, w)+ in (maybeA, w {archetypes = as, entities = es}, hook)+ Nothing -> (Nothing, w, return ()) -- | Despawn an entity, returning its components.------ @since 0.9-despawn :: EntityID -> Entities -> (IntMap Dynamic, Entities)+despawn :: EntityID -> Entities m -> (IntMap Dynamic, Entities m) despawn e w = let res = do !aId <- Map.lookup e $ entities w
+ src/Aztecs/ECS/World/Entities/Internal.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module : Aztecs.ECS.World.Entities.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.Entities.Internal (Entities (..)) where++import Aztecs.ECS.Entity (EntityID)+import Aztecs.ECS.World.Archetypes.Internal (ArchetypeID, Archetypes)+import Aztecs.ECS.World.Components.Internal (Components)+import Data.Map (Map)+import GHC.Generics++-- | World of entities and their components.+data Entities m = Entities+ { -- | Archetypes.+ archetypes :: !(Archetypes m),+ -- | Components.+ components :: !Components,+ -- | Entities and their archetype identifiers.+ entities :: !(Map EntityID ArchetypeID)+ }+ deriving (Show, Generic)
+ src/Aztecs/ECS/World/Internal.hs view
@@ -0,0 +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))+ }
+ src/Aztecs/ECS/World/Observers.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module : Aztecs.ECS.World.Observers+-- 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.Observers+ ( ObserverID (..),+ Observers (..),+ EntityObservers (..),+ DynamicObserver (..),+ empty,+ insertEntityObserver,+ insertEventObserver,+ addEntityObserver,+ addGlobalObserver,+ lookupEntityObservers,+ lookupGlobalObservers,+ lookupCallback,+ removeObserver,+ )+where++import Aztecs.ECS.Entity+import Aztecs.ECS.World.Observers.Internal+import Data.Dynamic+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Typeable++-- | Empty `Observers`.+empty :: Observers m+empty =+ Observers+ { entityObservers' = mempty,+ globalObservers = mempty,+ observerCallbacks = mempty,+ nextObserverId = ObserverID 0+ }++-- | Insert an entity observer callback.+insertEntityObserver ::+ forall e m.+ (Typeable e, Monad m) =>+ (EntityID -> e -> m ()) ->+ Observers m ->+ (ObserverID, Observers m)+insertEntityObserver callback os =+ let !oId = nextObserverId os+ dynCallback eId dyn = case fromDynamic dyn of+ Just evt -> callback eId evt+ Nothing -> pure ()+ in ( oId,+ os+ { observerCallbacks = Map.insert oId (DynEntityObserver dynCallback) (observerCallbacks os),+ nextObserverId = ObserverID (unObserverId oId + 1)+ }+ )++-- | Insert an event observer callback.+insertEventObserver ::+ forall e m.+ (Typeable e, Monad m) =>+ (e -> m ()) ->+ Observers m ->+ (ObserverID, Observers m)+insertEventObserver callback os =+ let !oId = nextObserverId os+ dynCallback dyn = case fromDynamic dyn of+ Just evt -> callback evt+ Nothing -> pure ()+ in ( oId,+ os+ { observerCallbacks = Map.insert oId (DynEventObserver dynCallback) (observerCallbacks os),+ nextObserverId = ObserverID (unObserverId oId + 1)+ }+ )++-- | Add an observer to a specific entity for a given event type.+addEntityObserver :: forall m e. (Typeable e) => EntityID -> ObserverID -> Observers m -> Observers m+addEntityObserver e oId os =+ let eventTypeRep = typeOf (Proxy @e)+ updateEntityObs Nothing =+ Just $ EntityObservers {eventObservers = Map.singleton eventTypeRep (Set.singleton oId)}+ updateEntityObs (Just eo) =+ Just $ eo {eventObservers = Map.insertWith Set.union eventTypeRep (Set.singleton oId) (eventObservers eo)}+ in os {entityObservers' = Map.alter updateEntityObs e (entityObservers' os)}++-- | Add a global observer for a given event type.+addGlobalObserver :: forall m e. (Typeable e) => ObserverID -> Observers m -> Observers m+addGlobalObserver oId os =+ let eventTypeRep = typeOf (Proxy @e)+ in os {globalObservers = Map.insertWith Set.union eventTypeRep (Set.singleton oId) (globalObservers os)}++-- | Lookup all observer IDs for an entity and event type.+lookupEntityObservers :: TypeRep -> EntityID -> Observers m -> Set.Set ObserverID+lookupEntityObservers eventTypeRep e os =+ case Map.lookup e (entityObservers' os) of+ Just eo -> Map.findWithDefault Set.empty eventTypeRep (eventObservers eo)+ Nothing -> Set.empty++-- | Lookup all global observer IDs for an event type.+lookupGlobalObservers :: TypeRep -> Observers m -> Set.Set ObserverID+lookupGlobalObservers eventTypeRep os = Map.findWithDefault Set.empty eventTypeRep (globalObservers os)++-- | Lookup an observer callback by ID.+lookupCallback :: ObserverID -> Observers m -> Maybe (DynamicObserver m)+lookupCallback oId os = Map.lookup oId (observerCallbacks os)++-- | Remove an observer by ID.+removeObserver :: ObserverID -> Observers m -> Observers m+removeObserver oId os =+ os+ { observerCallbacks = Map.delete oId (observerCallbacks os),+ entityObservers' = Map.map removeFromEntity (entityObservers' os),+ globalObservers = Map.map (Set.delete oId) (globalObservers os)+ }+ where+ removeFromEntity eo = eo {eventObservers = Map.map (Set.delete oId) (eventObservers eo)}
+ src/Aztecs/ECS/World/Observers/Internal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Aztecs.ECS.World.Observers.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.Observers.Internal+ ( ObserverID (..),+ Observers (..),+ EntityObservers (..),+ DynamicObserver (..),+ )+where++import Aztecs.ECS.Entity+import Data.Dynamic+import Data.Map.Strict (Map)+import Data.Set (Set)+import Data.Typeable+import GHC.Generics++-- | Observer identifier+newtype ObserverID = ObserverID+ { -- | Unique integer identifier+ unObserverId :: Int+ }+ deriving (Eq, Ord, Show, Generic)++-- | Dynamic observer callback+data DynamicObserver m+ = -- | Entity observer callback+ DynEntityObserver !(EntityID -> Dynamic -> m ())+ | -- | Event observer callback+ DynEventObserver !(Dynamic -> m ())++-- | Observers for a specific entity+newtype EntityObservers = EntityObservers {eventObservers :: Map TypeRep (Set ObserverID)}+ deriving (Show, Generic, Semigroup, Monoid)++-- | Global observer storage+data Observers m = Observers+ { entityObservers' :: !(Map EntityID EntityObservers),+ globalObservers :: !(Map TypeRep (Set ObserverID)),+ observerCallbacks :: !(Map ObserverID (DynamicObserver m)),+ nextObserverId :: !ObserverID+ }
src/Aztecs/ECS/World/Storage.hs view
@@ -17,47 +17,35 @@ import Prelude hiding (map, zipWith) -- | Component storage, containing zero or many components of the same type.------ @since 0.9 class (Typeable s, Typeable a) => Storage a s where -- | Storage with a single component.- --- -- @since 0.9 singleton :: a -> s -- | Vector of all components in the storage in ascending order.- --- -- @since 0.9 toAscVector :: s -> Vector a -- | Convert a sorted vector of components (in ascending order) into a storage.- --- -- @since 0.9 fromAscVector :: Vector a -> s -- | Map a function over all components in the storage.- --- --- -- @since 0.9 map :: (a -> a) -> s -> s -- | Map a function with some input over all components in the storage.- --- -- @since 0.9 zipWith :: (i -> a -> a) -> Vector i -> s -> (Vector a, s) -- | Map an applicative functor with some input over all components in the storage.- --- -- @since 0.9 zipWithM :: (Monad m) => (i -> a -> m a) -> Vector i -> s -> m (Vector a, s) -- | Map a function with some input over all components in the storage.- --- -- @since 0.9 zipWith_ :: (i -> a -> a) -> Vector i -> s -> s zipWith_ f is as = snd $ zipWith f is as --- | @since 0.9+ -- | Map a function with some input over all components, returning a tuple result and updated storage.+ zipWithAccum :: (i -> a -> (o, a)) -> Vector i -> s -> (Vector (o, a), s)++ -- | Map a monadic function with some input over all components, returning a tuple result and updated storage.+ zipWithAccumM :: (Monad m) => (i -> a -> m (o, a)) -> Vector i -> s -> m (Vector (o, a), s)+ instance (Typeable a) => Storage a (Vector a) where singleton a = V.singleton a {-# INLINE singleton #-}@@ -79,3 +67,15 @@ zipWithM f is as = (\as' -> (as', as')) <$> V.zipWithM f is as {-# INLINE zipWithM #-}++ zipWithAccum f is as =+ let pairs = V.zipWith f is as+ as' = V.map snd pairs+ in (pairs, as')+ {-# INLINE zipWithAccum #-}++ zipWithAccumM f is as = do+ pairs <- V.zipWithM f is as+ let as' = V.map snd pairs+ return (pairs, as')+ {-# INLINE zipWithAccumM #-}
src/Aztecs/ECS/World/Storage/Dynamic.hs view
@@ -32,34 +32,21 @@ import qualified Data.Vector as V -- | Dynamic storage of components.------ @since 0.9 data DynamicStorage = DynamicStorage { -- | Dynamic storage.- --- -- @since 0.9 storageDyn :: !Dynamic, -- | Singleton storage.- --- -- @since 0.9 singletonDyn' :: !(Dynamic -> Dynamic), -- | Convert this storage to an ascending vector.- --- -- @since 0.9 toAscVectorDyn' :: !(Dynamic -> Vector Dynamic), -- | Convert from an ascending vector.- --- -- @since 0.9 fromAscVectorDyn' :: !(Vector Dynamic -> Dynamic) } --- | @since 0.9 instance Show DynamicStorage where show s = "DynamicStorage " ++ show (storageDyn s) -- | Create a dynamic storage from a storage.------ @since 0.9 dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage dynStorage s = DynamicStorage@@ -71,19 +58,13 @@ {-# INLINE dynStorage #-} -- | Singleton dynamic storage.------ @since 0.9 singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} -- | Convert from an ascending vector.------ @since 0.9 fromAscVectorDyn :: Vector Dynamic -> DynamicStorage -> DynamicStorage fromAscVectorDyn dyns s = s {storageDyn = fromAscVectorDyn' s dyns} -- | Convert this storage to an ascending vector.------ @since 0.9 toAscVectorDyn :: DynamicStorage -> Vector Dynamic toAscVectorDyn = toAscVectorDyn' <*> storageDyn
src/Aztecs/Hierarchy.hs view
@@ -1,256 +1,217 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module : Aztecs.Asset.AssetServer--- 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)------ Hierarchical relationships.--- A `Children` component forms a one-to-many relationship with `Parent` components.-module Aztecs.Hierarchy- ( Parent (..),- Children (..),- update,- Hierarchy (..),- toList,- foldWithKey,- mapWithKey,- mapWithAccum,- hierarchy,- hierarchies,- ParentState (..),- ChildState (..),- )-where--import Aztecs.ECS-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-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Vector (Vector)-import qualified Data.Vector as V-import GHC.Generics---- | Parent component.------ @since 0.9-newtype Parent = Parent- { -- | Parent entity ID.- --- -- @since 0.9- unParent :: EntityID- }- deriving (Eq, Ord, Show, Generic)---- | @since 0.9-instance Component Parent---- | Parent internal state component.------ @since 0.9-newtype ParentState = ParentState {unParentState :: EntityID}- deriving (Show, Generic)---- | @since 0.9-instance Component ParentState---- | Children component.------ @since 0.9-newtype Children = Children {unChildren :: Set EntityID}- deriving (Eq, Ord, Show, Semigroup, Monoid, Generic)---- | @since 0.9-instance Component Children---- | Child internal state component.-newtype ChildState = ChildState {unChildState :: Set EntityID}- deriving (Show, Generic)---- | @since 0.9-instance Component ChildState---- | Update the parent-child relationships.------ @since 0.9-update ::- ( Applicative qr,- QueryReaderF qr,- DynamicQueryReaderF qr,- MonadReaderSystem qr s,- MonadAccess b m- ) =>- s (m ())-update = do- parents <- S.all $ do- entity <- Q.entity- parent <- Q.fetch- maybeParentState <- Q.fetchMaybe @_ @ParentState- return (entity, unParent parent, maybeParentState)-- children <- S.all $ do- entity <- Q.entity- cs <- Q.fetch- maybeChildState <- Q.fetchMaybe @_ @ChildState- return (entity, unChildren cs, maybeChildState)-- let go = do- mapM_- ( \(entity, parent, maybeParentState) -> case maybeParentState of- Just (ParentState parentState) -> do- when (parent /= parentState) $ do- A.insert parent . bundle $ ParentState parent-- -- Remove this entity from the previous parent's children.- maybeLastChildren <- A.lookup parentState- let lastChildren = maybe mempty unChildren maybeLastChildren- let lastChildren' = Set.filter (/= entity) lastChildren- A.insert parentState . bundle . Children $ lastChildren'-- -- 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 entity 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 entity parentChildren- )- parents- mapM_- ( \(entity, children', maybeChildState) -> case maybeChildState of- Just (ChildState childState) -> do- when (children' /= childState) $ do- A.insert entity . bundle $ ChildState children'- let added = Set.difference children' childState- removed = Set.difference childState children'- mapM_ (\e -> A.insert e . bundle . Parent $ entity) added- mapM_ (A.remove @_ @_ @Parent) removed- Nothing -> do- A.insert entity . bundle $ ChildState children'- mapM_ (\e -> A.insert e . bundle . Parent $ entity) children'- )- children- return go---- | Hierarchy of entities.------ @since 0.9-data Hierarchy a = Node- { -- | Entity ID.- --- -- @since 0.9- nodeEntityId :: EntityID,- -- | Entity components.- nodeEntity :: a,- -- | Child nodes.- --- -- @since 0.9- nodeChildren :: [Hierarchy a]- }- deriving (Functor)---- | @since 0.9-instance Foldable Hierarchy where- foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n)---- | @since 0.9-instance Traversable Hierarchy where- traverse f n =- Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n)---- | Convert a hierarchy to a vector of entity IDs and components.------ @since 0.9-toList :: Hierarchy a -> Vector (EntityID, a)-toList n = V.singleton (nodeEntityId n, nodeEntity n) <> V.concatMap toList (V.fromList $ nodeChildren n)---- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator.------ @since 0.9-foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b-foldWithKey f n b = f (nodeEntityId n) (nodeEntity n) (foldr (foldWithKey f) b (nodeChildren n))---- | Map a hierarchy with a function that takes the entity ID and entity.------ @since 0.9-mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b-mapWithKey f n =- Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n))---- | Map a hierarchy with a function that takes the entity ID, entity, and accumulator.------ @since 0.9-mapWithAccum :: (EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c-mapWithAccum f b n = case f (nodeEntityId n) (nodeEntity n) b of- (c, b') -> Node (nodeEntityId n) c (map (mapWithAccum f b') (nodeChildren n))---- | System to read a hierarchy of parents to children with the given query.------ @since 0.9-hierarchy ::- (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) =>- EntityID ->- q a ->- s (Maybe (Hierarchy a))-hierarchy e q = do- children <- S.all $ do- entity <- Q.entity- cs <- Q.fetch- a <- q- return (entity, (unChildren cs, a))-- let childMap = Map.fromList $ V.toList children- return $ hierarchy' e childMap---- | Build all hierarchies of parents to children, joined with the given query.------ @since 0.9-hierarchies ::- (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) =>- q a ->- s (Vector (Hierarchy a))-hierarchies q = do- children <-- S.all- ( do- entity <- Q.entity- cs <- Q.fetch- a <- q- return (entity, (unChildren cs, a))- )-- let childMap = Map.fromList $ V.toList children- roots <- S.filter Q.entity $ with @Children <> without @Parent- return $ V.mapMaybe (`hierarchy'` childMap) roots---- | Build a hierarchy of parents to children.------ @since 0.9-hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)-hierarchy' e childMap = case Map.lookup e childMap of- Just (cs, a) ->- let bs = mapMaybe (`hierarchy'` childMap) (Set.toList cs)- in Just- Node- { nodeEntityId = e,- nodeEntity = a,- nodeChildren = bs- }- Nothing -> Nothing+{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.Asset.AssetServer +-- 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) +-- +-- Hierarchical relationships. +-- A `Children` component forms a one-to-many relationship with `Parent` components. +module Aztecs.Hierarchy + ( Parent (..), + Children (..), + update, + Hierarchy (..), + toList, + foldWithKey, + mapWithKey, + mapWithAccum, + hierarchy, + hierarchies, + ParentState (..), + ChildState (..), + ) +where + +import Aztecs.ECS +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 +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics + +-- | Parent component. +newtype Parent = Parent + { -- | Parent entity ID. + unParent :: EntityID + } + deriving (Eq, Ord, Show, Generic) + +instance (Monad m) => Component m Parent + +-- | Parent internal state component. +newtype ParentState = ParentState {unParentState :: EntityID} + deriving (Show, Generic) + +instance (Monad m) => Component m ParentState + +-- | 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 + entity <- Q.entity + parent <- Q.query + maybeParentState <- Q.queryMaybe @_ @ParentState + return (entity, unParent parent, maybeParentState) + + children <- A.system . S.readQuery $ do + entity <- Q.entity + cs <- Q.query + maybeChildState <- Q.queryMaybe @_ @ChildState + return (entity, unChildren cs, maybeChildState) + + let go = do + mapM_ + ( \(entity, parent, maybeParentState) -> case maybeParentState of + Just (ParentState parentState) -> do + when (parent /= parentState) $ do + A.insert parent . bundle $ ParentState parent + + -- Remove this entity from the previous parent's children. + maybeLastChildren <- A.lookup parentState + let lastChildren = maybe mempty unChildren maybeLastChildren + let lastChildren' = Set.filter (/= entity) lastChildren + A.insert parentState . bundle . Children $ lastChildren' + + -- 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 entity 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 entity parentChildren + ) + parents + mapM_ + ( \(entity, children', maybeChildState) -> case maybeChildState of + Just (ChildState childState) -> do + when (children' /= childState) $ do + A.insert entity . bundle $ ChildState children' + let added = Set.difference children' childState + removed = Set.difference childState children' + mapM_ (\e -> A.insert e . bundle . Parent $ entity) added + mapM_ (A.remove @_ @Parent) removed + Nothing -> do + A.insert entity . bundle $ ChildState children' + mapM_ (\e -> A.insert e . bundle . Parent $ entity) children' + ) + children + go + +-- | Hierarchy of entities. +data Hierarchy a = Node + { -- | Entity ID. + nodeEntityId :: EntityID, + -- | Entity components. + nodeEntity :: a, + -- | Child nodes. + nodeChildren :: [Hierarchy a] + } + deriving (Functor) + +instance Foldable Hierarchy where + foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n) + +instance Traversable Hierarchy where + traverse f n = + Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n) + +-- | Convert a hierarchy to a vector of entity IDs and components. +toList :: Hierarchy a -> Vector (EntityID, a) +toList n = V.singleton (nodeEntityId n, nodeEntity n) <> V.concatMap toList (V.fromList $ nodeChildren n) + +-- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator. +foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b +foldWithKey f n b = f (nodeEntityId n) (nodeEntity n) (foldr (foldWithKey f) b (nodeChildren n)) + +-- | Map a hierarchy with a function that takes the entity ID and entity. +mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b +mapWithKey f n = + Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n)) + +-- | Map a hierarchy with a function that takes the entity ID, entity, and accumulator. +mapWithAccum :: (EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c +mapWithAccum f b n = case f (nodeEntityId n) (nodeEntity n) b of + (c, b') -> Node (nodeEntityId n) c (map (mapWithAccum f b') (nodeChildren n)) + +-- | System to read a hierarchy of parents to children with the given query. +hierarchy :: + (Monad m) => + EntityID -> + Query m a -> + Access m (Maybe (Hierarchy a)) +hierarchy e q = do + children <- A.system . S.readQuery $ do + entity <- Q.entity + cs <- Q.query + a <- q + return (entity, (unChildren cs, a)) + + let childMap = Map.fromList $ V.toList children + return $ hierarchy' e childMap + +-- | Build all hierarchies of parents to children, joined with the given query. +hierarchies :: + forall m a. + (Monad m) => + Query m a -> + Access m (Vector (Hierarchy a)) +hierarchies q = do + children <- + A.system . S.readQuery $ do + entity <- Q.entity + cs <- Q.query + a <- q + return (entity, (unChildren cs, a)) + + let childMap = Map.fromList $ V.toList children + roots <- A.system $ S.readQueryFiltered Q.entity (with @m @Children <> without @m @Parent) + return $ V.mapMaybe (`hierarchy'` childMap) roots + +-- | Build a hierarchy of parents to children. +hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a) +hierarchy' e childMap = case Map.lookup e childMap of + Just (cs, a) -> + let bs = mapMaybe (`hierarchy'` childMap) (Set.toList cs) + in Just + Node + { nodeEntityId = e, + nodeEntity = a, + nodeChildren = bs + } + Nothing -> Nothing
test/Main.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -22,15 +24,15 @@ newtype X = X Int deriving (Eq, Show, Arbitrary, Generic) -instance Component X+instance (Monad m) => Component m X newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic) -instance Component Y+instance (Monad m) => Component m Y newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic) -instance Component Z+instance (Monad m) => Component m Z main :: IO () main = hspec $ do@@ -55,74 +57,80 @@ prop_queryEmpty :: Expectation prop_queryEmpty =- let res = fst $ Q.all (Q.fetch @_ @X) $ W.entities W.empty in V.toList res `shouldMatchList` []+ let res =+ fst+ . runIdentity+ . Q.readQuery (Q.query @_ @X)+ $ W.entities W.empty+ in V.toList res `shouldMatchList` [] -- | Query all components from a list of `ComponentID`s. queryComponentIds ::- forall q a.- (Applicative q, DynamicQueryReaderF q, Component a) =>+ forall m q a.+ (Applicative q, DynamicQueryF m q, Component m a) => [ComponentID] -> q (EntityID, [a]) queryComponentIds = let go cId qAcc = do- x' <- Q.fetchDyn @_ @a cId+ x' <- Q.queryDyn @_ @_ @a cId (e, xs) <- qAcc return (e, x' : xs) in foldr go ((,) <$> Q.entity <*> pure []) prop_queryDyn :: [[X]] -> Expectation prop_queryDyn xs =- let spawn xs' (acc, wAcc) =- let spawn' x (bAcc, cAcc, idAcc) =- ( dynBundle (ComponentID idAcc) x <> bAcc,+ let spawner :: [X] -> ([(EntityID, [(X, ComponentID)])], World Identity) -> ([(EntityID, [(X, ComponentID)])], World Identity)+ spawner xs' (acc, wAcc) =+ let spawner' x (bAcc, cAcc, idAcc) =+ ( dynBundle @Identity (ComponentID idAcc) x <> bAcc, (x, ComponentID idAcc) : cAcc, idAcc + 1 )- (b, cs, _) = foldr spawn' (mempty, [], 0) xs'- (e, wAcc') = W.spawn b wAcc+ (b, cs, _) = foldr spawner' (mempty, [], 0) xs'+ (e, wAcc', _) = W.spawn b wAcc in ((e, cs) : acc, wAcc')- (es, w) = foldr spawn ([], W.empty) xs+ (es, w) = foldr spawner ([], W.empty) xs go (e, cs) = do- let q = queryComponentIds $ map snd cs- (res, _) = Q.all q $ W.entities w+ let q = queryComponentIds @Identity $ map snd cs+ (res, _) = runIdentity . Q.readQuery q $ W.entities w return $ V.toList res `shouldContain` [(e, map fst cs)] in mapM_ go es prop_queryTypedComponent :: [X] -> Expectation prop_queryTypedComponent xs = do- let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs- (res, _) = Q.all Q.fetch $ W.entities w+ let w = foldr (\x -> (\(_, w', _) -> w') . W.spawn (bundle x)) W.empty xs+ (res, _) = runIdentity . Q.readQuery Q.query $ W.entities w V.toList res `shouldMatchList` xs prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation prop_queryTwoTypedComponents xys = do- let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys- (res, _) = Q.all ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w+ let w = foldr (\(x, y) -> (\(_, w', _) -> w') . W.spawn (bundle x <> bundle y)) W.empty xys+ (res, _) = runIdentity $ Q.readQuery ((,) <$> Q.query <*> Q.query) $ W.entities w V.toList res `shouldMatchList` xys prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation prop_queryThreeTypedComponents xyzs = do- let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs+ let w = foldr (\(x, y, z) -> (\(_, w', _) -> w') . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs q = do- x <- Q.fetch- y <- Q.fetch- z <- Q.fetch+ x <- Q.query+ y <- Q.query+ z <- Q.query pure (x, y, z)- (res, _) = Q.all q $ W.entities w+ (res, _) = runIdentity $ Q.readQuery q $ W.entities w V.toList res `shouldMatchList` xyzs prop_querySingle :: Expectation prop_querySingle =- let (_, w) = W.spawn (bundle $ X 1) W.empty- (res, _) = Q.single Q.fetch $ W.entities w+ let (_, w, _) = W.spawn (bundle $ X 1) W.empty+ (res, _) = runIdentity $ Q.readQuerySingle Q.query $ W.entities w in res `shouldBe` X 1 prop_queryMapSingle :: Word8 -> Expectation prop_queryMapSingle n =- let (_, w) = W.spawn (bundle $ X 0) W.empty- q = Q.adjust (\_ (X x) -> X $ x + 1) (pure ())- w' = foldr (\_ es -> snd . runIdentity $ Q.mapSingle q es) (W.entities w) [1 .. n]- (res, _) = Q.single Q.fetch w'+ let (_, w, _) = W.spawn (bundle $ X 0) W.empty+ q = Q.queryMap $ \(X x) -> X $ x + 1+ w' = foldr (\_ es -> (\(_, es', _) -> es') . runIdentity $ Q.runQuerySingle q es) (W.entities w) [1 .. n]+ (res, _) = runIdentity $ Q.readQuerySingle Q.query w' in res `shouldBe` X (fromIntegral n) {-TODO@@ -133,7 +141,7 @@ s = S.mapSingle q go _ wAcc = let (_, _, wAcc') = runIdentity $ runSchedule s wAcc () in wAcc' w' = foldr go w [1 .. n]- (res, _) = Q.single () Q.fetch (W.entities w')+ (res, _) = Q.single () Q.query (W.entities w') in res `shouldBe` X (fromIntegral n) prop_addParents :: Expectation@@ -141,7 +149,7 @@ let (_, w) = W.spawnEmpty W.empty (e, w') = W.spawn (bundle . Children $ Set.singleton e) w (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()- let (res, _) = Q.all () Q.fetch $ W.entities w''+ let (res, _) = Q.all () Q.query $ W.entities w'' res `shouldMatchList` [Parent e] prop_removeParents :: Expectation@@ -151,7 +159,7 @@ (_, _, w'') <- runSchedule (system Hierarchy.update) w' () let w''' = W.insert e (Children Set.empty) w'' (_, _, w'''') <- runSchedule (system Hierarchy.update) w''' ()- let (res, _) = Q.all () (Q.fetch @_ @Parent) $ W.entities w''''+ let (res, _) = Q.all () (Q.query @_ @Parent) $ W.entities w'''' res `shouldMatchList` [] -} @@ -177,7 +185,7 @@ system $ S.mapSingle ( proc () -> do- X x <- Q.fetch -< ()+ X x <- Q.query -< () Q.set -< X $ x + 1 returnA -< x )