diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,29 +1,29 @@ -Copyright (c) 2024, Matt Hunzinger - - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of the copyright holder nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2024, Matt Hunzinger + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/aztecs.cabal b/aztecs.cabal --- a/aztecs.cabal +++ b/aztecs.cabal @@ -1,89 +1,89 @@ -cabal-version: 2.4 -name: aztecs -version: 0.11.1 -license: BSD-3-Clause -license-file: LICENSE -maintainer: matt@hunzinger.me -author: Matt Hunzinger -homepage: https://github.com/aztecs-hs/aztecs -synopsis: - A modular game engine and Entity-Component-System (ECS) for Haskell. - -description: - A modular game engine and Entity-Component-System (ECS) for Haskell. - An ECS is a modern approach to organizing your application state as a database, - providing patterns for data-oriented design and parallel processing. - Aztecs provides side-effect free components and systems, - as well as backends for rendering and input (such as `aztecs-sdl`), - allowing you to structure your game as simple function of `Input -> World -> World`. - -category: Game Engine - -source-repository head - type: git - location: https://github.com/aztecs-hs/aztecs.git - -library - exposed-modules: - Aztecs.ECS - Aztecs.ECS.Access - Aztecs.ECS.Component - Aztecs.ECS.Entity - Aztecs.ECS.Query - Aztecs.ECS.Query.Dynamic - Aztecs.ECS.System - Aztecs.ECS.View - Aztecs.ECS.World - Aztecs.ECS.World.Archetype - Aztecs.ECS.World.Archetypes - Aztecs.ECS.World.Bundle - Aztecs.ECS.World.Bundle.Dynamic - Aztecs.ECS.World.Components - Aztecs.ECS.World.Entities - Aztecs.ECS.World.Storage - Aztecs.ECS.World.Storage.Dynamic - - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >=4.2 && <5, - containers >=0.6, - deepseq >=1, - mtl >=2, - stm >=2 - -executable ecs - main-is: examples/ECS.hs - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base, - aztecs, - deepseq >=1 - -test-suite aztecs-test - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >=4.2 && <5, - aztecs, - containers >=0.6, - deepseq >=1, - hspec >=2, - QuickCheck >=2 - -benchmark aztecs-bench - type: exitcode-stdio-1.0 - main-is: Bench.hs - hs-source-dirs: bench - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >=4.2 && <5, - aztecs, - criterion >=1, - deepseq >=1 +cabal-version: 2.4 +name: aztecs +version: 0.12.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: matt@hunzinger.me +author: Matt Hunzinger +homepage: https://github.com/aztecs-hs/aztecs +synopsis: + A modular game engine and Entity-Component-System (ECS) for Haskell. + +description: + A modular game engine and Entity-Component-System (ECS) for Haskell. + An ECS is a modern approach to organizing your application state as a database, + providing patterns for data-oriented design and parallel processing. + Aztecs provides side-effect free components and systems, + as well as backends for rendering and input (such as `aztecs-sdl`), + allowing you to structure your game as simple function of `Input -> World -> World`. + +category: Game Engine + +source-repository head + type: git + location: https://github.com/aztecs-hs/aztecs.git + +library + exposed-modules: + Aztecs.ECS + Aztecs.ECS.Access + Aztecs.ECS.Component + Aztecs.ECS.Entity + Aztecs.ECS.Query + Aztecs.ECS.Query.Dynamic + Aztecs.ECS.System + Aztecs.ECS.View + Aztecs.ECS.World + Aztecs.ECS.World.Archetype + Aztecs.ECS.World.Archetypes + Aztecs.ECS.World.Bundle + Aztecs.ECS.World.Bundle.Dynamic + Aztecs.ECS.World.Components + Aztecs.ECS.World.Entities + Aztecs.ECS.World.Storage + Aztecs.ECS.World.Storage.Dynamic + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.2 && <5, + containers >=0.6, + deepseq >=1, + mtl >=2, + stm >=2 + +executable ecs + main-is: examples/ECS.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + aztecs, + deepseq >=1 + +test-suite aztecs-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.2 && <5, + aztecs, + containers >=0.6, + deepseq >=1, + hspec >=2, + QuickCheck >=2 + +benchmark aztecs-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.2 && <5, + aztecs, + criterion >=1, + deepseq >=1 diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -import Aztecs.ECS -import qualified Aztecs.ECS.Query as Q -import Aztecs.ECS.World -import qualified Aztecs.ECS.World as W -import Control.DeepSeq -import Criterion.Main -import Data.Function -import Data.Functor.Identity -import GHC.Generics - -newtype Position = Position Int deriving (Show, Generic, NFData) - -instance Component Position - -newtype Velocity = Velocity Int deriving (Show, Generic, NFData) - -instance Component Velocity - -q :: Query Position -q = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v) - -run :: World -> [Position] -run = fst . runIdentity . Q.query q . entities - -main :: IO () -main = do - let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc - !w = foldr (const go) W.empty [0 :: Int .. 10000] - defaultMain [bench "iter" $ nf run w] +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Aztecs.ECS +import qualified Aztecs.ECS.Query as Q +import Aztecs.ECS.World +import qualified Aztecs.ECS.World as W +import Control.DeepSeq +import Criterion.Main +import Data.Function +import Data.Functor.Identity +import GHC.Generics + +newtype Position = Position Int deriving (Show, Generic, NFData) + +instance Component Position + +newtype Velocity = Velocity Int deriving (Show, Generic, NFData) + +instance Component Velocity + +q :: Query Position +q = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v) + +run :: World -> [Position] +run = fst . runIdentity . Q.query q . entities + +main :: IO () +main = do + let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc + !w = foldr (const go) W.empty [0 :: Int .. 10000] + defaultMain [bench "iter" $ nf run w] diff --git a/examples/ECS.hs b/examples/ECS.hs --- a/examples/ECS.hs +++ b/examples/ECS.hs @@ -1,35 +1,30 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Main where - -import Aztecs.ECS -import Control.DeepSeq -import Control.Monad -import Control.Monad.IO.Class -import Data.Function -import GHC.Generics - -newtype Position = Position Int deriving (Show, Generic, NFData) - -instance Component Position - -newtype Velocity = Velocity Int deriving (Show, Generic, NFData) - -instance Component Velocity - -move :: (Monad m) => QueryT m Position -move = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v) - -run :: SystemT IO () -run = do - positions <- query move - liftIO $ print positions - -app :: AccessT IO () -app = do - _ <- spawn $ bundle (Position 0) <> bundle (Velocity 1) - forever $ system run - -main :: IO () -main = runAccessT_ app +module Main where + +import Aztecs.ECS +import Control.Monad +import Control.Monad.IO.Class +import Data.Function + +newtype Position = Position Int deriving (Show) + +instance Component Position + +newtype Velocity = Velocity Int + +instance Component Velocity + +move :: Query Position +move = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v) + +run :: SystemT IO () +run = do + positions <- query move + liftIO $ print positions + +app :: AccessT IO () +app = do + _ <- spawn $ bundle (Position 0) <> bundle (Velocity 1) + forever $ system run + +main :: IO () +main = runAccessT_ app diff --git a/src/Aztecs/ECS.hs b/src/Aztecs/ECS.hs --- a/src/Aztecs/ECS.hs +++ b/src/Aztecs/ECS.hs @@ -1,52 +1,58 @@ --- | 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. -module Aztecs.ECS - ( module Aztecs.ECS.System, - module Aztecs.ECS.Query, - Access, - AccessT, - runAccessT, - runAccessT_, - Bundle, - bundle, - fromDynBundle, - DynamicBundle, - dynBundle, - Component (..), - EntityID, - spawn, - system, - concurrently, - World, - ) -where - -import Aztecs.ECS.Access -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.Query hiding (query, querySingle, querySingleMaybe, readQueryEntities) -import Aztecs.ECS.System hiding (concurrently) -import Aztecs.ECS.World (World) -import Aztecs.ECS.World.Bundle -import Aztecs.ECS.World.Bundle.Dynamic +-- | 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. +module Aztecs.ECS + ( module Aztecs.ECS.System, + module Aztecs.ECS.Query, + Access, + AccessT, + runAccessT, + runAccessT_, + Bundle, + bundle, + fromDynBundle, + DynamicBundle, + dynBundle, + Component (..), + EntityID, + spawn, + system, + concurrently, + World, + ) +where + +import Aztecs.ECS.Access +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Query hiding + ( query, + querySingle, + querySingleMaybe, + readQuery, + readQueryEntities, + ) +import Aztecs.ECS.System hiding (concurrently) +import Aztecs.ECS.World (World) +import Aztecs.ECS.World.Bundle +import Aztecs.ECS.World.Bundle.Dynamic diff --git a/src/Aztecs/ECS/Access.hs b/src/Aztecs/ECS/Access.hs --- a/src/Aztecs/ECS/Access.hs +++ b/src/Aztecs/ECS/Access.hs @@ -1,150 +1,150 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.Access --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.Access - ( Access, - AccessT (..), - spawn, - insert, - lookup, - remove, - despawn, - runAccessT, - runAccessT_, - system, - concurrently, - ) -where - -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.System (SystemT (..), runSystemT) -import qualified Aztecs.ECS.System as S -import Aztecs.ECS.World (World (..)) -import qualified Aztecs.ECS.World as W -import Aztecs.ECS.World.Bundle -import Control.Concurrent.STM -import Control.DeepSeq -import Control.Monad.Fix -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State.Strict -import Prelude hiding (lookup) - --- | @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 (rnf w' `seq` w') - unAccessT $ f a' - --- | 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 - --- | 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 - --- | Spawn an entity with a `Bundle`. --- --- @since 0.11 -spawn :: (Monad m) => Bundle -> AccessT m EntityID -spawn b = AccessT $ do - !w <- get - let !(e, w') = W.spawn b w - put w' - return e - --- | Insert a `Bundle` into an entity. --- --- @since 0.11 -insert :: (Monad m) => EntityID -> Bundle -> AccessT m () -insert e c = AccessT $ do - !w <- get - let !w' = W.insert e c w - put w' - --- | Lookup a component by `EntityID`. --- --- @since 0.11 -lookup :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a) -lookup e = AccessT $ do - !w <- get - return $ W.lookup e w - --- | Remove a component by `EntityID`. --- --- @since 0.11 -remove :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a) -remove e = AccessT $ do - !w <- get - let !(a, w') = W.remove e w - put w' - return a - --- | Despawn an entity by `EntityID`. --- --- @since 0.11 -despawn :: (Monad m) => EntityID -> AccessT m () -despawn e = AccessT $ do - !w <- get - let !(_, w') = W.despawn e w - put w' - --- | Run a `System`. --- --- @since 0.11 -system :: (Monad m) => SystemT m a -> AccessT m a -system s = AccessT $ do - !w <- get - let go f = do - es <- get - let es' = f es - put es' - return es' - (a, es) <- lift $ runStateT (runSystemT s go) (entities w) - put w {entities = es} - return a - --- | Run a `System` concurrently. --- --- @since 0.11 -concurrently :: SystemT IO a -> AccessT IO a -concurrently s = AccessT $ do - !w <- get - esVar <- lift . newTVarIO $ entities w - let go f = atomically $ do - es <- readTVar esVar - let es' = f es - writeTVar esVar es' - return es' - a <- liftIO $ S.concurrently s go - es <- lift $ readTVarIO esVar - put w {entities = es} - return a +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Access +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Access + ( Access, + AccessT (..), + spawn, + insert, + lookup, + remove, + despawn, + runAccessT, + runAccessT_, + system, + concurrently, + ) +where + +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.System (SystemT (..), runSystemT) +import qualified Aztecs.ECS.System as S +import Aztecs.ECS.World (World (..)) +import qualified Aztecs.ECS.World as W +import Aztecs.ECS.World.Bundle +import Control.Concurrent.STM +import Control.DeepSeq +import Control.Monad.Fix +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State.Strict +import Prelude hiding (lookup) + +-- | @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 (rnf w' `seq` w') + unAccessT $ f a' + +-- | 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 + +-- | 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 + +-- | Spawn an entity with a `Bundle`. +-- +-- @since 0.11 +spawn :: (Monad m) => Bundle -> AccessT m EntityID +spawn b = AccessT $ do + !w <- get + let !(e, w') = W.spawn b w + put w' + return e + +-- | Insert a `Bundle` into an entity. +-- +-- @since 0.11 +insert :: (Monad m) => EntityID -> Bundle -> AccessT m () +insert e c = AccessT $ do + !w <- get + let !w' = W.insert e c w + put w' + +-- | Lookup a component by `EntityID`. +-- +-- @since 0.11 +lookup :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a) +lookup e = AccessT $ do + !w <- get + return $ W.lookup e w + +-- | Remove a component by `EntityID`. +-- +-- @since 0.11 +remove :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a) +remove e = AccessT $ do + !w <- get + let !(a, w') = W.remove e w + put w' + return a + +-- | Despawn an entity by `EntityID`. +-- +-- @since 0.11 +despawn :: (Monad m) => EntityID -> AccessT m () +despawn e = AccessT $ do + !w <- get + let !(_, w') = W.despawn e w + put w' + +-- | Run a `System`. +-- +-- @since 0.11 +system :: (Monad m) => SystemT m a -> AccessT m a +system s = AccessT $ do + !w <- get + let go f = do + es <- get + let es' = f es + put es' + return es' + (a, es) <- lift $ runStateT (runSystemT s go) (entities w) + put w {entities = es} + return a + +-- | Run a `System` concurrently. +-- +-- @since 0.11 +concurrently :: SystemT IO a -> AccessT IO a +concurrently s = AccessT $ do + !w <- get + esVar <- lift . newTVarIO $ entities w + let go f = atomically $ do + es <- readTVar esVar + let es' = f es + writeTVar esVar es' + return es' + a <- liftIO $ S.concurrently s go + es <- lift $ readTVarIO esVar + put w {entities = es} + return a diff --git a/src/Aztecs/ECS/Component.hs b/src/Aztecs/ECS/Component.hs --- a/src/Aztecs/ECS/Component.hs +++ b/src/Aztecs/ECS/Component.hs @@ -1,41 +1,41 @@ -{-# 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 Control.DeepSeq -import Data.Typeable -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, NFData) - --- | 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 = [a] +{-# 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 Control.DeepSeq +import Data.Typeable +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, NFData) + +-- | 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 = [a] diff --git a/src/Aztecs/ECS/Entity.hs b/src/Aztecs/ECS/Entity.hs --- a/src/Aztecs/ECS/Entity.hs +++ b/src/Aztecs/ECS/Entity.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Module : Aztecs.ECS.Entity --- 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.Entity (EntityID (..)) where - -import Control.DeepSeq -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, NFData) +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Aztecs.ECS.Entity +-- 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.Entity (EntityID (..)) where + +import Control.DeepSeq +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, NFData) diff --git a/src/Aztecs/ECS/Query.hs b/src/Aztecs/ECS/Query.hs --- a/src/Aztecs/ECS/Query.hs +++ b/src/Aztecs/ECS/Query.hs @@ -1,276 +1,270 @@ -{-# 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) -module Aztecs.ECS.Query - ( -- * Queries - Query, - QueryT (..), - - -- ** Operations - entity, - fetch, - fetchMap, - fetchMapM, - zipFetchMap, - zipFetchMapAccum, - zipFetchMapM, - zipFetchMapAccumM, - - -- ** Filters - with, - without, - - -- ** Running - query, - readSingle, - readSingle', - readSingleMaybe, - readSingleMaybe', - querySingle, - querySingleMaybe, - queryEntities, - readQueryEntities, - - -- ** Conversion - fromDyn, - ) -where - -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -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 Control.Monad.Identity -import GHC.Stack - --- | @since 0.11 -type Query = QueryT Identity - --- | Query for matching entities. --- --- @since 0.11 -newtype QueryT f a = Query - { -- | Run a query, producing a `DynamicQueryT`. - -- - -- @since 0.11 - runQuery :: Components -> (Components, DynamicQueryT f a) - } - deriving (Functor) - --- | @since 0.11 -instance (Applicative f) => Applicative (QueryT f) where - {-# INLINE pure #-} - pure a = Query (,pure a) - - {-# INLINE (<*>) #-} - (Query f) <*> (Query g) = Query $ \cs -> - let !(cs', aQS) = g cs - !(cs'', bQS) = f cs' - in (cs'', bQS <*> aQS) - --- | Fetch the current `EntityID`. --- --- @since 0.11 -{-# INLINE entity #-} -entity :: QueryT f EntityID -entity = Query (,entityDyn) - --- | Fetch a component. --- --- @since 0.11 -{-# INLINE fetch #-} -fetch :: forall f a. (Component a) => QueryT f a -fetch = fromDynInternal @f @a $ fetchDyn - --- | Fetch a component and map it, storing the result. --- --- @since 0.11 -{-# INLINE fetchMap #-} -fetchMap :: forall m a. (Component a) => (a -> a) -> QueryT m a -fetchMap f = fromDynInternal @_ @a $ fetchMapDyn f - --- | Fetch a component and map it with a monadic function, storing the result. --- --- @since 0.11 -{-# INLINE fetchMapM #-} -fetchMapM :: forall m a. (Monad m, Component a) => (a -> m a) -> QueryT m a -fetchMapM f = fromDynInternal @_ @a $ fetchMapDynM f - --- | Fetch a component and map it with some input, storing the result. --- --- @since 0.11 -{-# INLINE zipFetchMap #-} -zipFetchMap :: forall m a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m a -zipFetchMap f = fromWriterInternal @a $ zipFetchMapDyn f - --- | Fetch a component and map it with some input, storing the result and returning some output. --- --- @since 0.11 -{-# INLINE zipFetchMapAccum #-} -zipFetchMapAccum :: - forall m a b c. (Component a) => (b -> a -> (c, a)) -> QueryT m b -> QueryT m (c, a) -zipFetchMapAccum f = fromWriterInternal @a $ zipFetchMapAccumDyn f - --- | Fetch a component and map it with some input and a monadic function, storing the result. --- --- @since 0.11 -{-# INLINE zipFetchMapM #-} -zipFetchMapM :: forall m a b. (Monad m, Component a) => (b -> a -> m a) -> QueryT m b -> QueryT m a -zipFetchMapM f = fromWriterInternal @a $ zipFetchMapDynM f - --- | Fetch a component and map it with some input and a monadic function, --- storing the result and returning some output. --- --- @since 0.11 -{-# INLINE zipFetchMapAccumM #-} -zipFetchMapAccumM :: - forall m a b c. (Monad m, Component a) => (b -> a -> m (c, a)) -> QueryT m b -> QueryT m (c, a) -zipFetchMapAccumM f = fromWriterInternal @a $ zipFetchMapAccumDynM f - --- | Filter for entities with a component. --- --- @since 0.11 -{-# INLINE with #-} -with :: forall f a. (Component a) => QueryT f () -with = fromDynInternal @f @a $ withDyn - --- | Filter for entities without a component. --- --- @since 0.11 -{-# INLINE without #-} -without :: forall f a. (Component a) => QueryT f () -without = fromDynInternal @f @a $ withDyn - --- | Convert a `DynamicQueryT` to a `QueryT`. --- --- @since 0.11 -{-# INLINE fromDyn #-} -fromDyn :: DynamicQueryT f a -> QueryT f a -fromDyn q = Query (,q) - -{-# INLINE fromDynInternal #-} -fromDynInternal :: - forall f a b. - (Component a) => - (ComponentID -> DynamicQueryT f b) -> - QueryT f b -fromDynInternal f = Query $ \cs -> - let !(cId, cs') = CS.insert @a cs in (cs', f cId) - -{-# INLINE fromWriterInternal #-} -fromWriterInternal :: - forall c f a b. - (Component c) => - (ComponentID -> DynamicQueryT f b -> DynamicQueryT f a) -> - QueryT f b -> - QueryT f a -fromWriterInternal f q = Query $ \cs -> - let !(cId, cs') = CS.insert @c cs - !(cs'', dynQ) = runQuery q cs' - in (cs'', f cId dynQ) - --- | Match and update all entities. --- --- @since 0.11 -{-# INLINE query #-} -query :: (Monad m) => QueryT m a -> Entities -> m ([a], Entities) -query q es = do - let !(cs', dynQ) = runQuery q $ components es - (as, es') <- queryDyn dynQ es - return (as, es' {components = cs'}) - --- | Match and update a single matched entity. --- --- @since 0.11 -{-# INLINE querySingle #-} -querySingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities) -querySingle q es = do - let !(cs', dynQ) = runQuery q $ components es - (as, es') <- mapSingleDyn dynQ es - return (as, es' {components = cs'}) - --- | Match and update a single matched entity, or `Nothing`. --- --- @since 0.11 -{-# INLINE querySingleMaybe #-} -querySingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities) -querySingleMaybe q es = do - let !(cs', dynQ) = runQuery q $ components es - (as, es') <- mapSingleMaybeDyn dynQ es - return (as, es' {components = cs'}) - --- | Match and update the specified entities. --- --- @since 0.11 -queryEntities :: (Monad m) => [EntityID] -> QueryT m a -> Entities -> m ([a], Entities) -queryEntities eIds q es = do - let !(cs', dynQ) = runQuery q $ components es - (as, es') <- queryEntitiesDyn eIds dynQ es - return (as, es' {components = cs'}) - --- | Match a single entity. --- --- @since 0.11 -{-# INLINE readSingle #-} -readSingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities) -readSingle q es = do - let !(cs', dynQ) = runQuery q $ components es - as <- singleDyn dynQ es - return (as, es {components = cs'}) - --- | Match a single entity. --- --- @since 0.11 -{-# INLINE readSingle' #-} -readSingle' :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Components) -readSingle' q es = do - let !(cs', dynQ) = runQuery q $ components es - as <- singleDyn dynQ es - return (as, cs') - --- | Match a single entity, or `Nothing`. --- --- @since 0.11 -{-# INLINE readSingleMaybe #-} -readSingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities) -readSingleMaybe q es = do - let !(cs', dynQ) = runQuery q $ components es - as <- singleMaybeDyn dynQ es - return (as, es {components = cs'}) - --- | Match a single entity, or `Nothing`. --- --- @since 0.11 -{-# INLINE readSingleMaybe' #-} -readSingleMaybe' :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Components) -readSingleMaybe' q es = do - let !(cs', dynQ) = runQuery q $ components es - as <- singleMaybeDyn dynQ es - return (as, cs') - --- | Match the specified entities. --- --- @since 0.11 -readQueryEntities :: (Monad m) => [EntityID] -> QueryT m a -> Entities -> m ([a], Entities) -readQueryEntities eIds q es = do - let !(cs', dynQ) = runQuery q $ components es - as <- readQueryEntitiesDyn eIds dynQ es - return (as, es {components = cs'}) +{-# 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) +module Aztecs.ECS.Query + ( -- * Queries + Query, + QueryT (..), + + -- ** Operations + entity, + fetch, + fetchMaybe, + fetchMap, + fetchMapM, + zipFetchMap, + zipFetchMapAccum, + zipFetchMapM, + zipFetchMapAccumM, + + -- ** Filters + with, + without, + + -- ** Conversion + fromDyn, + liftQuery, + + -- ** Running + + -- *** Writing + query, + querySingle, + querySingleMaybe, + queryEntities, + + -- *** Reading + readQueryEntities, + readQuery, + readQuerySingle, + readQuerySingleMaybe, + ) +where + +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +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 Control.Monad.Identity +import Control.Monad.Trans +import GHC.Stack + +-- | @since 0.11 +type Query = QueryT Identity + +-- | Query for matching entities. +-- +-- @since 0.11 +newtype QueryT f a = Query + { -- | Run a query, producing a `DynamicQueryT`. + -- + -- @since 0.11 + runQuery :: Components -> (Components, DynamicQueryT f a) + } + deriving (Functor) + +-- | @since 0.11 +instance (Applicative f) => Applicative (QueryT f) where + {-# INLINE pure #-} + pure a = Query (,pure a) + + {-# INLINE (<*>) #-} + (Query f) <*> (Query g) = Query $ \cs -> + let !(cs', aQS) = g cs + !(cs'', bQS) = f cs' + in (cs'', bQS <*> aQS) + +-- | Fetch the current `EntityID`. +-- +-- @since 0.11 +{-# INLINE entity #-} +entity :: QueryT f EntityID +entity = Query (,entityDyn) + +-- | Fetch a component. +-- +-- @since 0.11 +{-# INLINE fetch #-} +fetch :: forall f a. (Component a) => QueryT f a +fetch = fromDynInternal @f @a $ fetchDyn + +-- | Fetch a component, or `Nothing`. +-- +-- @since 0.12 +{-# INLINE fetchMaybe #-} +fetchMaybe :: forall f a. (Component a) => QueryT f (Maybe a) +fetchMaybe = fromDynInternal @f @a $ fetchMaybeDyn + +-- | Fetch a component and map it, storing the result. +-- +-- @since 0.11 +{-# INLINE fetchMap #-} +fetchMap :: forall f a. (Component a) => (a -> a) -> QueryT f a +fetchMap f = fromDynInternal @_ @a $ fetchMapDyn f + +-- | Fetch a component and map it with a monadic function, storing the result. +-- +-- @since 0.11 +{-# INLINE fetchMapM #-} +fetchMapM :: forall f a. (Monad f, Component a) => (a -> f a) -> QueryT f a +fetchMapM f = fromDynInternal @_ @a $ fetchMapDynM f + +-- | Fetch a component and map it with some input, storing the result. +-- +-- @since 0.11 +{-# INLINE zipFetchMap #-} +zipFetchMap :: forall f a b. (Component a) => (b -> a -> a) -> QueryT f b -> QueryT f a +zipFetchMap f = fromWriterInternal @a $ zipFetchMapDyn f + +-- | Fetch a component and map it with some input, storing the result and returning some output. +-- +-- @since 0.11 +{-# INLINE zipFetchMapAccum #-} +zipFetchMapAccum :: + forall f a b c. (Component a) => (b -> a -> (c, a)) -> QueryT f b -> QueryT f (c, a) +zipFetchMapAccum f = fromWriterInternal @a $ zipFetchMapAccumDyn f + +-- | Fetch a component and map it with some input and a monadic function, storing the result. +-- +-- @since 0.11 +{-# INLINE zipFetchMapM #-} +zipFetchMapM :: forall f a b. (Monad f, Component a) => (b -> a -> f a) -> QueryT f b -> QueryT f a +zipFetchMapM f = fromWriterInternal @a $ zipFetchMapDynM f + +-- | Fetch a component and map it with some input and a monadic function, +-- storing the result and returning some output. +-- +-- @since 0.11 +{-# INLINE zipFetchMapAccumM #-} +zipFetchMapAccumM :: + forall f a b c. (Monad f, Component a) => (b -> a -> f (c, a)) -> QueryT f b -> QueryT f (c, a) +zipFetchMapAccumM f = fromWriterInternal @a $ zipFetchMapAccumDynM f + +-- | Filter for entities with a component. +-- +-- @since 0.11 +{-# INLINE with #-} +with :: forall f a. (Component a) => QueryT f () +with = fromDynInternal @f @a $ withDyn + +-- | Filter for entities without a component. +-- +-- @since 0.11 +{-# INLINE without #-} +without :: forall f a. (Component a) => QueryT f () +without = fromDynInternal @f @a $ withDyn + +-- | Convert a `DynamicQueryT` to a `QueryT`. +-- +-- @since 0.11 +{-# INLINE fromDyn #-} +fromDyn :: DynamicQueryT f a -> QueryT f a +fromDyn q = Query (,q) + +{-# INLINE fromDynInternal #-} +fromDynInternal :: + forall f a b. + (Component a) => + (ComponentID -> DynamicQueryT f b) -> + QueryT f b +fromDynInternal f = Query $ \cs -> + let !(cId, cs') = CS.insert @a cs in (cs', f cId) + +{-# INLINE fromWriterInternal #-} +fromWriterInternal :: + forall c f a b. + (Component c) => + (ComponentID -> DynamicQueryT f b -> DynamicQueryT f a) -> + QueryT f b -> + QueryT f a +fromWriterInternal f q = Query $ \cs -> + let !(cId, cs') = CS.insert @c cs + !(cs'', dynQ) = runQuery q cs' + in (cs'', f cId dynQ) + +liftQuery :: (MonadTrans g, Monad (g f), Monad f) => QueryT f a -> QueryT (g f) a +liftQuery q = Query $ \cs -> let !(cs', dynQ) = runQuery q cs in (cs', liftQueryDyn dynQ) + +-- | Match and update all entities. +-- +-- @since 0.11 +{-# INLINE query #-} +query :: (Applicative f) => QueryT f a -> Entities -> f ([a], Entities) +query = runQueryWithDyn queryDyn + +-- | Match and update a single matched entity. +-- +-- @since 0.12 +{-# INLINE querySingle #-} +querySingle :: (HasCallStack, Applicative f) => QueryT f a -> Entities -> f (a, Entities) +querySingle = runQueryWithDyn querySingleDyn + +-- | Match and update a single matched entity, or `Nothing`. +-- +-- @since 0.12 +{-# INLINE querySingleMaybe #-} +querySingleMaybe :: (Applicative m) => QueryT m a -> Entities -> m (Maybe a, Entities) +querySingleMaybe = runQueryWithDyn querySingleMaybeDyn + +-- | Match and update the specified entities. +-- +-- @since 0.12 +{-# INLINE queryEntities #-} +queryEntities :: (Monad m) => [EntityID] -> QueryT m a -> Entities -> m ([a], Entities) +queryEntities eIds = runQueryWithDyn $ queryEntitiesDyn eIds + +-- | Match and update all entities. +-- +-- @since 0.12 +{-# INLINE readQuery #-} +readQuery :: (Applicative f) => QueryT f a -> Entities -> f ([a], Entities) +readQuery = runQueryWithDyn $ \q es -> (,es) <$> readQueryDyn q es + +-- | Match a single entity. +-- +-- @since 0.12 +{-# INLINE readQuerySingle #-} +readQuerySingle :: (HasCallStack, Applicative f) => QueryT f a -> Entities -> f (a, Entities) +readQuerySingle = runQueryWithDyn $ \q es -> (,es) <$> readQuerySingleDyn q es + +-- | Match a single entity, or `Nothing`. +-- +-- @since 0.12 +{-# INLINE readQuerySingleMaybe #-} +readQuerySingleMaybe :: (Applicative f) => QueryT f a -> Entities -> f (Maybe a, Entities) +readQuerySingleMaybe = runQueryWithDyn $ \q es -> (,es) <$> readQuerySingleMaybeDyn q es + +-- | Match the specified entities. +-- +-- @since 0.12 +{-# INLINE readQueryEntities #-} +readQueryEntities :: (Applicative f) => [EntityID] -> QueryT f a -> Entities -> f ([a], Entities) +readQueryEntities eIds = runQueryWithDyn $ \q es -> (,es) <$> readQueryEntitiesDyn eIds q es + +{-# INLINE runQueryWithDyn #-} +runQueryWithDyn :: + (Applicative f) => + (DynamicQueryT f a -> Entities -> b) -> + QueryT f a -> + Entities -> + b +runQueryWithDyn f q es = + let !(cs', dynQ) = runQuery q $ components es in f dynQ es {components = cs'} diff --git a/src/Aztecs/ECS/Query/Dynamic.hs b/src/Aztecs/ECS/Query/Dynamic.hs --- a/src/Aztecs/ECS/Query/Dynamic.hs +++ b/src/Aztecs/ECS/Query/Dynamic.hs @@ -1,512 +1,502 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.Query.Dynamic --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.Query.Dynamic - ( -- * Dynamic queries - DynamicQuery, - DynamicQueryT (..), - - -- ** Operations - entityDyn, - fetchDyn, - fetchMaybeDyn, - fetchMapDyn, - fetchMapDynM, - zipFetchMapDyn, - zipFetchMapAccumDyn, - zipFetchMapDynM, - zipFetchMapAccumDynM, - - -- ** Filters - withDyn, - withoutDyn, - - -- ** Running - queryDyn, - singleDyn, - singleMaybeDyn, - queryEntitiesDyn, - readQueryDyn, - mapSingleDyn, - mapSingleMaybeDyn, - readQueryEntitiesDyn, - - -- *** Internal - QueryFilter (..), - queryFilter, - runDynQuery, - runDynQueryEntities, - readDynQuery, - readDynQueryEntities, - ) -where - -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Archetype (Archetype) -import qualified Aztecs.ECS.World.Archetype as A -import Aztecs.ECS.World.Archetypes (ArchetypeID, Node (..)) -import qualified Aztecs.ECS.World.Archetypes as AS -import Aztecs.ECS.World.Entities -import Control.Applicative -import Control.Monad -import Control.Monad.Identity (Identity) -import Data.Bifunctor -import Data.Foldable -import Data.Map (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import GHC.Stack -import Prelude hiding (reads) - -data Operation f a where - Entity :: Operation f EntityID - Fetch :: (Component a) => !ComponentID -> Operation f a - FetchMaybe :: (Component a) => !ComponentID -> Operation f (Maybe a) - FetchMap :: (Component a) => !(a -> a) -> !ComponentID -> Operation f a - FetchMapM :: (Monad f, Component a) => !(a -> f a) -> !ComponentID -> Operation f a - Adjust :: (Component a) => !(b -> a -> (c, a)) -> !ComponentID -> !(DynamicQueryT f b) -> Operation f (c, a) - AdjustM :: (Monad f, Component a) => !(b -> a -> f (c, a)) -> !ComponentID -> !(DynamicQueryT f b) -> Operation f (c, a) - With :: !ComponentID -> Operation f () - Without :: !ComponentID -> Operation f () - --- @since 0.9 -type DynamicQuery = DynamicQueryT Identity - --- | Dynamic query for components by ID. --- --- @since 0.11 -data DynamicQueryT f a where - Pure :: !a -> DynamicQueryT f a - Map :: !(a -> b) -> !(DynamicQueryT f a) -> DynamicQueryT f b - Ap :: !(DynamicQueryT f (a -> b)) -> !(DynamicQueryT f a) -> DynamicQueryT f b - Op :: !(Operation f a) -> DynamicQueryT f a - -instance Functor (DynamicQueryT f) where - {-# INLINE fmap #-} - fmap = Map - --- | @since 0.11 -instance Applicative (DynamicQueryT f) where - {-# INLINE pure #-} - pure = Pure - - {-# INLINE (<*>) #-} - (<*>) = Ap - -{-# INLINE entityDyn #-} -entityDyn :: DynamicQueryT f EntityID -entityDyn = Op Entity - -{-# INLINE fetchDyn #-} -fetchDyn :: (Component a) => ComponentID -> DynamicQueryT f a -fetchDyn = Op . Fetch - -{-# INLINE fetchMaybeDyn #-} -fetchMaybeDyn :: (Component a) => ComponentID -> DynamicQueryT f (Maybe a) -fetchMaybeDyn = Op . FetchMaybe - -{-# INLINE fetchMapDyn #-} -fetchMapDyn :: (Component a) => (a -> a) -> ComponentID -> DynamicQueryT f a -fetchMapDyn f = Op . FetchMap f - -{-# INLINE fetchMapDynM #-} -fetchMapDynM :: (Monad f, Component a) => (a -> f a) -> ComponentID -> DynamicQueryT f a -fetchMapDynM f = Op . FetchMapM f - -{-# INLINE zipFetchMapDyn #-} -zipFetchMapDyn :: (Component a) => (b -> a -> a) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f a -zipFetchMapDyn f cId q = snd <$> Op (Adjust (\b a -> ((), f b a)) cId q) - -{-# INLINE zipFetchMapAccumDyn #-} -zipFetchMapAccumDyn :: (Component a) => (b -> a -> (c, a)) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f (c, a) -zipFetchMapAccumDyn f cId q = Op $ Adjust f cId q - -{-# INLINE zipFetchMapDynM #-} -zipFetchMapDynM :: (Monad f, Component a) => (b -> a -> f a) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f a -zipFetchMapDynM f cId q = snd <$> zipFetchMapAccumDynM (\b a -> ((),) <$> f b a) cId q - -{-# INLINE zipFetchMapAccumDynM #-} -zipFetchMapAccumDynM :: (Monad f, Component a) => (b -> a -> f (c, a)) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f (c, a) -zipFetchMapAccumDynM f cId q = Op $ AdjustM f cId q - -{-# INLINE withDyn #-} -withDyn :: ComponentID -> DynamicQueryT f () -withDyn = Op . With - -{-# INLINE withoutDyn #-} -withoutDyn :: ComponentID -> DynamicQueryT f () -withoutDyn = Op . Without - -{-# INLINE opFilter #-} -opFilter :: Operation f a -> QueryFilter -opFilter Entity = mempty -opFilter (Fetch cId) = mempty {filterWith = Set.singleton cId} -opFilter (FetchMaybe cId) = mempty {filterWith = Set.singleton cId} -opFilter (FetchMap _ cId) = mempty {filterWith = Set.singleton cId} -opFilter (FetchMapM _ cId) = mempty {filterWith = Set.singleton cId} -opFilter (Adjust _ cId q) = queryFilter q <> mempty {filterWith = Set.singleton cId} -opFilter (AdjustM _ cId q) = queryFilter q <> mempty {filterWith = Set.singleton cId} -opFilter (With cId) = mempty {filterWith = Set.singleton cId} -opFilter (Without cId) = mempty {filterWithout = Set.singleton cId} - -{-# INLINE queryFilter #-} -queryFilter :: DynamicQueryT f a -> QueryFilter -queryFilter (Pure _) = mempty -queryFilter (Map _ q) = queryFilter q -queryFilter (Ap f g) = queryFilter f <> queryFilter g -queryFilter (Op op) = opFilter op - -{-# INLINE runOp #-} -runOp :: (Applicative f) => Operation f a -> Archetype -> f ([a], Archetype) -runOp Entity arch = pure (Set.toList $ A.entities arch, mempty) -runOp (Fetch cId) arch = pure (A.lookupComponentsAsc cId arch, mempty) -runOp (FetchMaybe cId) arch = - pure - ( case A.lookupComponentsAscMaybe cId arch of - Just as -> fmap Just as - Nothing -> replicate (length $ A.entities arch) Nothing, - mempty - ) -runOp (FetchMap f cId) arch = pure $ A.map f cId arch -runOp (FetchMapM f cId) arch = do - (as, arch') <- A.mapM f cId arch - return (as, arch') -runOp (Adjust f cId q) arch = do - res <- runDynQuery q arch - return $ - let !(bs, arch') = res - !(as, arch'') = A.zipWith bs f cId arch - in (as, arch'' <> arch') -runOp (AdjustM f cId q) arch = do - (as, arch') <- runDynQuery q arch - (bs, arch'') <- A.zipWithM as f cId arch - return (bs, arch'' <> arch') -runOp (With _) _ = pure ([], mempty) -runOp (Without _) _ = pure ([], mempty) - -{-# INLINE readOp #-} -readOp :: (Applicative f) => Operation f a -> Archetype -> f [a] -readOp Entity arch = pure $ Set.toList $ A.entities arch -readOp (Fetch cId) arch = pure $ A.lookupComponentsAsc cId arch -readOp (FetchMaybe cId) arch = - pure $ - case A.lookupComponentsAscMaybe cId arch of - Just as -> fmap Just as - Nothing -> replicate (length $ A.entities arch) Nothing -readOp (FetchMap f cId) arch = do - bs <- readOp (Fetch cId) arch - return $ map f bs -readOp (FetchMapM f cId) arch = do - bs <- readOp (Fetch cId) arch - mapM f bs -readOp (Adjust f cId q) arch = do - as <- readDynQuery q arch - bs <- readOp (Fetch cId) arch - return $ zipWith f as bs -readOp (AdjustM f cId q) arch = do - as <- readDynQuery q arch - bs <- readOp (Fetch cId) arch - zipWithM f as bs -readOp (With _) _ = pure [] -readOp (Without _) _ = pure [] - -{-# INLINE queryEntitiesDyn #-} -queryEntitiesDyn :: - (Monad m) => - [EntityID] -> - DynamicQueryT m a -> - Entities -> - m ([a], Entities) -queryEntitiesDyn eIds q es = - let qf = queryFilter q - go = runDynQueryEntities eIds q - in if Set.null $ filterWith qf - then do - (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es} - return (as, es) - else - let go' (acc, esAcc) (aId, n) = do - (as', arch') <- go $ nodeArchetype n - let n' = n {nodeArchetype = arch' <> nodeArchetype n} - !nodes = Map.insert aId n' . AS.nodes $ archetypes esAcc - return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}) - in foldlM go' ([], es) $ Map.toList . AS.find (filterWith qf) (filterWithout qf) $ archetypes es - -readQueryEntitiesDyn :: (Monad m) => [EntityID] -> DynamicQueryT m a -> Entities -> m [a] -readQueryEntitiesDyn eIds q es = - let qf = queryFilter q - in if Set.null $ filterWith qf - then readDynQueryEntities eIds q A.empty {A.entities = Map.keysSet $ entities es} - else - let go n = readDynQuery q $ AS.nodeArchetype n - in concat <$> mapM go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es) - -runOpEntities :: (Applicative f) => Operation f a -> [EntityID] -> Archetype -> f ([a], Archetype) -runOpEntities Entity es _ = pure (es, mempty) -runOpEntities (Fetch cId) es arch = - pure - ( map snd - . filter (\(e, _) -> e `elem` es) - . Map.toList - $ A.lookupComponents cId arch, - mempty - ) -runOpEntities (FetchMaybe cId) es arch = - pure - ( map (\(e, a) -> if e `elem` es then Just a else Nothing) - . Map.toList - $ A.lookupComponents cId arch, - mempty - ) -runOpEntities (FetchMap f cId) es arch = - pure $ - let go e a = - if e `elem` es - then let a' = f a in (Just a', a') - else (Nothing, a) - !(as, arch') = A.zipWith es go cId arch - in (mapMaybe fst as, arch') -runOpEntities (FetchMapM f cId) es arch = do - (as, arch') <- runOpEntities (AdjustM (\() a -> (,a) <$> f a) cId (pure ())) es arch - return (map snd as, arch') -runOpEntities (Adjust f cId q) es arch = do - res <- runDynQuery q arch - return $ - let go (e, b) a = - if e `elem` es - then let (x, y) = f b a in (Just x, y) - else (Nothing, a) - !(bs, arch') = res - !(as, arch'') = A.zipWith (zip es bs) go cId arch - in (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch') -runOpEntities (AdjustM f cId q) es arch = do - (bs, arch') <- runDynQuery q arch - let go (e, b) a = - if e `elem` es - then do - (x, y) <- f b a - return (Just x, y) - else return (Nothing, a) - (as, arch'') <- A.zipWithM (zip es bs) go cId arch - return (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch') -runOpEntities (With _) _ arch = pure ([], arch) -runOpEntities (Without _) _ arch = pure ([], arch) - -runDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f ([a], Archetype) -runDynQueryEntities es (Pure a) _ = pure (replicate (length es) a, mempty) -runDynQueryEntities es (Map f q) arch = first (fmap f) <$> runDynQueryEntities es q arch -runDynQueryEntities es (Ap f g) arch = do - res <- runDynQueryEntities es g arch - res' <- runDynQueryEntities es f arch - return $ - let (as, arch') = res - (bs, arch'') = res' - in (zipWith ($) bs as, arch'' <> arch') -runDynQueryEntities es (Op op) arch = runOpEntities op es arch - -{-# INLINE readOpEntities #-} -readOpEntities :: (Applicative f) => Operation f a -> [EntityID] -> Archetype -> f [a] -readOpEntities Entity es _ = pure es -readOpEntities (Fetch cId) es arch = - pure - . map snd - . filter (\(e, _) -> e `elem` es) - . Map.toList - $ A.lookupComponents cId arch -readOpEntities (FetchMaybe cId) es arch = - pure - . map (\(e, a) -> if e `elem` es then Just a else Nothing) - . Map.toList - $ A.lookupComponents cId arch -readOpEntities (FetchMap f cId) es arch = do - b <- readOpEntities (Fetch cId) es arch - pure $ map f b -readOpEntities (FetchMapM f cId) es arch = do - b <- readOpEntities (Fetch cId) es arch - mapM f b -readOpEntities (Adjust f cId q) es arch = do - a <- readDynQueryEntities es q arch - b <- readOpEntities (Fetch cId) es arch - pure $ zipWith f a b -readOpEntities (AdjustM f cId q) es arch = do - a <- readDynQueryEntities es q arch - b <- readOpEntities (Fetch cId) es arch - zipWithM f a b -readOpEntities (With _) _ _ = pure [] -readOpEntities (Without _) _ _ = pure [] - -{-# INLINE readDynQueryEntities #-} -readDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f [a] -readDynQueryEntities es (Pure a) _ = pure $ replicate (length es) a -readDynQueryEntities es (Map f q) arch = fmap f <$> readDynQueryEntities es q arch -readDynQueryEntities es (Ap f g) arch = do - a <- readDynQueryEntities es g arch - b <- readDynQueryEntities es f arch - pure $ b <*> a -readDynQueryEntities es (Op op) arch = readOpEntities op es arch - -{-# INLINE runDynQuery #-} -runDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f ([a], Archetype) -runDynQuery (Pure a) arch = pure (replicate (length $ A.entities arch) a, mempty) -runDynQuery (Map f q) arch = do - res <- runDynQuery q arch - return $ first (fmap f) res -runDynQuery (Ap f g) arch = do - res <- runDynQuery g arch - res' <- runDynQuery f arch - return $ - let (as, arch') = res - (bs, arch'') = res' - in (zipWith ($) bs as, arch'' <> arch') -runDynQuery (Op op) arch = runOp op arch - -{-# INLINE readDynQuery #-} -readDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f [a] -readDynQuery (Pure a) arch = pure $ replicate (length $ A.entities arch) a -readDynQuery (Map f q) arch = fmap f <$> readDynQuery q arch -readDynQuery (Ap f g) arch = do - as <- readDynQuery g arch - bs <- readDynQuery f arch - pure $ zipWith ($) bs as -readDynQuery (Op op) arch = readOp op arch - --- | Match all entities. --- --- @since 0.11 -readQueryDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m [a] -readQueryDyn q es = - let qf = queryFilter q - in if Set.null $ filterWith qf - then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities es} - else - let go n = readDynQuery q $ AS.nodeArchetype n - in concat <$> mapM go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es) - --- | Match a single entity. --- --- @since 0.11 -singleDyn :: (HasCallStack, Monad m) => DynamicQueryT m a -> Entities -> m a -singleDyn q es = do - res <- singleMaybeDyn q es - return $ case res of - Just a -> a - _ -> error "singleDyn: expected a single entity" - --- | Match a single entity, or `Nothing`. --- --- @since 0.11 -singleMaybeDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m (Maybe a) -singleMaybeDyn q es = - let qf = queryFilter q - in if Set.null $ filterWith qf - then case Map.keys $ entities es of - [eId] -> do - res <- readDynQuery q $ A.singleton eId - return $ case res of - [a] -> Just a - _ -> Nothing - _ -> return Nothing - else case Map.elems $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of - [n] -> do - res <- readDynQuery q $ AS.nodeArchetype n - return $ case res of - [a] -> Just a - _ -> Nothing - _ -> return Nothing - --- | Match and update all matched entities. --- --- @since 0.11 -{-# INLINE queryDyn #-} -queryDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m ([a], Entities) -queryDyn = mapDyn' id - -{-# INLINE mapDyn' #-} -mapDyn' :: - (Monad m) => - (Map ArchetypeID Node -> Map ArchetypeID Node) -> - DynamicQueryT m a -> - Entities -> - m ([a], Entities) -mapDyn' f q es = - let !qf = queryFilter q - go = runDynQuery q - in if Set.null $ filterWith qf - then do - (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es} - return (as, es) - else - let go' (acc, esAcc) (aId, n) = do - (as', arch') <- go $ nodeArchetype n - let n' = n {nodeArchetype = arch' <> nodeArchetype n} - !nodes = Map.insert aId n' . AS.nodes $ archetypes esAcc - return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}) - in foldlM go' ([], es) $ Map.toList . f . AS.find (filterWith qf) (filterWithout qf) $ archetypes es - --- | Map a single matched entity. --- --- @since 0.11 -mapSingleDyn :: (HasCallStack, Monad m) => DynamicQueryT m a -> Entities -> m (a, Entities) -mapSingleDyn q es = do - (res, es') <- mapSingleMaybeDyn q es - return $ case res of - Just a -> (a, es') - _ -> error "mapSingleDyn: expected single matching entity" - --- | Map a single matched entity, or @Nothing@. --- --- @since 0.11 -{-# INLINE mapSingleMaybeDyn #-} -mapSingleMaybeDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m (Maybe a, Entities) -mapSingleMaybeDyn q es = - let qf = queryFilter q - in if Set.null $ filterWith qf - then case Map.keys $ entities es of - [eId] -> do - res <- runDynQuery q $ A.singleton eId - return $ case res of - ([a], _) -> (Just a, es) - _ -> (Nothing, es) - _ -> pure (Nothing, es) - else case Map.toList $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of - [(aId, n)] -> do - (as, arch') <- runDynQuery q $ AS.nodeArchetype n - return $ case as of - [a] -> - let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es - in (Just a, es {archetypes = (archetypes es) {AS.nodes = nodes}}) - _ -> (Nothing, es) - _ -> pure (Nothing, es) - --- | `Query` filter. --- --- @since 0.11 -data QueryFilter = QueryFilter - { filterWith :: !(Set ComponentID), - filterWithout :: !(Set ComponentID) - } - deriving (Show) - --- | @since 0.9 -instance Semigroup QueryFilter where - QueryFilter r1 w1 <> QueryFilter r2 w2 = QueryFilter (r1 <> r2) (w1 <> w2) - --- | @since 0.9 -instance Monoid QueryFilter where - mempty = QueryFilter mempty mempty +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Aztecs.ECS.Query.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Query.Dynamic + ( -- * Dynamic queries + DynamicQuery, + DynamicQueryT (..), + + -- ** Operations + entityDyn, + fetchDyn, + fetchMaybeDyn, + fetchMapDyn, + fetchMapDynM, + zipFetchMapDyn, + zipFetchMapAccumDyn, + zipFetchMapDynM, + zipFetchMapAccumDynM, + + -- ** Filters + withDyn, + withoutDyn, + + -- ** Conversion + liftQueryDyn, + + -- ** Running + queryDyn, + readQuerySingleDyn, + readQuerySingleMaybeDyn, + queryEntitiesDyn, + readQueryDyn, + querySingleDyn, + querySingleMaybeDyn, + readQueryEntitiesDyn, + + -- *** Internal + QueryFilter (..), + Operation (..), + queryFilter, + runDynQuery, + runDynQueryEntities, + readDynQuery, + readDynQueryEntities, + ) +where + +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +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 +import Control.Applicative +import Control.Monad +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Identity +import Data.Bifunctor +import Data.Foldable +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Stack +import Prelude hiding (reads) + +-- @since 0.9 +type DynamicQuery = DynamicQueryT Identity + +-- | Dynamic query for components by ID. +-- +-- @since 0.11 +data DynamicQueryT f a where + Entity :: DynamicQueryT f EntityID + Pure :: a -> DynamicQueryT f a + Map :: (a -> b) -> DynamicQueryT f a -> DynamicQueryT f b + Ap :: DynamicQueryT f (a -> b) -> DynamicQueryT f a -> DynamicQueryT f b + Lift :: (MonadTrans g, Monad (g f), Monad f) => DynamicQueryT f a -> DynamicQueryT (g f) a + Op :: ComponentID -> Operation f a -> DynamicQueryT f a + +instance Functor (DynamicQueryT f) where + {-# INLINE fmap #-} + fmap = Map + +-- | @since 0.11 +instance Applicative (DynamicQueryT f) where + {-# INLINE pure #-} + pure = Pure + + {-# INLINE (<*>) #-} + (<*>) = Ap + +{-# INLINE entityDyn #-} +entityDyn :: DynamicQueryT f EntityID +entityDyn = Entity + +{-# INLINE fetchDyn #-} +fetchDyn :: (Component a) => ComponentID -> DynamicQueryT f a +fetchDyn cId = Op cId Fetch + +{-# INLINE fetchMaybeDyn #-} +fetchMaybeDyn :: (Component a) => ComponentID -> DynamicQueryT f (Maybe a) +fetchMaybeDyn cId = Op cId FetchMaybe + +{-# INLINE fetchMapDyn #-} +fetchMapDyn :: (Component a) => (a -> a) -> ComponentID -> DynamicQueryT f a +fetchMapDyn f cId = Op cId $ FetchMap f + +{-# INLINE fetchMapDynM #-} +fetchMapDynM :: (Monad f, Component a) => (a -> f a) -> ComponentID -> DynamicQueryT f a +fetchMapDynM f cId = Op cId $ FetchMapM f + +{-# INLINE zipFetchMapDyn #-} +zipFetchMapDyn :: + (Component a) => (b -> a -> a) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f a +zipFetchMapDyn f cId q = snd <$> Op cId (ZipFetchMap (\b a -> ((), f b a)) q) + +{-# INLINE zipFetchMapAccumDyn #-} +zipFetchMapAccumDyn :: + (Component a) => (b -> a -> (c, a)) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f (c, a) +zipFetchMapAccumDyn f cId q = Op cId $ ZipFetchMap f q + +{-# INLINE zipFetchMapDynM #-} +zipFetchMapDynM :: + (Monad f, Component a) => + (b -> a -> f a) -> + ComponentID -> + DynamicQueryT f b -> + DynamicQueryT f a +zipFetchMapDynM f cId q = snd <$> zipFetchMapAccumDynM (\b a -> ((),) <$> f b a) cId q + +{-# INLINE zipFetchMapAccumDynM #-} +zipFetchMapAccumDynM :: + (Monad f, Component a) => + (b -> a -> f (c, a)) -> + ComponentID -> + DynamicQueryT f b -> + DynamicQueryT f (c, a) +zipFetchMapAccumDynM f cId q = Op cId $ ZipFetchMapM f q + +{-# INLINE withDyn #-} +withDyn :: ComponentID -> DynamicQueryT f () +withDyn cId = Op cId With + +{-# INLINE withoutDyn #-} +withoutDyn :: ComponentID -> DynamicQueryT f () +withoutDyn cId = Op cId Without + +{-# INLINE liftQueryDyn #-} +liftQueryDyn :: (MonadTrans g, Monad (g f), Monad f) => DynamicQueryT f a -> DynamicQueryT (g f) a +liftQueryDyn = Lift + +-- | Match all entities. +-- +-- @since 0.11 +readQueryDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f [a] +readQueryDyn q es = + let qf = queryFilter q + in if Set.null $ filterWith qf + then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities es} + else + let go n = readDynQuery q $ AS.nodeArchetype n + in concat <$> traverse go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es) + +-- | Match a single entity. +-- +-- @since 0.11 +readQuerySingleDyn :: (HasCallStack, Applicative f) => DynamicQueryT f a -> Entities -> f a +readQuerySingleDyn q es = do + res <- readQuerySingleMaybeDyn q es + return $ case res of + Just a -> a + _ -> error "singleDyn: expected a single entity" + +-- | Match a single entity, or `Nothing`. +-- +-- @since 0.11 +readQuerySingleMaybeDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f (Maybe a) +readQuerySingleMaybeDyn q es = + let qf = queryFilter q + in if Set.null $ filterWith qf + then case Map.keys $ entities es of + [eId] -> do + res <- readDynQuery q $ A.singleton eId + return $ case res of + [a] -> Just a + _ -> Nothing + _ -> pure Nothing + else case Map.elems $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of + [n] -> do + res <- readDynQuery q $ AS.nodeArchetype n + return $ case res of + [a] -> Just a + _ -> Nothing + _ -> pure Nothing + +readQueryEntitiesDyn :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Entities -> f [a] +readQueryEntitiesDyn eIds q es = + let qf = queryFilter q + in if Set.null $ filterWith qf + then readDynQueryEntities eIds q A.empty {A.entities = Map.keysSet $ entities es} + else + let go n = readDynQuery q $ AS.nodeArchetype n + in concat <$> traverse go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es) + +-- | Match and update all matched entities. +-- +-- @since 0.11 +{-# INLINE queryDyn #-} +queryDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f ([a], Entities) +queryDyn q es = + let qf = queryFilter q + in if Set.null $ filterWith qf + then (,es) . fst <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} + else + let go (aId, n) = do + res <- runDynQuery q $ nodeArchetype n + return $ + let (as', arch') = res + in (as', aId, n {nodeArchetype = arch' <> nodeArchetype n}) + matches = Map.toList . AS.find (filterWith qf) (filterWithout qf) $ archetypes es + res' = traverse go matches + folder (acc, esAcc) (as, aId, node) = + let nodes = Map.insert aId node . AS.nodes $ archetypes esAcc + in (as ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}) + in fmap (foldl' folder ([], es)) res' + +-- | Match and update a single entity. +-- +-- @since 0.11 +querySingleDyn :: (HasCallStack, Applicative m) => DynamicQueryT m a -> Entities -> m (a, Entities) +querySingleDyn q es = do + res <- querySingleMaybeDyn q es + return $ case res of + (Just a, es') -> (a, es') + _ -> error "mapSingleDyn: expected single matching entity" + +-- | Match and update a single entity, or @Nothing@. +-- +-- @since 0.11 +{-# INLINE querySingleMaybeDyn #-} +querySingleMaybeDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f (Maybe a, Entities) +querySingleMaybeDyn q es = + let qf = queryFilter q + in if Set.null $ filterWith qf + then case Map.keys $ entities es of + [eId] -> do + res <- runDynQuery q $ A.singleton eId + return $ case res of + ([a], _) -> (Just a, es) + _ -> (Nothing, es) + _ -> pure (Nothing, es) + else case Map.toList $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of + [(aId, n)] -> do + res <- runDynQuery q $ AS.nodeArchetype n + return $ case res of + ([a], arch') -> + let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es + in (Just a, es {archetypes = (archetypes es) {AS.nodes = nodes}}) + _ -> (Nothing, es) + _ -> pure (Nothing, es) + +{-# INLINE queryEntitiesDyn #-} +queryEntitiesDyn :: + (Monad m) => + [EntityID] -> + DynamicQueryT m a -> + Entities -> + m ([a], Entities) +queryEntitiesDyn eIds q es = + let qf = queryFilter q + go = runDynQueryEntities eIds q + in if Set.null $ filterWith qf + then do + (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es} + return (as, es) + else + let go' (acc, esAcc) (aId, n) = do + (as', arch') <- go $ nodeArchetype n + let n' = n {nodeArchetype = arch' <> nodeArchetype n} + nodes = Map.insert aId n' . AS.nodes $ archetypes esAcc + return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}) + in foldlM go' ([], es) $ Map.toList . AS.find (filterWith qf) (filterWithout qf) $ archetypes es + +{-# INLINE queryFilter #-} +queryFilter :: DynamicQueryT f a -> QueryFilter +queryFilter (Pure _) = mempty +queryFilter (Map _ q) = queryFilter q +queryFilter (Ap f g) = queryFilter f <> queryFilter g +queryFilter (Lift q) = queryFilter q +queryFilter Entity = mempty +queryFilter (Op cId op) = opFilter cId op + +{-# INLINE readDynQuery #-} +readDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f [a] +readDynQuery (Pure a) arch = pure $ replicate (length $ A.entities arch) a +readDynQuery (Map f q) arch = fmap f <$> readDynQuery q arch +readDynQuery (Ap f g) arch = do + as <- readDynQuery g arch + bs <- readDynQuery f arch + pure $ zipWith ($) bs as +readDynQuery (Lift q) arch = lift $ readDynQuery q arch +readDynQuery Entity arch = pure $ Set.toList $ A.entities arch +readDynQuery (Op cId op) arch = readOp cId op arch + +{-# INLINE readDynQueryEntities #-} +readDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f [a] +readDynQueryEntities es (Pure a) _ = pure $ replicate (length es) a +readDynQueryEntities es (Map f q) arch = fmap f <$> readDynQueryEntities es q arch +readDynQueryEntities es (Ap f g) arch = do + a <- readDynQueryEntities es g arch + b <- readDynQueryEntities es f arch + pure $ b <*> a +readDynQueryEntities es (Lift q) arch = lift $ readDynQueryEntities es q arch +readDynQueryEntities es Entity _ = pure es +readDynQueryEntities es (Op cId op) arch = readOpEntities cId es op arch + +{-# INLINE runDynQuery #-} +runDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f ([a], Archetype) +runDynQuery (Pure a) arch = pure (replicate (length $ A.entities arch) a, mempty) +runDynQuery (Map f q) arch = do + res <- runDynQuery q arch + return $ first (fmap f) res +runDynQuery (Ap f g) arch = do + res <- runDynQuery g arch + res' <- runDynQuery f arch + return $ + let (as, arch') = res + (bs, arch'') = res' + in (zipWith ($) bs as, arch'' <> arch') +runDynQuery (Lift q) arch = lift $ runDynQuery q arch +runDynQuery Entity arch = (,arch) <$> readDynQuery Entity arch +runDynQuery (Op cId op) arch = runOp cId op arch + +runDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f ([a], Archetype) +runDynQueryEntities es (Pure a) _ = pure (replicate (length es) a, mempty) +runDynQueryEntities es (Map f q) arch = first (fmap f) <$> runDynQueryEntities es q arch +runDynQueryEntities es (Ap f g) arch = do + res <- runDynQueryEntities es g arch + res' <- runDynQueryEntities es f arch + return $ + let (as, arch') = res + (bs, arch'') = res' + in (zipWith ($) bs as, arch'' <> arch') +runDynQueryEntities es (Lift q) arch = lift $ runDynQueryEntities es q arch +runDynQueryEntities es Entity _ = pure (es, mempty) +runDynQueryEntities es (Op cId op) arch = runOpEntities cId es op arch + +data Operation f a where + Fetch :: (Component a) => Operation f a + FetchMaybe :: (Component a) => Operation f (Maybe a) + FetchMap :: (Component a) => (a -> a) -> Operation f a + FetchMapM :: (Monad f, Component a) => (a -> f a) -> Operation f a + ZipFetchMap :: (Component a) => (b -> a -> (c, a)) -> (DynamicQueryT f b) -> Operation f (c, a) + ZipFetchMapM :: (Monad f, Component a) => (b -> a -> f (c, a)) -> (DynamicQueryT f b) -> Operation f (c, a) + With :: Operation f () + Without :: Operation f () + +{-# INLINE opFilter #-} +opFilter :: ComponentID -> Operation f a -> QueryFilter +opFilter cId Fetch = mempty {filterWith = Set.singleton cId} +opFilter cId FetchMaybe = mempty {filterWith = Set.singleton cId} +opFilter cId (FetchMap _) = mempty {filterWith = Set.singleton cId} +opFilter cId (FetchMapM _) = mempty {filterWith = Set.singleton cId} +opFilter cId (ZipFetchMap _ q) = queryFilter q <> mempty {filterWith = Set.singleton cId} +opFilter cId (ZipFetchMapM _ q) = queryFilter q <> mempty {filterWith = Set.singleton cId} +opFilter cId With = mempty {filterWith = Set.singleton cId} +opFilter cId Without = mempty {filterWithout = Set.singleton cId} + +{-# INLINE readOp #-} +readOp :: (Applicative f) => ComponentID -> Operation f a -> Archetype -> f [a] +readOp cId Fetch arch = pure $ A.lookupComponentsAsc cId arch +readOp cId FetchMaybe arch = + pure $ + case A.lookupComponentsAscMaybe cId arch of + Just as -> fmap Just as + Nothing -> replicate (length $ A.entities arch) Nothing +readOp cId (FetchMap f) arch = do + bs <- readOp cId Fetch arch + return $ map f bs +readOp cId (FetchMapM f) arch = do + bs <- readOp cId Fetch arch + mapM f bs +readOp cId (ZipFetchMap f q) arch = do + as <- readDynQuery q arch + bs <- readOp cId Fetch arch + return $ zipWith f as bs +readOp cId (ZipFetchMapM f q) arch = do + as <- readDynQuery q arch + bs <- readOp cId Fetch arch + zipWithM f as bs +readOp _ With _ = pure [] +readOp _ Without _ = pure [] + +{-# INLINE runOp #-} +runOp :: (Applicative f) => ComponentID -> Operation f a -> Archetype -> f ([a], Archetype) +runOp cId (FetchMap f) arch = pure $ A.map f cId arch +runOp cId (FetchMapM f) arch = do + (as, arch') <- A.mapM f cId arch + return (as, arch') +runOp cId (ZipFetchMap f q) arch = do + res <- runDynQuery q arch + return $ + let (bs, arch') = res + (as, arch'') = A.zipMap bs f cId arch + in (as, arch'' <> arch') +runOp cId (ZipFetchMapM f q) arch = do + (as, arch') <- runDynQuery q arch + (bs, arch'') <- A.zipMapM as f cId arch + return (bs, arch'' <> arch') +runOp cId op arch = (,mempty) <$> readOp cId op arch + +{-# INLINE readOpEntities #-} +readOpEntities :: (Applicative f) => ComponentID -> [EntityID] -> Operation f a -> Archetype -> f [a] +readOpEntities cId es Fetch arch = + pure + . map snd + . filter (\(e, _) -> e `elem` es) + . Map.toList + $ A.lookupComponents cId arch +readOpEntities cId es FetchMaybe arch = + pure + . map (\(e, a) -> if e `elem` es then Just a else Nothing) + . Map.toList + $ A.lookupComponents cId arch +readOpEntities cId es (FetchMap f) arch = do + b <- readOpEntities cId es Fetch arch + pure $ map f b +readOpEntities cId es (FetchMapM f) arch = do + b <- readOpEntities cId es Fetch arch + mapM f b +readOpEntities cId es (ZipFetchMap f q) arch = do + a <- readDynQueryEntities es q arch + b <- readOpEntities cId es Fetch arch + pure $ zipWith f a b +readOpEntities cId es (ZipFetchMapM f q) arch = do + a <- readDynQueryEntities es q arch + b <- readOpEntities cId es Fetch arch + zipWithM f a b +readOpEntities _ _ With _ = pure [] +readOpEntities _ _ Without _ = pure [] + +runOpEntities :: (Applicative f) => ComponentID -> [EntityID] -> Operation f a -> Archetype -> f ([a], Archetype) +runOpEntities cId es (FetchMap f) arch = + pure $ + let go e a = + if e `elem` es + then let a' = f a in (Just a', a') + else (Nothing, a) + (as, arch') = A.zipMap es go cId arch + in (mapMaybe fst as, arch') +runOpEntities cId es (FetchMapM f) arch = do + (as, arch') <- runOpEntities cId es (ZipFetchMapM (\() a -> (,a) <$> f a) (pure ())) arch + return (map snd as, arch') +runOpEntities cId es (ZipFetchMap f q) arch = do + res <- runDynQuery q arch + return $ + let go (e, b) a = + if e `elem` es + then let (x, y) = f b a in (Just x, y) + else (Nothing, a) + (bs, arch') = res + (as, arch'') = A.zipMap (zip es bs) go cId arch + in (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch') +runOpEntities cId es (ZipFetchMapM f q) arch = do + (bs, arch') <- runDynQuery q arch + let go (e, b) a = + if e `elem` es + then do + (x, y) <- f b a + return (Just x, y) + else return (Nothing, a) + (as, arch'') <- A.zipMapM (zip es bs) go cId arch + return (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch') +runOpEntities cId es op arch = (,arch) <$> readOpEntities cId es op arch + +-- | `Query` filter. +-- +-- @since 0.11 +data QueryFilter = QueryFilter + { filterWith :: !(Set ComponentID), + filterWithout :: !(Set ComponentID) + } + deriving (Show) + +-- | @since 0.9 +instance Semigroup QueryFilter where + QueryFilter r1 w1 <> QueryFilter r2 w2 = QueryFilter (r1 <> r2) (w1 <> w2) + +-- | @since 0.9 +instance Monoid QueryFilter where + mempty = QueryFilter mempty mempty diff --git a/src/Aztecs/ECS/System.hs b/src/Aztecs/ECS/System.hs --- a/src/Aztecs/ECS/System.hs +++ b/src/Aztecs/ECS/System.hs @@ -1,216 +1,337 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - --- | --- 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) --- --- Systems to process entities. -module Aztecs.ECS.System - ( -- * Systems - System, - SystemT (..), - - -- ** Reading - readQuery, - allDyn, - readQueryEntities, - - -- ** Writing - query, - querySingleMaybe, - queryDyn, - querySingleMaybeDyn, - - -- ** Running - runSystemT, - concurrently, - - -- * Internal - Job (..), - Task (..), - ) -where - -import Aztecs.ECS.Entity (EntityID) -import Aztecs.ECS.Query (QueryT (..)) -import Aztecs.ECS.Query.Dynamic (DynamicQueryT, queryFilter, readDynQuery, readDynQueryEntities) -import qualified Aztecs.ECS.View as V -import qualified Aztecs.ECS.World.Archetype as A -import Aztecs.ECS.World.Entities (Entities (..)) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Monad.Identity -import Control.Monad.Trans -import Data.Kind -import qualified Data.Map as Map - --- | System task. --- --- @since 0.11 -newtype Task t (m :: Type -> Type) a - = Task {runTask :: ((Entities -> Entities) -> t m Entities) -> t m a} - deriving (Functor) - --- | Job to be interpreted. --- --- @since 0.11 -data Job t m a where - Pure :: a -> Job t m a - Map :: (a -> b) -> Job t m a -> Job t m b - Ap :: Job t m (a -> b) -> Job t m a -> Job t m b - Bind :: Job t m a -> (a -> Job t m b) -> Job t m b - Once :: Task t m a -> Job t m a - -type System = SystemT Identity - --- | System to process entities. --- --- @since 0.11 -newtype SystemT m a - = System {unSystem :: forall t. (MonadTrans t, Monad (t m)) => Job t m a} - --- | @since 0.11 -instance Functor (SystemT m) where - fmap f (System s) = System $ Map f s - --- | @since 0.11 -instance (Monad m) => Applicative (SystemT m) where - pure a = System $ Pure a - (System f) <*> (System g) = System $ Ap f g - --- | @since 0.11 -instance (Monad m) => Monad (SystemT m) where - (System a) >>= f = System $ Bind a (unSystem . f) - --- | @since 0.11 -instance (MonadIO m) => MonadIO (SystemT m) where - liftIO m = System $ Once . Task . const . lift $ liftIO m - --- | Map all entities with a `DynamicQueryT`. --- --- @since 0.11 -queryDyn :: (Monad m) => DynamicQueryT m a -> SystemT m [a] -queryDyn q = System $ Once . Task $ \f -> do - w <- f id - let qf = queryFilter q - !v = V.view qf $ archetypes w - (o, v') <- lift $ V.mapDyn q v - _ <- f $ V.unview v' - return o - --- | Map a single entity with a `DynamicQueryT`. --- --- @since 0.11 -querySingleMaybeDyn :: (Monad m) => DynamicQueryT m a -> SystemT m (Maybe a) -querySingleMaybeDyn q = System $ Once . Task $ \f -> do - w <- f id - let qf = queryFilter q - case V.viewSingle qf $ archetypes w of - Just v -> do - (o, v') <- lift $ V.mapSingleDyn q v - _ <- f $ V.unview v' - return o - Nothing -> return Nothing - --- | Match and update all entities with a `QueryT`. --- --- @since 0.11 -query :: (Monad m) => QueryT m a -> SystemT m [a] -query q = do - dynQ <- fromQuery q - queryDyn dynQ - --- | Match and update a single entity with a `QueryT`, or @Nothing@. --- --- @since 0.11 -querySingleMaybe :: (Monad m) => QueryT m a -> SystemT m (Maybe a) -querySingleMaybe q = do - dynQ <- fromQuery q - querySingleMaybeDyn dynQ - --- | Match all entities with a `QueryT`. --- --- @since 0.11 -readQuery :: (Monad m) => QueryT m a -> SystemT m [a] -readQuery q = do - dynQ <- fromQuery q - allDyn dynQ - --- | Match entities with a `QueryT`. --- --- @since 0.11 -readQueryEntities :: (Monad m) => [EntityID] -> QueryT m a -> SystemT m [a] -readQueryEntities es q = fromQuery q >>= queryEntitiesDyn es - -allDyn :: (Monad m) => DynamicQueryT m a -> SystemT m [a] -allDyn q = System $ Once . Task $ \f -> do - w <- f id - let qf = queryFilter q - !v = V.view qf $ archetypes w - lift $ - if V.null v - then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities w} - else V.allDyn q v - -queryEntitiesDyn :: (Monad m) => [EntityID] -> DynamicQueryT m a -> SystemT m [a] -queryEntitiesDyn es q = System $ Once . Task $ \f -> do - w <- f id - let qf = queryFilter q - !v = V.view qf $ archetypes w - lift $ - if V.null v - then readDynQueryEntities es q $ A.empty {A.entities = Map.keysSet $ entities w} - else V.allDyn q v - --- | Convert a `QueryT` to a `System`. --- --- @since 0.11 -fromQuery :: (Monad m) => QueryT m a -> SystemT m (DynamicQueryT m a) -fromQuery q = System $ Once . Task $ \f -> do - w <- f id - let (cs', dynQ) = runQuery q $ components w - _ <- f $ const w {components = cs'} - return dynQ - -runSystemT :: (MonadTrans t, Monad (t m), Monad m) => SystemT m a -> ((Entities -> Entities) -> t m Entities) -> t m a -runSystemT (System s) = runJob s - -runJob :: (MonadTrans t, Monad (t m), Monad m) => Job t m a -> ((Entities -> Entities) -> t m Entities) -> t m a -runJob (Pure a) _ = return a -runJob (Map f' s') f = f' <$> runJob s' f -runJob (Ap f' a) f = runJob f' f <*> runJob a f -runJob (Bind a f') f = runJob a f >>= \a' -> runJob (f' a') f -runJob (Once (Task t)) f = t f - -concurrently :: SystemT IO a -> ((Entities -> Entities) -> IO Entities) -> IO a -concurrently (System s) f = runJobConcurrently s $ lift . f - -runJobConcurrently :: Job IdentityT IO a -> ((Entities -> Entities) -> IdentityT IO Entities) -> IO a -runJobConcurrently (Pure a) _ = return a -runJobConcurrently (Map f' s') f = f' <$> runJobConcurrently s' f -runJobConcurrently (Ap f' a) f = do - aVar <- newEmptyMVar - fVar <- newEmptyMVar - _ <- forkIO $ do - f'' <- runJobConcurrently f' f - putMVar fVar f'' - _ <- forkIO $ do - a' <- runJobConcurrently a f - putMVar aVar a' - a' <- takeMVar aVar - f'' <- takeMVar fVar - return $ f'' a' -runJobConcurrently (Bind a f') f = runJobConcurrently a f >>= \a' -> runJobConcurrently (f' a') f -runJobConcurrently (Once (Task t)) f = runIdentityT $ t f +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- 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) +-- +-- Systems to process entities. +module Aztecs.ECS.System + ( -- * Systems + System, + SystemT (..), + + -- ** Queries + + -- *** Reading + readQuery, + readQueryT, + readQueryEntities, + readQueryEntitiesT, + + -- *** Writing + query, + queryT, + querySingleMaybe, + querySingleMaybeT, + + -- *** Conversion + fromQuery, + fromQueryT, + + -- ** Dynamic Queries + + -- *** Reading + readQueryDyn, + readQueryDynT, + readQueryEntitiesDyn, + readQueryEntitiesDynT, + + -- *** Writing + queryDyn, + queryDynT, + querySingleMaybeDyn, + querySingleMaybeDynT, + + -- * Internal + Job (..), + Task (..), + + -- ** Running + runSystemT, + concurrently, + ) +where + +import Aztecs.ECS.Entity +import Aztecs.ECS.Query (Query, QueryT (..)) +import Aztecs.ECS.Query.Dynamic + ( DynamicQuery, + DynamicQueryT, + queryFilter, + readDynQuery, + readDynQueryEntities, + ) +import qualified Aztecs.ECS.View as V +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Entities (Entities (..)) +import Control.Concurrent +import Control.Monad.Identity +import Control.Monad.Trans +import Data.Kind +import qualified Data.Map as Map + +-- | System task. +-- +-- @since 0.11 +newtype Task t (m :: Type -> Type) a + = Task {runTask :: ((Entities -> Entities) -> t m Entities) -> t m a} + deriving (Functor) + +-- | Job to be interpreted. +-- +-- @since 0.11 +data Job t m a where + Pure :: a -> Job t m a + Map :: (a -> b) -> Job t m a -> Job t m b + Ap :: Job t m (a -> b) -> Job t m a -> Job t m b + Bind :: Job t m a -> (a -> Job t m b) -> Job t m b + Once :: Task t m a -> Job t m a + +type System = SystemT Identity + +-- | System to process entities. +-- +-- @since 0.11 +newtype SystemT m a + = System {unSystem :: forall t. (MonadTrans t, Monad (t m)) => Job t m a} + +-- | @since 0.11 +instance Functor (SystemT m) where + fmap f (System s) = System $ Map f s + +-- | @since 0.11 +instance (Monad m) => Applicative (SystemT m) where + pure a = System $ Pure a + (System f) <*> (System g) = System $ Ap f g + +-- | @since 0.11 +instance (Monad m) => Monad (SystemT m) where + (System a) >>= f = System $ Bind a (unSystem . f) + +-- | @since 0.11 +instance (MonadIO m) => MonadIO (SystemT m) where + liftIO m = System $ Once . Task . const . lift $ liftIO m + +-- | Match all entities with a `Query`. +-- +-- @since 0.11 +readQuery :: (Monad m) => Query a -> SystemT m [a] +readQuery q = do + dynQ <- fromQuery q + readQueryDyn dynQ + +-- | Match all entities with a `QueryT`. +-- +-- @since 0.11 +readQueryT :: (Monad m) => QueryT m a -> SystemT m [a] +readQueryT q = do + dynQ <- fromQueryT q + readQueryDynT dynQ + +-- | Match and update all entities with a `QueryT`. +-- +-- @since 0.11 +query :: (Monad m) => Query a -> SystemT m [a] +query q = do + dynQ <- fromQuery q + queryDyn dynQ + +-- | Match and update all entities with a `QueryT`. +-- +-- @since 0.11 +queryT :: (Monad m) => QueryT m a -> SystemT m [a] +queryT q = do + dynQ <- fromQueryT q + queryDynT dynQ + +-- | Match and update a single entity with a `Query`, or @Nothing@. +-- +-- @since 0.11 +querySingleMaybe :: (Monad m) => Query a -> SystemT m (Maybe a) +querySingleMaybe q = do + dynQ <- fromQuery q + querySingleMaybeDyn dynQ + +-- | Match and update a single entity with a `QueryT`, or @Nothing@. +-- +-- @since 0.11 +querySingleMaybeT :: (Monad m) => QueryT m a -> SystemT m (Maybe a) +querySingleMaybeT q = do + dynQ <- fromQueryT q + querySingleMaybeDynT dynQ + +-- | Map all entities with a `DynamicQuery`. +-- +-- @since 0.11 +queryDyn :: (Monad m) => DynamicQuery a -> SystemT m [a] +queryDyn q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + !v = V.view qf $ archetypes w + let (o, v') = runIdentity $ V.mapDyn q v + _ <- f $ V.unview v' + return o + +-- | Map all entities with a `DynamicQueryT`. +-- +-- @since 0.11 +queryDynT :: (Monad m) => DynamicQueryT m a -> SystemT m [a] +queryDynT q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + !v = V.view qf $ archetypes w + (o, v') <- lift $ V.mapDyn q v + _ <- f $ V.unview v' + return o + +-- | Map a single entity with a `DynamicQuery`. +-- +-- @since 0.11 +querySingleMaybeDyn :: (Monad m) => DynamicQuery a -> SystemT m (Maybe a) +querySingleMaybeDyn q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + case V.viewSingle qf $ archetypes w of + Just v -> do + let (o, v') = runIdentity $ V.mapSingleDyn q v + _ <- f $ V.unview v' + return o + Nothing -> return Nothing + +-- | Map a single entity with a `DynamicQueryT`. +-- +-- @since 0.11 +querySingleMaybeDynT :: (Monad m) => DynamicQueryT m a -> SystemT m (Maybe a) +querySingleMaybeDynT q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + case V.viewSingle qf $ archetypes w of + Just v -> do + (o, v') <- lift $ V.mapSingleDyn q v + _ <- f $ V.unview v' + return o + Nothing -> return Nothing + +readQueryDyn :: (Monad m) => DynamicQuery a -> SystemT m [a] +readQueryDyn q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + !v = V.view qf $ archetypes w + return $ + runIdentity $ + if V.null v + then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities w} + else V.allDyn q v + +readQueryDynT :: (Monad m) => DynamicQueryT m a -> SystemT m [a] +readQueryDynT q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + !v = V.view qf $ archetypes w + lift $ + if V.null v + then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities w} + else V.allDyn q v + +-- | Match entities with a `QueryT`. +-- +-- @since 0.11 +readQueryEntities :: (Monad m) => [EntityID] -> Query a -> SystemT m [a] +readQueryEntities es q = fromQuery q >>= readQueryEntitiesDyn es + +-- | Match entities with a `QueryT`. +-- +-- @since 0.11 +readQueryEntitiesT :: (Monad m) => [EntityID] -> QueryT m a -> SystemT m [a] +readQueryEntitiesT es q = fromQueryT q >>= readQueryEntitiesDynT es + +readQueryEntitiesDyn :: (Monad m) => [EntityID] -> DynamicQuery a -> SystemT m [a] +readQueryEntitiesDyn es q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + !v = V.view qf $ archetypes w + return . runIdentity $ + if V.null v + then readDynQueryEntities es q $ A.empty {A.entities = Map.keysSet $ entities w} + else V.allDyn q v + +readQueryEntitiesDynT :: (Monad m) => [EntityID] -> DynamicQueryT m a -> SystemT m [a] +readQueryEntitiesDynT es q = System $ Once . Task $ \f -> do + w <- f id + let qf = queryFilter q + !v = V.view qf $ archetypes w + lift $ + if V.null v + then readDynQueryEntities es q $ A.empty {A.entities = Map.keysSet $ entities w} + else V.allDyn q v + +-- | Convert a `Query` to a `SystemT`. +-- +-- @since 0.11 +fromQuery :: Query a -> SystemT m (DynamicQuery a) +fromQuery q = System $ Once . Task $ \f -> do + w <- f id + let (cs', dynQ) = runQuery q $ components w + _ <- f $ const w {components = cs'} + return dynQ + +-- | Convert a `QueryT` to a `SystemT`. +-- +-- @since 0.11 +fromQueryT :: (Monad m) => QueryT m a -> SystemT m (DynamicQueryT m a) +fromQueryT q = System $ Once . Task $ \f -> do + w <- f id + let (cs', dynQ) = runQuery q $ components w + _ <- f $ const w {components = cs'} + return dynQ + +runSystemT :: + (MonadTrans t, Monad (t m), Monad m) => + SystemT m a -> + ((Entities -> Entities) -> t m Entities) -> + t m a +runSystemT (System s) = runJob s + +runJob :: + (MonadTrans t, Monad (t m), Monad m) => + Job t m a -> + ((Entities -> Entities) -> t m Entities) -> + t m a +runJob (Pure a) _ = return a +runJob (Map f' s') f = f' <$> runJob s' f +runJob (Ap f' a) f = runJob f' f <*> runJob a f +runJob (Bind a f') f = runJob a f >>= \a' -> runJob (f' a') f +runJob (Once (Task t)) f = t f + +concurrently :: SystemT IO a -> ((Entities -> Entities) -> IO Entities) -> IO a +concurrently (System s) f = runJobConcurrently s $ lift . f + +runJobConcurrently :: Job IdentityT IO a -> ((Entities -> Entities) -> IdentityT IO Entities) -> IO a +runJobConcurrently (Pure a) _ = return a +runJobConcurrently (Map f' s') f = f' <$> runJobConcurrently s' f +runJobConcurrently (Ap f' a) f = do + aVar <- newEmptyMVar + fVar <- newEmptyMVar + _ <- forkIO $ do + f'' <- runJobConcurrently f' f + putMVar fVar f'' + _ <- forkIO $ do + a' <- runJobConcurrently a f + putMVar aVar a' + a' <- takeMVar aVar + f'' <- takeMVar fVar + return $ f'' a' +runJobConcurrently (Bind a f') f = runJobConcurrently a f >>= \a' -> runJobConcurrently (f' a') f +runJobConcurrently (Once (Task t)) f = runIdentityT $ t f diff --git a/src/Aztecs/ECS/View.hs b/src/Aztecs/ECS/View.hs --- a/src/Aztecs/ECS/View.hs +++ b/src/Aztecs/ECS/View.hs @@ -1,127 +1,127 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Aztecs.ECS.View --- 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.View - ( View (..), - view, - viewSingle, - null, - unview, - allDyn, - singleDyn, - mapDyn, - mapSingleDyn, - ) -where - -import Aztecs.ECS.Query.Dynamic (DynamicQueryT (..), QueryFilter (filterWith, filterWithout), readDynQuery, runDynQuery) -import Aztecs.ECS.World.Archetypes -import qualified Aztecs.ECS.World.Archetypes as AS -import Aztecs.ECS.World.Entities (Entities) -import qualified Aztecs.ECS.World.Entities as E -import Data.Foldable (foldl', foldlM) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Prelude hiding (null) - --- | View into a `World`, containing a subset of archetypes. --- --- @since 0.9 -newtype View = View - { -- | Archetypes contained in this view. - -- - -- @since 0.9 - viewArchetypes :: Map ArchetypeID Node - } - deriving (Show, Semigroup, Monoid) - --- | View into all archetypes containing the provided component IDs. --- --- @since 0.9 -view :: QueryFilter -> Archetypes -> View -view qf as = View $ AS.find (filterWith qf) (filterWithout qf) as - --- | View into a single archetype containing the provided component IDs. --- --- @since 0.9 -viewSingle :: QueryFilter -> Archetypes -> Maybe View -viewSingle qf as = case Map.toList $ AS.find (filterWith qf) (filterWithout qf) as of - [a] -> Just . View $ uncurry Map.singleton a - _ -> Nothing - --- | @True@ if the `View` is empty. --- --- @since 0.9 -null :: View -> Bool -null = Map.null . viewArchetypes - --- | "Un-view" a `View` back into a `World`. --- --- @since 0.9 -unview :: View -> Entities -> Entities -unview v es = - es - { E.archetypes = - foldl' - (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)}) - (E.archetypes es) - (Map.toList $ viewArchetypes v) - } - --- | Query all matching entities in a `View`. --- --- @since 0.9 -allDyn :: (Monad m) => DynamicQueryT m a -> View -> m [a] -allDyn q v = - foldlM - ( \acc n -> do - as <- readDynQuery q $ nodeArchetype n - return $ as ++ acc - ) - [] - (viewArchetypes v) - --- | Query all matching entities in a `View`. --- --- @since 0.9 -singleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a) -singleDyn q v = do - as <- allDyn q v - return $ case as of - [a] -> Just a - _ -> Nothing - --- | Map all matching entities in a `View`. --- --- @since 0.9 -mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m ([a], View) -mapDyn q v = do - (as, arches) <- - foldlM - ( \(acc, archAcc) (aId, n) -> do - (as', arch') <- runDynQuery q $ nodeArchetype n - return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc) - ) - ([], Map.empty) - (Map.toList $ viewArchetypes v) - return (as, View arches) - --- | Map a single matching entity in a `View`. --- --- @since 0.9 -mapSingleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a, View) -mapSingleDyn q v = do - (as, arches) <- mapDyn q v - return $ case as of - [a] -> (Just a, arches) - _ -> (Nothing, arches) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Aztecs.ECS.View +-- 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.View + ( View (..), + view, + viewSingle, + null, + unview, + allDyn, + singleDyn, + mapDyn, + mapSingleDyn, + ) +where + +import Aztecs.ECS.Query.Dynamic +import Aztecs.ECS.World.Archetypes +import qualified Aztecs.ECS.World.Archetypes as AS +import Aztecs.ECS.World.Entities (Entities) +import qualified Aztecs.ECS.World.Entities as E +import Data.Foldable (foldl', foldlM) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Prelude hiding (null) + +-- | View into a `World`, containing a subset of archetypes. +-- +-- @since 0.9 +newtype View = View + { -- | Archetypes contained in this view. + -- + -- @since 0.9 + viewArchetypes :: Map ArchetypeID Node + } + deriving (Show, Semigroup, Monoid) + +-- | View into all archetypes containing the provided component IDs. +-- +-- @since 0.9 +view :: QueryFilter -> Archetypes -> View +view qf as = View $ AS.find (filterWith qf) (filterWithout qf) as + +-- | View into a single archetype containing the provided component IDs. +-- +-- @since 0.9 +viewSingle :: QueryFilter -> Archetypes -> Maybe View +viewSingle qf as = case Map.toList $ AS.find (filterWith qf) (filterWithout qf) as of + [a] -> Just . View $ uncurry Map.singleton a + _ -> Nothing + +-- | @True@ if the `View` is empty. +-- +-- @since 0.9 +null :: View -> Bool +null = Map.null . viewArchetypes + +-- | "Un-view" a `View` back into a `World`. +-- +-- @since 0.9 +unview :: View -> Entities -> Entities +unview v es = + es + { E.archetypes = + foldl' + (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)}) + (E.archetypes es) + (Map.toList $ viewArchetypes v) + } + +-- | Query all matching entities in a `View`. +-- +-- @since 0.9 +allDyn :: (Monad m) => DynamicQueryT m a -> View -> m [a] +allDyn q v = + foldlM + ( \acc n -> do + as <- readDynQuery q $ nodeArchetype n + return $ as ++ acc + ) + [] + (viewArchetypes v) + +-- | Query all matching entities in a `View`. +-- +-- @since 0.9 +singleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a) +singleDyn q v = do + as <- allDyn q v + return $ case as of + [a] -> Just a + _ -> Nothing + +-- | Map all matching entities in a `View`. +-- +-- @since 0.9 +mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m ([a], View) +mapDyn q v = do + (as, arches) <- + foldlM + ( \(acc, archAcc) (aId, n) -> do + (as', arch') <- runDynQuery q $ nodeArchetype n + return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc) + ) + ([], Map.empty) + (Map.toList $ viewArchetypes v) + return (as, View arches) + +-- | Map a single matching entity in a `View`. +-- +-- @since 0.9 +mapSingleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a, View) +mapSingleDyn q v = do + (as, arches) <- mapDyn q v + return $ case as of + [a] -> (Just a, arches) + _ -> (Nothing, arches) diff --git a/src/Aztecs/ECS/World.hs b/src/Aztecs/ECS/World.hs --- a/src/Aztecs/ECS/World.hs +++ b/src/Aztecs/ECS/World.hs @@ -1,105 +1,105 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World - ( World (..), - empty, - spawn, - spawnEmpty, - insert, - lookup, - remove, - removeWithId, - despawn, - ) -where - -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 Control.DeepSeq -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, NFData) - --- | Empty `World`. --- --- @since 0.9 -empty :: World -empty = - World - { entities = E.empty, - nextEntityId = EntityID 0 - } - --- | Spawn a `Bundle` into the `World`. --- --- @since 0.9 -spawn :: Bundle -> World -> (EntityID, World) -spawn b w = - let e = nextEntityId w - in (e, w {entities = E.spawn e b $ entities w, nextEntityId = EntityID $ unEntityId e + 1}) - --- | Spawn an empty entity. --- --- @since 0.9 -spawnEmpty :: World -> (EntityID, World) -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)} - --- | Lookup a component in an entity. --- --- @since 0.9 -lookup :: forall a. (Component a) => EntityID -> World -> 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 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}) - --- | Despawn an entity, returning its components. -despawn :: EntityID -> World -> (IntMap Dynamic, World) -despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es}) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World + ( World (..), + empty, + spawn, + spawnEmpty, + insert, + lookup, + remove, + removeWithId, + despawn, + ) +where + +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 Control.DeepSeq +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, NFData) + +-- | Empty `World`. +-- +-- @since 0.9 +empty :: World +empty = + World + { entities = E.empty, + nextEntityId = EntityID 0 + } + +-- | Spawn a `Bundle` into the `World`. +-- +-- @since 0.9 +spawn :: Bundle -> World -> (EntityID, World) +spawn b w = + let e = nextEntityId w + in (e, w {entities = E.spawn e b $ entities w, nextEntityId = EntityID $ unEntityId e + 1}) + +-- | Spawn an empty entity. +-- +-- @since 0.9 +spawnEmpty :: World -> (EntityID, World) +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)} + +-- | Lookup a component in an entity. +-- +-- @since 0.9 +lookup :: forall a. (Component a) => EntityID -> World -> 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 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}) + +-- | Despawn an entity, returning its components. +despawn :: EntityID -> World -> (IntMap Dynamic, World) +despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es}) diff --git a/src/Aztecs/ECS/World/Archetype.hs b/src/Aztecs/ECS/World/Archetype.hs --- a/src/Aztecs/ECS/World/Archetype.hs +++ b/src/Aztecs/ECS/World/Archetype.hs @@ -1,301 +1,299 @@ -{-# 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, - insertAscList, - map, - mapM, - 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.DeepSeq -import Control.Monad.Writer - ( MonadTrans (..), - 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 GHC.Generics -import Prelude hiding (map, mapM, 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, NFData) - -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 -{-# INLINE lookupStorage #-} -lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a) -lookupStorage cId w = do - !dynS <- IntMap.lookup (unComponentId cId) $ storages w - fromDynamic $ storageDyn dynS - --- | Lookup a component by its `EntityID` and `ComponentID`. --- --- @since 0.9 -{-# INLINE lookupComponent #-} -lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a -lookupComponent e cId w = lookupComponents cId w Map.!? e - --- | Lookup all components by their `ComponentID`. --- --- @since 0.9 -{-# INLINE lookupComponents #-} -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) as - Nothing -> Map.empty - --- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. --- --- @since 0.9 -{-# INLINE lookupComponentsAsc #-} -lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> [a] -lookupComponentsAsc cId = fromMaybe [] . lookupComponentsAscMaybe cId - --- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. --- --- @since 0.9 -{-# INLINE lookupComponentsAscMaybe #-} -lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe [a] -lookupComponentsAscMaybe cId arch = S.toAscList <$> lookupStorage @a cId arch - --- | 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.fromAscList @a @(StorageT a) . 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 - --- | Map a list of components with a function and a component storage. --- --- @since 0.11 -{-# INLINE map #-} -map :: - forall a. (Component a) => (a -> a) -> ComponentID -> Archetype -> ([a], Archetype) -map f cId arch = - let go maybeDyn = case maybeDyn of - Just dyn -> case fromDynamic $ storageDyn dyn of - Just s -> do - let !(as, s') = S.map @a @(StorageT a) f s - tell as - 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'}) - --- | Map a list of components with a monadic function. --- --- @since 0.11 -{-# INLINE mapM #-} -mapM :: - forall m a. - (Monad m, Component a) => - (a -> m a) -> - ComponentID -> - Archetype -> - m ([a], Archetype) -mapM f cId arch = do - let go maybeDyn = case maybeDyn of - Just dyn -> case fromDynamic $ storageDyn dyn of - Just s -> do - (as, s') <- lift $ S.mapM @a @(StorageT a) f s - tell as - return $ Just $ dyn {storageDyn = toDyn s'} - Nothing -> return maybeDyn - Nothing -> return Nothing - (storages', cs) <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch - return (cs, arch {storages = storages'}) - --- | Zip a list of components with a function. --- --- @since 0.9 -{-# INLINE zipWith #-} -zipWith :: - forall a b c. - (Component c) => - [a] -> - (a -> c -> (b, c)) -> - ComponentID -> - Archetype -> - ([(b, c)], Archetype) -zipWith as f cId arch = - let go maybeDyn = case maybeDyn of - Just dyn -> case fromDynamic $ storageDyn dyn of - Just s -> do - let !(acs, s') = S.zipWith @c @(StorageT c) f as s - tell acs - 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'}) - --- | Zip a list of components with a monadic function . --- --- @since 0.9 -zipWithM :: - forall m a b c. - (Applicative m, Component c) => - [a] -> - (a -> c -> m (b, c)) -> - ComponentID -> - Archetype -> - m ([(b, 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}) - --- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`. --- --- @since 0.9 -{-# INLINE insertAscList #-} -insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype -insertAscList cId as arch = - let !storage = dynStorage @a $ S.fromAscList @a @(StorageT a) as - in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch} - --- | 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) $ toAscListDyn dynS - !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs - dynS' = S.fromAscListDyn (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) $ toAscListDyn dynS - !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs - dynS' = S.fromAscListDyn (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 = Map.elems . Map.insert e dyn . Map.fromAscList . zip es $ toAscListDyn s - in fromAscListDyn 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 DeriveGeneric #-} +{-# 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, + insertAscList, + map, + mapM, + zipMap, + zipMapM, + ) +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.DeepSeq +import Control.Monad.Writer + ( MonadTrans (..), + 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 GHC.Generics +import Prelude hiding (map, mapM, 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 + +instance NFData Archetype where + rnf = rnf . entities + +-- | 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 +{-# INLINE lookupStorage #-} +lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a) +lookupStorage cId w = do + dynS <- IntMap.lookup (unComponentId cId) $ storages w + fromDynamic $ storageDyn dynS + +-- | Lookup a component by its `EntityID` and `ComponentID`. +-- +-- @since 0.9 +{-# INLINE lookupComponent #-} +lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a +lookupComponent e cId w = lookupComponents cId w Map.!? e + +-- | Lookup all components by their `ComponentID`. +-- +-- @since 0.9 +{-# INLINE lookupComponents #-} +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) as + Nothing -> Map.empty + +-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. +-- +-- @since 0.9 +{-# INLINE lookupComponentsAsc #-} +lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> [a] +lookupComponentsAsc cId = fromMaybe [] . lookupComponentsAscMaybe cId + +-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. +-- +-- @since 0.9 +{-# INLINE lookupComponentsAscMaybe #-} +lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe [a] +lookupComponentsAscMaybe cId arch = S.toAscList <$> lookupStorage @a cId arch + +-- | 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.fromAscList @a @(StorageT a) . 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 +{-# INLINE member #-} +member :: ComponentID -> Archetype -> Bool +member cId = IntMap.member (unComponentId cId) . storages + +-- | Map a list of components with a function and a component storage. +-- +-- @since 0.11 +{-# INLINE map #-} +map :: + forall a. (Component a) => (a -> a) -> ComponentID -> Archetype -> ([a], Archetype) +map f cId arch = + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + let !(as, s') = S.map @a @(StorageT a) f s + tell as + 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'}) + +-- | Map a list of components with a monadic function. +-- +-- @since 0.11 +{-# INLINE mapM #-} +mapM :: + forall m a. + (Monad m, Component a) => + (a -> m a) -> + ComponentID -> + Archetype -> + m ([a], Archetype) +mapM f cId arch = do + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + (as, s') <- lift $ S.mapM @a @(StorageT a) f s + tell as + return $ Just $ dyn {storageDyn = toDyn s'} + Nothing -> return maybeDyn + Nothing -> return Nothing + (storages', cs) <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch + return (cs, arch {storages = storages'}) + +-- | Zip a list of components with a function. +-- +-- @since 0.9 +{-# INLINE zipMap #-} +zipMap :: + forall a b c. + (Component c) => + [a] -> + (a -> c -> (b, c)) -> + ComponentID -> + Archetype -> + ([(b, c)], Archetype) +zipMap as f cId arch = + let go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + let (acs, s') = S.zipWith @c @(StorageT c) f as s + tell acs + 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'}) + +-- | Zip a list of components with a monadic function . +-- +-- @since 0.9 +zipMapM :: + forall m a b c. + (Applicative m, Component c) => + [a] -> + (a -> c -> m (b, c)) -> + ComponentID -> + Archetype -> + m ([(b, c)], Archetype) +zipMapM 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}) + +-- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`. +-- +-- @since 0.9 +{-# INLINE insertAscList #-} +insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype +insertAscList cId as arch = + let !storage = dynStorage @a $ S.fromAscList @a @(StorageT a) as + in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch} + +-- | 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) $ toAscListDyn dynS + !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs + dynS' = S.fromAscListDyn (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) $ toAscListDyn dynS + !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs + dynS' = S.fromAscListDyn (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 = Map.elems . Map.insert e dyn . Map.fromAscList . zip es $ toAscListDyn s + in fromAscListDyn ecs s + in archAcc {storages = storages', entities = Set.insert e $ entities archAcc} + in foldl' f arch (IntMap.toList cs) diff --git a/src/Aztecs/ECS/World/Archetypes.hs b/src/Aztecs/ECS/World/Archetypes.hs --- a/src/Aztecs/ECS/World/Archetypes.hs +++ b/src/Aztecs/ECS/World/Archetypes.hs @@ -1,245 +1,245 @@ -{-# 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 --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Archetypes - ( ArchetypeID (..), - Node (..), - Archetypes (..), - empty, - insertArchetype, - lookupArchetypeId, - findArchetypeIds, - lookup, - find, - adjustArchetype, - insert, - remove, - ) -where - -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Archetype (Archetype (..)) -import qualified Aztecs.ECS.World.Archetype as A -import Aztecs.ECS.World.Bundle.Dynamic -import Aztecs.ECS.World.Storage.Dynamic -import Control.DeepSeq (NFData (..)) -import Data.Dynamic -import Data.Foldable (foldl') -import qualified Data.IntMap.Strict as IntMap -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import 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, NFData) - --- | 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, NFData) - --- | `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, NFData) - --- | Empty `Archetypes`. --- --- @since 0.9 -empty :: Archetypes -empty = - Archetypes - { nodes = mempty, - archetypeIds = mempty, - nextArchetypeId = ArchetypeID 0, - componentIds = mempty - } - --- | Insert an archetype by its set of `ComponentID`s. --- --- @since 0.9 -insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes) -insertArchetype cIds n arches = - let aId = nextArchetypeId arches - in ( aId, - arches - { nodes = Map.insert aId n (nodes arches), - archetypeIds = Map.insert cIds aId (archetypeIds arches), - nextArchetypeId = ArchetypeID (unArchetypeId aId + 1), - componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches) - } - ) - --- | Adjust an `Archetype` by its `ArchetypeID`. --- --- @since 0.9 -adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes -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.11 -findArchetypeIds :: Set ComponentID -> Set ComponentID -> Archetypes -> Set ArchetypeID -findArchetypeIds w wo arches = - let !withIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems w) - !withoutIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems wo) - !withoutSet = foldl' Set.union Set.empty withoutIds - in case withIds of - (aId : aIds') -> foldl' Set.intersection aId aIds' `Set.difference` withoutSet - [] -> Set.empty - --- | Lookup `Archetype`s containing a set of `ComponentID`s. --- --- @since 0.9 -find :: Set ComponentID -> Set ComponentID -> Archetypes -> Map ArchetypeID Node -find w wo arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds w wo arches) - --- | Lookup an `ArchetypeID` by its set of `ComponentID`s. --- --- @since 0.9 -lookupArchetypeId :: Set ComponentID -> Archetypes -> 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 aId arches = Map.lookup aId (nodes arches) - --- | Insert a component into an entity with its `ComponentID`. --- --- @since 0.9 -insert :: - EntityID -> - ArchetypeID -> - Set ComponentID -> - DynamicBundle -> - Archetypes -> - (Maybe ArchetypeID, Archetypes) -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}) - else - let cIds' = cIds <> nodeComponentIds node - in case lookupArchetypeId cIds' arches of - Just nextAId -> - let !(cs, arch) = A.remove e $ nodeArchetype node - node' = node {nodeArchetype = arch} - !nodes' = Map.insert aId node' $ nodes arches - adjustNode nextNode = - let nextArch = nodeArchetype nextNode - nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch} - !nextArch'' = A.insertComponents e cs nextArch' - in nextNode {nodeArchetype = runDynamicBundle b e nextArch''} - in (Just nextAId, arches {nodes = Map.adjust adjustNode nextAId nodes'}) - 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} - !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch} - !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'} - in (Just nextAId, arches') - Nothing -> (Nothing, arches) - --- | Remove a component from an entity with its `ComponentID`. --- --- @since 0.9 -remove :: - (Component a) => - EntityID -> - ArchetypeID -> - ComponentID -> - Archetypes -> - (Maybe (a, ArchetypeID), Archetypes) -remove e aId cId arches = case lookup aId arches of - Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of - Just nextAId -> - let !(cs, arch') = A.remove e (nodeArchetype node) - !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)} - (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs - go' archAcc (itemCId, dyn) = - let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s - 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')} - ) - Nothing -> - let !(cs, arch') = A.removeStorages e (nodeArchetype node) - (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs - !n = - Node - { nodeComponentIds = Set.insert cId (nodeComponentIds node), - nodeArchetype = Archetype {storages = cs', entities = Set.singleton e} - } - !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches - node' = node {nodeArchetype = arch'} - removeDyn s = - let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') $ toAscListDyn s - in (res, fromAscListDyn $ Map.elems dyns) - in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)), - arches' {nodes = Map.insert aId node' (nodes arches')} - ) - Nothing -> (Nothing, arches) +{-# 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 +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Archetypes + ( ArchetypeID (..), + Node (..), + Archetypes (..), + empty, + insertArchetype, + lookupArchetypeId, + findArchetypeIds, + lookup, + find, + adjustArchetype, + insert, + remove, + ) +where + +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Archetype (Archetype (..)) +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Bundle.Dynamic +import Aztecs.ECS.World.Storage.Dynamic +import Control.DeepSeq (NFData (..)) +import Data.Dynamic +import Data.Foldable (foldl') +import qualified Data.IntMap.Strict as IntMap +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import 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, NFData) + +-- | 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, NFData) + +-- | `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, NFData) + +-- | Empty `Archetypes`. +-- +-- @since 0.9 +empty :: Archetypes +empty = + Archetypes + { nodes = mempty, + archetypeIds = mempty, + nextArchetypeId = ArchetypeID 0, + componentIds = mempty + } + +-- | Insert an archetype by its set of `ComponentID`s. +-- +-- @since 0.9 +insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes) +insertArchetype cIds n arches = + let aId = nextArchetypeId arches + in ( aId, + arches + { nodes = Map.insert aId n (nodes arches), + archetypeIds = Map.insert cIds aId (archetypeIds arches), + nextArchetypeId = ArchetypeID (unArchetypeId aId + 1), + componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches) + } + ) + +-- | Adjust an `Archetype` by its `ArchetypeID`. +-- +-- @since 0.9 +adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes +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.11 +findArchetypeIds :: Set ComponentID -> Set ComponentID -> Archetypes -> Set ArchetypeID +findArchetypeIds w wo arches = + let !withIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems w) + !withoutIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems wo) + !withoutSet = foldl' Set.union Set.empty withoutIds + in case withIds of + (aId : aIds') -> foldl' Set.intersection aId aIds' `Set.difference` withoutSet + [] -> Set.empty + +-- | Lookup `Archetype`s containing a set of `ComponentID`s. +-- +-- @since 0.9 +find :: Set ComponentID -> Set ComponentID -> Archetypes -> Map ArchetypeID Node +find w wo arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds w wo arches) + +-- | Lookup an `ArchetypeID` by its set of `ComponentID`s. +-- +-- @since 0.9 +lookupArchetypeId :: Set ComponentID -> Archetypes -> 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 aId arches = Map.lookup aId (nodes arches) + +-- | Insert a component into an entity with its `ComponentID`. +-- +-- @since 0.9 +insert :: + EntityID -> + ArchetypeID -> + Set ComponentID -> + DynamicBundle -> + Archetypes -> + (Maybe ArchetypeID, Archetypes) +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}) + else + let cIds' = cIds <> nodeComponentIds node + in case lookupArchetypeId cIds' arches of + Just nextAId -> + let !(cs, arch) = A.remove e $ nodeArchetype node + node' = node {nodeArchetype = arch} + !nodes' = Map.insert aId node' $ nodes arches + adjustNode nextNode = + let nextArch = nodeArchetype nextNode + nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch} + !nextArch'' = A.insertComponents e cs nextArch' + in nextNode {nodeArchetype = runDynamicBundle b e nextArch''} + in (Just nextAId, arches {nodes = Map.adjust adjustNode nextAId nodes'}) + 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} + !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch} + !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'} + in (Just nextAId, arches') + Nothing -> (Nothing, arches) + +-- | Remove a component from an entity with its `ComponentID`. +-- +-- @since 0.9 +remove :: + (Component a) => + EntityID -> + ArchetypeID -> + ComponentID -> + Archetypes -> + (Maybe (a, ArchetypeID), Archetypes) +remove e aId cId arches = case lookup aId arches of + Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of + Just nextAId -> + let !(cs, arch') = A.remove e (nodeArchetype node) + !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)} + (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs + go' archAcc (itemCId, dyn) = + let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s + 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')} + ) + Nothing -> + let !(cs, arch') = A.removeStorages e (nodeArchetype node) + (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs + !n = + Node + { nodeComponentIds = Set.insert cId (nodeComponentIds node), + nodeArchetype = Archetype {storages = cs', entities = Set.singleton e} + } + !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches + node' = node {nodeArchetype = arch'} + removeDyn s = + let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') $ toAscListDyn s + in (res, fromAscListDyn $ Map.elems dyns) + in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)), + arches' {nodes = Map.insert aId node' (nodes arches')} + ) + Nothing -> (Nothing, arches) diff --git a/src/Aztecs/ECS/World/Bundle.hs b/src/Aztecs/ECS/World/Bundle.hs --- a/src/Aztecs/ECS/World/Bundle.hs +++ b/src/Aztecs/ECS/World/Bundle.hs @@ -1,69 +1,69 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World.Bundle --- 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 - ( Bundle (..), - bundle, - fromDynBundle, - runBundle, - ) -where - -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Archetype -import Aztecs.ECS.World.Bundle.Dynamic -import Aztecs.ECS.World.Components -import qualified Aztecs.ECS.World.Components as CS -import Data.Set (Set) -import qualified Data.Set as Set - --- | Bundle of components. --- --- @since 0.9 -newtype Bundle = Bundle - { -- | Unwrap the bundle. - -- - -- @since 0.9 - unBundle :: Components -> (Set ComponentID, Components, DynamicBundle) - } - --- | @since 0.9 -instance Monoid Bundle where - mempty = Bundle (Set.empty,,mempty) - --- | @since 0.9 -instance Semigroup Bundle where - Bundle b1 <> Bundle b2 = Bundle $ \cs -> - let (cIds1, cs', d1) = b1 cs - (cIds2, cs'', d2) = b2 cs' - in (cIds1 <> cIds2, cs'', d1 <> d2) - --- | @since 0.11 -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) - -fromDynBundle :: DynamicBundle -> Bundle -fromDynBundle d = Bundle (Set.empty,,d) - --- | Insert a bundle of components into an archetype. --- --- @since 0.9 -runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype) -runBundle b cs eId arch = - let !(_, cs', d) = unBundle b cs - !arch' = runDynamicBundle d eId arch - in (cs', arch') +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Bundle +-- 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 + ( Bundle (..), + bundle, + fromDynBundle, + runBundle, + ) +where + +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Archetype +import Aztecs.ECS.World.Bundle.Dynamic +import Aztecs.ECS.World.Components +import qualified Aztecs.ECS.World.Components as CS +import Data.Set (Set) +import qualified Data.Set as Set + +-- | Bundle of components. +-- +-- @since 0.9 +newtype Bundle = Bundle + { -- | Unwrap the bundle. + -- + -- @since 0.9 + unBundle :: Components -> (Set ComponentID, Components, DynamicBundle) + } + +-- | @since 0.9 +instance Monoid Bundle where + mempty = Bundle (Set.empty,,mempty) + +-- | @since 0.9 +instance Semigroup Bundle where + Bundle b1 <> Bundle b2 = Bundle $ \cs -> + let (cIds1, cs', d1) = b1 cs + (cIds2, cs'', d2) = b2 cs' + in (cIds1 <> cIds2, cs'', d1 <> d2) + +-- | @since 0.11 +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) + +fromDynBundle :: DynamicBundle -> Bundle +fromDynBundle d = Bundle (Set.empty,,d) + +-- | Insert a bundle of components into an archetype. +-- +-- @since 0.9 +runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype) +runBundle b cs eId arch = + let !(_, cs', d) = unBundle b cs + !arch' = runDynamicBundle d eId arch + in (cs', arch') diff --git a/src/Aztecs/ECS/World/Bundle/Dynamic.hs b/src/Aztecs/ECS/World/Bundle/Dynamic.hs --- a/src/Aztecs/ECS/World/Bundle/Dynamic.hs +++ b/src/Aztecs/ECS/World/Bundle/Dynamic.hs @@ -1,30 +1,30 @@ --- | --- Module : Aztecs.ECS.World.Bundle.Dynamic --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), dynBundle) where - -import Aztecs.ECS.Component -import Aztecs.ECS.Entity -import Aztecs.ECS.World.Archetype - --- | Dynamic bundle of components. --- --- @since 0.9 -newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype} - --- | @since 0.9 -instance Semigroup DynamicBundle where - DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch) - --- | @since 0.9 -instance Monoid DynamicBundle where - mempty = DynamicBundle $ \_ arch -> arch - --- | @since 0.11 -dynBundle :: (Component a) => ComponentID -> a -> DynamicBundle -dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch +-- | +-- Module : Aztecs.ECS.World.Bundle.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), dynBundle) where + +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Archetype + +-- | Dynamic bundle of components. +-- +-- @since 0.9 +newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype} + +-- | @since 0.9 +instance Semigroup DynamicBundle where + DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch) + +-- | @since 0.9 +instance Monoid DynamicBundle where + mempty = DynamicBundle $ \_ arch -> arch + +-- | @since 0.11 +dynBundle :: (Component a) => ComponentID -> a -> DynamicBundle +dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch diff --git a/src/Aztecs/ECS/World/Components.hs b/src/Aztecs/ECS/World/Components.hs --- a/src/Aztecs/ECS/World/Components.hs +++ b/src/Aztecs/ECS/World/Components.hs @@ -1,84 +1,84 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Aztecs.ECS.World.Components --- 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 - ( ComponentID (..), - Components (..), - empty, - lookup, - insert, - insert', - ) -where - -import Aztecs.ECS.Component -import Control.DeepSeq -import Data.Map.Strict (Map) -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, NFData) - --- | Empty `Components`. --- --- @since 0.9 -empty :: Components -empty = - Components - { componentIds = mempty, - nextComponentId = ComponentID 0 - } - --- | 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 cs = case lookup @a cs of - Just cId -> (cId, cs) - Nothing -> insert' @a cs - --- | Insert a component ID by type. --- --- @since 0.9 -insert' :: forall c. (Component c) => Components -> (ComponentID, Components) -insert' cs = - let !cId = nextComponentId cs - in ( cId, - cs - { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs), - nextComponentId = ComponentID (unComponentId cId + 1) - } - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Aztecs.ECS.World.Components +-- 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 + ( ComponentID (..), + Components (..), + empty, + lookup, + insert, + insert', + ) +where + +import Aztecs.ECS.Component +import Control.DeepSeq +import Data.Map.Strict (Map) +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, NFData) + +-- | Empty `Components`. +-- +-- @since 0.9 +empty :: Components +empty = + Components + { componentIds = mempty, + nextComponentId = ComponentID 0 + } + +-- | 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 cs = case lookup @a cs of + Just cId -> (cId, cs) + Nothing -> insert' @a cs + +-- | Insert a component ID by type. +-- +-- @since 0.9 +insert' :: forall c. (Component c) => Components -> (ComponentID, Components) +insert' cs = + let !cId = nextComponentId cs + in ( cId, + cs + { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs), + nextComponentId = ComponentID (unComponentId cId + 1) + } + ) diff --git a/src/Aztecs/ECS/World/Entities.hs b/src/Aztecs/ECS/World/Entities.hs --- a/src/Aztecs/ECS/World/Entities.hs +++ b/src/Aztecs/ECS/World/Entities.hs @@ -1,206 +1,206 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World.Entities --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Entities - ( Entities (..), - empty, - spawn, - spawnWithArchetypeId, - insert, - insertDyn, - lookup, - remove, - removeWithId, - despawn, - ) -where - -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 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 Control.DeepSeq -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, NFData) - --- | Empty `World`. --- --- @since 0.9 -empty :: Entities -empty = - Entities - { archetypes = AS.empty, - components = CS.empty, - entities = mempty - } - --- | Spawn a `Bundle`. --- --- @since 0.9 -spawn :: EntityID -> Bundle -> Entities -> Entities -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) - } - Nothing -> - let arch' = 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' - } - --- | Spawn a `DynamicBundle` with a specified `ArchetypeID`. --- --- @since 0.9 -spawnWithArchetypeId :: - EntityID -> - ArchetypeID -> - DynamicBundle -> - Entities -> - Entities -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) - } - --- | Insert a component into an entity. --- --- @since 0.9 -insert :: EntityID -> Bundle -> Entities -> Entities -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 -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 - es = case maybeNextAId of - Just nextAId -> Map.insert e nextAId $ entities w - Nothing -> entities w - in w {archetypes = arches, entities = es} - Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of - Just aId -> spawnWithArchetypeId e aId b w - Nothing -> - let arch = 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)} - --- | Lookup a component in an entity. --- --- @since 0.9 -lookup :: forall a. (Component a) => EntityID -> Entities -> 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 e w = - let !(cId, components') = CS.insert @a (components w) - in removeWithId @a 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) -removeWithId e cId w = case Map.lookup e (entities w) of - Just aId -> - let (res, as) = AS.remove @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) - --- | Despawn an entity, returning its components. --- --- @since 0.9 -despawn :: EntityID -> Entities -> (IntMap Dynamic, Entities) -despawn e w = - let res = do - !aId <- Map.lookup e $ entities w - !node <- AS.lookup aId $ archetypes w - return (aId, node) - in case res of - Just (aId, node) -> - let !(dynAcc, arch') = A.remove e (nodeArchetype node) - in ( dynAcc, - w - { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, - entities = Map.delete e (entities w) - } - ) - Nothing -> (IntMap.empty, w) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Entities +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Entities + ( Entities (..), + empty, + spawn, + spawnWithArchetypeId, + insert, + insertDyn, + lookup, + remove, + removeWithId, + despawn, + ) +where + +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 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 Control.DeepSeq +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, NFData) + +-- | Empty `World`. +-- +-- @since 0.9 +empty :: Entities +empty = + Entities + { archetypes = AS.empty, + components = CS.empty, + entities = mempty + } + +-- | Spawn a `Bundle`. +-- +-- @since 0.9 +spawn :: EntityID -> Bundle -> Entities -> Entities +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) + } + Nothing -> + let arch' = 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' + } + +-- | Spawn a `DynamicBundle` with a specified `ArchetypeID`. +-- +-- @since 0.9 +spawnWithArchetypeId :: + EntityID -> + ArchetypeID -> + DynamicBundle -> + Entities -> + Entities +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) + } + +-- | Insert a component into an entity. +-- +-- @since 0.9 +insert :: EntityID -> Bundle -> Entities -> Entities +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 +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 + es = case maybeNextAId of + Just nextAId -> Map.insert e nextAId $ entities w + Nothing -> entities w + in w {archetypes = arches, entities = es} + Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of + Just aId -> spawnWithArchetypeId e aId b w + Nothing -> + let arch = 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)} + +-- | Lookup a component in an entity. +-- +-- @since 0.9 +lookup :: forall a. (Component a) => EntityID -> Entities -> 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 e w = + let !(cId, components') = CS.insert @a (components w) + in removeWithId @a 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) +removeWithId e cId w = case Map.lookup e (entities w) of + Just aId -> + let (res, as) = AS.remove @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) + +-- | Despawn an entity, returning its components. +-- +-- @since 0.9 +despawn :: EntityID -> Entities -> (IntMap Dynamic, Entities) +despawn e w = + let res = do + !aId <- Map.lookup e $ entities w + !node <- AS.lookup aId $ archetypes w + return (aId, node) + in case res of + Just (aId, node) -> + let !(dynAcc, arch') = A.remove e (nodeArchetype node) + in ( dynAcc, + w + { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, + entities = Map.delete e (entities w) + } + ) + Nothing -> (IntMap.empty, w) diff --git a/src/Aztecs/ECS/World/Storage.hs b/src/Aztecs/ECS/World/Storage.hs --- a/src/Aztecs/ECS/World/Storage.hs +++ b/src/Aztecs/ECS/World/Storage.hs @@ -1,76 +1,75 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Aztecs.ECS.World.Storage --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Storage (Storage (..)) where - -import Control.DeepSeq -import qualified Control.Monad -import qualified Control.Monad as M -import Data.Data -import Prelude hiding (zipWith) -import qualified Prelude - --- | Component storage, containing zero or many components of the same type. --- --- @since 0.9 -class (Typeable s, NFData s, Typeable a) => Storage a s where - -- | Storage with a single component. - -- - -- @since 0.9 - singleton :: a -> s - - -- | List of all components in the storage in ascending order. - -- - -- @since 0.9 - toAscList :: s -> [a] - - -- | Convert a sorted list of components (in ascending order) into a storage. - -- - -- @since 0.9 - fromAscList :: [a] -> s - - -- | Map a function over all components in the storage. - -- - -- - -- @since 0.11 - map :: (a -> a) -> s -> ([a], s) - - -- | Map a monadic function over all components in the storage. - -- - -- @since 0.11 - mapM :: (Monad m) => (a -> m a) -> s -> m ([a], s) - - -- | Map a function with some input over all components in the storage. - -- - -- @since 0.11 - zipWith :: (b -> a -> (c, a)) -> [b] -> s -> ([(c, a)], s) - - -- | Map an applicative functor with some input over all components in the storage. - -- - -- @since 0.11 - zipWithM :: (Applicative m) => (b -> a -> m (c, a)) -> [b] -> s -> m ([(c, a)], s) - --- | @since 0.11 -instance (Typeable a, NFData a) => Storage a [a] where - {-# INLINE singleton #-} - singleton a = [a] - {-# INLINE toAscList #-} - toAscList = id - {-# INLINE fromAscList #-} - fromAscList = id - {-# INLINE map #-} - map f as = let as' = fmap f as in (as', as') - {-# INLINE mapM #-} - mapM f as = (\as' -> (as', as')) <$> M.mapM f as - {-# INLINE zipWith #-} - zipWith f is as = let as' = Prelude.zipWith f is as in (as', fmap snd as') - {-# INLINE zipWithM #-} - zipWithM f is as = (\as' -> (as', fmap snd as')) <$> Control.Monad.zipWithM f is as +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Aztecs.ECS.World.Storage +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Storage (Storage (..)) where + +import qualified Control.Monad +import qualified Control.Monad as M +import Data.Data +import Prelude hiding (zipWith) +import qualified Prelude + +-- | 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 + + -- | List of all components in the storage in ascending order. + -- + -- @since 0.9 + toAscList :: s -> [a] + + -- | Convert a sorted list of components (in ascending order) into a storage. + -- + -- @since 0.9 + fromAscList :: [a] -> s + + -- | Map a function over all components in the storage. + -- + -- + -- @since 0.11 + map :: (a -> a) -> s -> ([a], s) + + -- | Map a monadic function over all components in the storage. + -- + -- @since 0.11 + mapM :: (Monad m) => (a -> m a) -> s -> m ([a], s) + + -- | Map a function with some input over all components in the storage. + -- + -- @since 0.11 + zipWith :: (b -> a -> (c, a)) -> [b] -> s -> ([(c, a)], s) + + -- | Map an applicative functor with some input over all components in the storage. + -- + -- @since 0.11 + zipWithM :: (Applicative m) => (b -> a -> m (c, a)) -> [b] -> s -> m ([(c, a)], s) + +-- | @since 0.11 +instance (Typeable a) => Storage a [a] where + {-# INLINE singleton #-} + singleton a = [a] + {-# INLINE toAscList #-} + toAscList = id + {-# INLINE fromAscList #-} + fromAscList = id + {-# INLINE map #-} + map f as = let as' = fmap f as in (as', as') + {-# INLINE mapM #-} + mapM f as = (\as' -> (as', as')) <$> M.mapM f as + {-# INLINE zipWith #-} + zipWith f is as = let as' = Prelude.zipWith f is as in (as', fmap snd as') + {-# INLINE zipWithM #-} + zipWithM f is as = (\as' -> (as', fmap snd as')) <$> Control.Monad.zipWithM f is as diff --git a/src/Aztecs/ECS/World/Storage/Dynamic.hs b/src/Aztecs/ECS/World/Storage/Dynamic.hs --- a/src/Aztecs/ECS/World/Storage/Dynamic.hs +++ b/src/Aztecs/ECS/World/Storage/Dynamic.hs @@ -1,97 +1,87 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Aztecs.ECS.World.Storage.Dynamic --- Copyright : (c) Matt Hunzinger, 2025 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : matt@hunzinger.me --- Stability : provisional --- Portability : non-portable (GHC extensions) -module Aztecs.ECS.World.Storage.Dynamic - ( DynamicStorage (..), - dynStorage, - singletonDyn, - fromAscListDyn, - toAscListDyn, - ) -where - -import qualified Aztecs.ECS.World.Storage as S -import Control.DeepSeq -import Data.Dynamic -import Data.Maybe - --- | 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 list. - -- - -- @since 0.9 - toAscListDyn' :: !(Dynamic -> [Dynamic]), - -- | Convert from an ascending list. - -- - -- @since 0.9 - fromAscListDyn' :: !([Dynamic] -> Dynamic), - -- | Reduce this storage to normal form. - -- - -- @since 0.9 - storageRnf :: !(Dynamic -> ()) - } - --- | @since 0.9 -instance Show DynamicStorage where - show s = "DynamicStorage " ++ show (storageDyn s) - --- | @since 0.9 -instance NFData DynamicStorage where - rnf s = storageRnf s (storageDyn s) - --- | Create a dynamic storage from a storage. --- --- @since 0.9 -{-# INLINE dynStorage #-} -dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage -dynStorage s = - DynamicStorage - { storageDyn = toDyn s, - singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic, - toAscListDyn' = \d -> map toDyn (S.toAscList @a @s (fromMaybe (error "TODO") $ fromDynamic d)), - fromAscListDyn' = toDyn . S.fromAscList @a @s . map (fromMaybe (error "TODO") . fromDynamic), - storageRnf = maybe () rnf . fromDynamic @s - } - --- | Singleton dynamic storage. --- --- @since 0.9 -singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage -singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} - --- | Convert from an ascending list. --- --- @since 0.9 -fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage -fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns} - --- | Convert this storage to an ascending list. --- --- @since 0.9 -toAscListDyn :: DynamicStorage -> [Dynamic] -toAscListDyn = toAscListDyn' <*> storageDyn +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Storage.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Storage.Dynamic + ( DynamicStorage (..), + dynStorage, + singletonDyn, + fromAscListDyn, + toAscListDyn, + ) +where + +import qualified Aztecs.ECS.World.Storage as S +import Data.Dynamic +import Data.Maybe + +-- | 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 list. + -- + -- @since 0.9 + toAscListDyn' :: !(Dynamic -> [Dynamic]), + -- | Convert from an ascending list. + -- + -- @since 0.9 + fromAscListDyn' :: !([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 +{-# INLINE dynStorage #-} +dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage +dynStorage s = + DynamicStorage + { storageDyn = toDyn s, + singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic, + toAscListDyn' = \d -> map toDyn (S.toAscList @a @s (fromMaybe (error "TODO") $ fromDynamic d)), + fromAscListDyn' = toDyn . S.fromAscList @a @s . map (fromMaybe (error "TODO") . fromDynamic) + } + +-- | Singleton dynamic storage. +-- +-- @since 0.9 +singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage +singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} + +-- | Convert from an ascending list. +-- +-- @since 0.9 +fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage +fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns} + +-- | Convert this storage to an ascending list. +-- +-- @since 0.9 +toAscListDyn :: DynamicStorage -> [Dynamic] +toAscListDyn = toAscListDyn' <*> storageDyn diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,189 +1,127 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Main (main) where - -import Aztecs.ECS -import Aztecs.ECS.Component (ComponentID (ComponentID)) -import qualified Aztecs.ECS.Query as Q -import qualified Aztecs.ECS.Query.Dynamic as Q -import qualified Aztecs.ECS.World as W -import Control.DeepSeq -import Data.Functor.Identity (Identity (runIdentity)) -import Data.Word -import GHC.Generics -import Test.Hspec -import Test.QuickCheck - -newtype X = X Int deriving (Eq, Show, Arbitrary, Generic, NFData) - -instance Component X - -newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic, NFData) - -instance Component Y - -newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic, NFData) - -instance Component Z - -main :: IO () -main = hspec $ do - describe "Aztecs.ECS.Query.querySingle" $ do - it "queries a single entity" prop_querySingle - describe "Aztecs.ECS.Query.queryMapSingle" $ do - it "maps a single entity" $ property prop_queryMapSingle - describe "Aztecs.ECS.Query.query" $ do - it "queries an empty world" prop_queryEmpty - it "queries dynamic components" $ property prop_queryDyn - it "queries a typed component" $ property prop_queryTypedComponent - it "queries 2 typed components" $ property prop_queryTwoTypedComponents - it "queries 3 typed components" $ property prop_queryThreeTypedComponents - -{-TODO -describe "Aztecs.ECS.System.mapSingle" $ do - it "maps a single entity" $ property prop_systemMapSingle -describe "Aztecs.ECS.Hierarchy.update" $ do - it "adds Parent components to children" $ property prop_addParents - it "removes Parent components from removed children" $ property prop_removeParents --} - -prop_queryEmpty :: Expectation -prop_queryEmpty = - let res = fst . runIdentity . Q.query (fetch @_ @X) $ W.entities W.empty in res `shouldMatchList` [] - --- | Query all components from a list of `ComponentID`s. -queryComponentIds :: - forall f a. - (Monad f, Component a) => - [ComponentID] -> - QueryT f (EntityID, [a]) -queryComponentIds = - let go cId qAcc = do - x' <- Q.fromDyn $ Q.fetchDyn @a cId - (e, xs) <- qAcc - return (e, x' : xs) - in foldr go ((,) <$> Q.entity <*> pure []) - -prop_queryDyn :: [[X]] -> Expectation -prop_queryDyn xs = - let s xs' (acc, wAcc) = - let s' x (bAcc, cAcc, idAcc) = - ( fromDynBundle (dynBundle (ComponentID idAcc) x) <> bAcc, - (x, ComponentID idAcc) : cAcc, - idAcc + 1 - ) - (b, cs, _) = foldr s' (mempty, [], 0) xs' - (e, wAcc') = W.spawn b wAcc - in ((e, cs) : acc, wAcc') - (es, w) = foldr s ([], W.empty) xs - go (e, cs) = do - let q = queryComponentIds $ map snd cs - (res, _) = runIdentity . Q.query q $ W.entities w - return $ 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, _) = runIdentity . Q.query Q.fetch $ W.entities w - 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, _) = runIdentity . Q.query ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w - 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 - q = do - x <- Q.fetch - y <- Q.fetch - z <- Q.fetch - pure (x, y, z) - (res, _) = runIdentity . Q.query q $ W.entities w - res `shouldMatchList` xyzs - -prop_querySingle :: Expectation -prop_querySingle = - let (_, w) = W.spawn (bundle $ X 1) W.empty - (res, _) = runIdentity . Q.readSingle Q.fetch $ 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.zipFetchMap (\_ (X x) -> X $ x + 1) (pure ()) - w' = foldr (\_ es -> snd . runIdentity $ Q.querySingle q es) (W.entities w) [1 .. n] - (res, _) = runIdentity $ Q.readSingle Q.fetch w' - in res `shouldBe` X (fromIntegral n) - -{-TODO -prop_systemMapSingle :: Word8 -> Expectation -prop_systemMapSingle n = - let (_, w) = W.spawn (bundle $ X 0) W.empty - q = Q.adjust (\_ (X x) -> X $ x + 1) - 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') - in res `shouldBe` X (fromIntegral n) - -prop_addParents :: Expectation -prop_addParents = do - 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'' - res `shouldMatchList` [Parent e] - -prop_removeParents :: Expectation -prop_removeParents = do - let (_, w) = W.spawnEmpty W.empty - (e, w') = W.spawn (bundle . Children $ Set.singleton e) w - (_, _, 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'''' - res `shouldMatchList` [] --} - -{- -prop_scheduleQueryEntity :: [X] -> Expectation -prop_scheduleQueryEntity xs = do - let go x (eAcc, wAcc) = let (e, wAcc') = W.spawn (bundle x) wAcc in (e : eAcc, wAcc') - (es, w) = foldr go ([], W.empty) xs - (res, _, _) <- runSchedule (reader $ S.all Q.entity) w () - res `shouldMatchList` es - -prop_scheduleUpdate :: Expectation -prop_scheduleUpdate = do - let (_, w) = W.spawn (bundle $ X 1) W.empty - (_, _, w') <- runSchedule update w () - (x, _, _) <- runSchedule update w' () - x `shouldBe` True - -update :: Schedule IO () Bool -update = proc () -> do - rec lastShouldQuit <- delay False -< shouldQuit - x <- - system $ - S.mapSingle - ( proc () -> do - X x <- Q.fetch -< () - Q.set -< X $ x + 1 - returnA -< x - ) - -< - () - let shouldQuit = (lastShouldQuit || x > 1) - returnA -< shouldQuit --} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main (main) where + +import Aztecs.ECS +import Aztecs.ECS.Component (ComponentID (ComponentID)) +import qualified Aztecs.ECS.Query as Q +import qualified Aztecs.ECS.Query.Dynamic as Q +import qualified Aztecs.ECS.World as W +import Control.DeepSeq +import Data.Functor.Identity (Identity (runIdentity)) +import Data.Word +import GHC.Generics +import Test.Hspec +import Test.QuickCheck + +newtype X = X Int deriving (Eq, Show, Arbitrary, Generic, NFData) + +instance Component X + +newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic, NFData) + +instance Component Y + +newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic, NFData) + +instance Component Z + +main :: IO () +main = hspec $ do + describe "Aztecs.ECS.Query.querySingle" $ do + it "queries a single entity" prop_querySingle + describe "Aztecs.ECS.Query.queryMapSingle" $ do + it "maps a single entity" $ property prop_queryMapSingle + describe "Aztecs.ECS.Query.query" $ do + it "queries an empty world" prop_queryEmpty + it "queries dynamic components" $ property prop_queryDyn + it "queries a typed component" $ property prop_queryTypedComponent + it "queries 2 typed components" $ property prop_queryTwoTypedComponents + it "queries 3 typed components" $ property prop_queryThreeTypedComponents + +{-TODO +describe "Aztecs.ECS.System.mapSingle" $ do + it "maps a single entity" $ property prop_systemMapSingle +describe "Aztecs.ECS.Hierarchy.update" $ do + it "adds Parent components to children" $ property prop_addParents + it "removes Parent components from removed children" $ property prop_removeParents +-} + +prop_queryEmpty :: Expectation +prop_queryEmpty = + let res = fst . runIdentity . Q.query (fetch @_ @X) $ W.entities W.empty in res `shouldMatchList` [] + +-- | Query all components from a list of `ComponentID`s. +queryComponentIds :: + forall f a. + (Monad f, Component a) => + [ComponentID] -> + QueryT f (EntityID, [a]) +queryComponentIds = + let go cId qAcc = do + x' <- Q.fromDyn $ Q.fetchDyn @a cId + (e, xs) <- qAcc + return (e, x' : xs) + in foldr go ((,) <$> Q.entity <*> pure []) + +prop_queryDyn :: [[X]] -> Expectation +prop_queryDyn xs = + let s xs' (acc, wAcc) = + let s' x (bAcc, cAcc, idAcc) = + ( fromDynBundle (dynBundle (ComponentID idAcc) x) <> bAcc, + (x, ComponentID idAcc) : cAcc, + idAcc + 1 + ) + (b, cs, _) = foldr s' (mempty, [], 0) xs' + (e, wAcc') = W.spawn b wAcc + in ((e, cs) : acc, wAcc') + (es, w) = foldr s ([], W.empty) xs + go (e, cs) = do + let q = queryComponentIds $ map snd cs + (res, _) = runIdentity . Q.query q $ W.entities w + return $ 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, _) = runIdentity . Q.query Q.fetch $ W.entities w + 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, _) = runIdentity . Q.query ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w + 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 + q = do + x <- Q.fetch + y <- Q.fetch + z <- Q.fetch + pure (x, y, z) + (res, _) = runIdentity . Q.query q $ W.entities w + res `shouldMatchList` xyzs + +prop_querySingle :: Expectation +prop_querySingle = + let (_, w) = W.spawn (bundle $ X 1) W.empty + (res, _) = runIdentity . Q.readQuerySingle Q.fetch $ 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.zipFetchMap (\_ (X x) -> X $ x + 1) (pure ()) + w' = foldr (\_ es -> snd . runIdentity $ Q.querySingle q es) (W.entities w) [1 .. n] + (res, _) = runIdentity $ Q.readQuerySingle Q.fetch w' + in res `shouldBe` X (fromIntegral n)