aztecs 0.10.0 → 0.17.1
raw patch · 58 files changed
Files
- LICENSE +29/−29
- aztecs.cabal +97/−107
- bench/Bench.hs +18/−10
- src/Aztecs.hs +8/−88
- src/Aztecs/Asset.hs +0/−32
- src/Aztecs/Asset/AssetLoader.hs +0/−99
- src/Aztecs/Asset/AssetLoader/Class.hs +0/−23
- src/Aztecs/Asset/AssetServer.hs +0/−142
- src/Aztecs/Asset/Class.hs +0/−27
- src/Aztecs/Camera.hs +0/−78
- src/Aztecs/ECS.hs +125/−100
- src/Aztecs/ECS/Access.hs +110/−176
- src/Aztecs/ECS/Access/Class.hs +0/−52
- src/Aztecs/ECS/Access/Internal.hs +79/−0
- src/Aztecs/ECS/Component.hs +46/−41
- src/Aztecs/ECS/Component/Internal.hs +21/−0
- src/Aztecs/ECS/Entity.hs +1/−6
- src/Aztecs/ECS/Event.hs +47/−0
- src/Aztecs/ECS/Observer.hs +102/−0
- src/Aztecs/ECS/Query.hs +404/−316
- src/Aztecs/ECS/Query/Class.hs +0/−41
- src/Aztecs/ECS/Query/Dynamic.hs +288/−200
- src/Aztecs/ECS/Query/Dynamic/Class.hs +45/−20
- src/Aztecs/ECS/Query/Dynamic/Reader.hs +0/−146
- src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs +0/−32
- src/Aztecs/ECS/Query/Reader.hs +0/−175
- src/Aztecs/ECS/Query/Reader/Class.hs +0/−26
- src/Aztecs/ECS/System.hs +117/−132
- src/Aztecs/ECS/System/Class.hs +0/−44
- src/Aztecs/ECS/System/Dynamic.hs +145/−0
- src/Aztecs/ECS/System/Dynamic/Class.hs +0/−43
- src/Aztecs/ECS/System/Dynamic/Reader/Class.hs +0/−50
- src/Aztecs/ECS/System/Reader/Class.hs +0/−49
- src/Aztecs/ECS/View.hs +34/−53
- src/Aztecs/ECS/World.hs +89/−105
- src/Aztecs/ECS/World/Archetype.hs +275/−261
- src/Aztecs/ECS/World/Archetype/Internal.hs +41/−0
- src/Aztecs/ECS/World/Archetypes.hs +204/−254
- src/Aztecs/ECS/World/Archetypes/Internal.hs +55/−0
- src/Aztecs/ECS/World/Bundle.hs +31/−28
- src/Aztecs/ECS/World/Bundle/Class.hs +0/−23
- src/Aztecs/ECS/World/Bundle/Dynamic.hs +39/−30
- src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs +9/−6
- src/Aztecs/ECS/World/Components.hs +4/−31
- src/Aztecs/ECS/World/Components/Internal.hs +25/−0
- src/Aztecs/ECS/World/Entities.hs +187/−206
- src/Aztecs/ECS/World/Entities/Internal.hs +28/−0
- src/Aztecs/ECS/World/Internal.hs +26/−0
- src/Aztecs/ECS/World/Observers.hs +126/−0
- src/Aztecs/ECS/World/Observers/Internal.hs +53/−0
- src/Aztecs/ECS/World/Storage.hs +45/−40
- src/Aztecs/ECS/World/Storage/Dynamic.hs +70/−97
- src/Aztecs/Hierarchy.hs +184/−255
- src/Aztecs/Input.hs +0/−258
- src/Aztecs/Time.hs +0/−30
- src/Aztecs/Transform.hs +0/−169
- src/Aztecs/Window.hs +0/−30
- test/Main.hs +50/−42
LICENSE view
@@ -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.
aztecs.cabal view
@@ -1,107 +1,97 @@-cabal-version: 2.4-name: aztecs-version: 0.10.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- Aztecs.ECS- Aztecs.ECS.Access- Aztecs.ECS.Access.Class- Aztecs.ECS.Component- Aztecs.ECS.Entity- Aztecs.ECS.Query- Aztecs.ECS.Query.Class- Aztecs.ECS.Query.Dynamic- Aztecs.ECS.Query.Dynamic.Class- Aztecs.ECS.Query.Dynamic.Reader- Aztecs.ECS.Query.Dynamic.Reader.Class- Aztecs.ECS.Query.Reader- Aztecs.ECS.Query.Reader.Class- Aztecs.ECS.System- Aztecs.ECS.System.Class- Aztecs.ECS.System.Dynamic.Class- Aztecs.ECS.System.Dynamic.Reader.Class- Aztecs.ECS.System.Reader.Class- Aztecs.ECS.View- Aztecs.ECS.World- Aztecs.ECS.World.Archetype- Aztecs.ECS.World.Archetypes- Aztecs.ECS.World.Bundle- Aztecs.ECS.World.Bundle.Class- Aztecs.ECS.World.Bundle.Dynamic- Aztecs.ECS.World.Bundle.Dynamic.Class- Aztecs.ECS.World.Components- Aztecs.ECS.World.Entities- Aztecs.ECS.World.Storage- Aztecs.ECS.World.Storage.Dynamic- Aztecs.Asset- Aztecs.Asset.AssetLoader- Aztecs.Asset.AssetLoader.Class- Aztecs.Asset.AssetServer- Aztecs.Asset.Class- Aztecs.Camera- Aztecs.Hierarchy- Aztecs.Input- Aztecs.Time- Aztecs.Transform- Aztecs.Window-- hs-source-dirs: src- default-language: Haskell2010- ghc-options: -Wall- build-depends:- base >=4.2 && <5,- containers >=0.6,- deepseq >=1,- linear >=1,- mtl >=2,- parallel >=3,- stm >=2--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.17.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 + Aztecs.ECS + Aztecs.ECS.Access + Aztecs.ECS.Access.Internal + Aztecs.ECS.Component + Aztecs.ECS.Component.Internal + Aztecs.ECS.Entity + Aztecs.ECS.Event + Aztecs.ECS.Observer + Aztecs.ECS.Query + Aztecs.ECS.Query.Dynamic + Aztecs.ECS.Query.Dynamic.Class + Aztecs.ECS.System + Aztecs.ECS.System.Dynamic + Aztecs.ECS.View + Aztecs.ECS.World + Aztecs.ECS.World.Archetype + Aztecs.ECS.World.Archetype.Internal + Aztecs.ECS.World.Archetypes + Aztecs.ECS.World.Archetypes.Internal + Aztecs.ECS.World.Bundle + Aztecs.ECS.World.Bundle.Dynamic + Aztecs.ECS.World.Bundle.Dynamic.Class + Aztecs.ECS.World.Components + Aztecs.ECS.World.Components.Internal + Aztecs.ECS.World.Entities + Aztecs.ECS.World.Entities.Internal + Aztecs.ECS.World.Internal + Aztecs.ECS.World.Observers + Aztecs.ECS.World.Observers.Internal + Aztecs.ECS.World.Storage + Aztecs.ECS.World.Storage.Dynamic + Aztecs.Hierarchy + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.2 && <5, + containers >=0.6, + mtl >=2, + vector >=0.12 + +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, + vector >=0.12 + +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, + vector >=0.12
bench/Bench.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} import Aztecs.ECS import qualified Aztecs.ECS.Query as Q@@ -8,26 +10,32 @@ import qualified Aztecs.ECS.World as W import Control.DeepSeq import Criterion.Main-import Data.Function-import Data.Functor.Identity+import Data.Functor.Identity (Identity (runIdentity))+import Data.Vector (Vector) import GHC.Generics newtype Position = Position Int deriving (Show, Generic, NFData) -instance Component Position+instance (Monad m) => Component m Position newtype Velocity = Velocity Int deriving (Show, Generic, NFData) -instance Component Velocity+instance (Monad m) => Component m Velocity -query :: Query Position-query = Q.fetch & Q.adjust (\(Velocity v) (Position p) -> Position $ p + v)+move :: (Monad m) => Query m Position+move = queryMapWith (\(Velocity v) (Position p) -> (Position $ p + v)) query -run :: Query Position -> World -> [Position]-run q = fst . runIdentity . Q.map q . entities+run :: Query Identity Position -> World Identity -> Vector Position+run q = (\(a, _, _) -> a) . runIdentity . Q.runQuery q . entities +runSys :: Query Identity Position -> World Identity -> Vector Position+runSys q = fst . runIdentity . runAccess (system $ runQuery q)+ main :: IO () main = do- let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc+ let go wAcc = (\(_, w', _) -> w') $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc !w = foldr (const go) W.empty [0 :: Int .. 10000]- defaultMain [bench "iter" $ nf (run query) w]+ defaultMain+ [ bench "iter" $ nf (run move) w,+ bench "iterSystem" $ nf (runSys move) w+ ]
src/Aztecs.hs view
@@ -1,88 +1,8 @@--- | Aztecs is a type-safe and friendly ECS for games and more.------ An ECS is a modern approach to organizing your application state as a database,--- providing patterns for data-oriented design and parallel processing.------ The ECS architecture is composed of three main concepts:------ === Entities--- An entity is an object comprised of zero or more components.--- In Aztecs, entities are represented by their `EntityID`, a unique identifier.------ === Components--- A `Component` holds the data for a particular aspect of an entity.--- For example, a zombie entity might have a @Health@ and a @Transform@ component.------ > newtype Position = Position Int deriving (Show)--- > instance Component Position--- >--- > newtype Velocity = Velocity Int deriving (Show)--- > instance Component Velocity------ === Systems--- A `System` is a pipeline that processes entities and their components.--- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.------ Systems can access game state in two ways:------ ==== Access--- An `Access` can be queued for full access to the `World`, after a system is complete.--- `Access` allows for spawning, inserting, and removing components.------ > setup :: System () ()--- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)------ ==== Queries--- A `Query` can read and write matching components.------ > move :: System () ()--- > move =--- > S.map--- > ( proc () -> do--- > Velocity v <- Q.fetch -< ()--- > Position p <- Q.fetch -< ()--- > Q.set -< Position $ p + v--- > )--- > >>> S.run print------ Finally, systems can be run on a `World` to produce a result.------ > main :: IO ()--- > main = runSystem_ $ setup >>> S.forever move-module Aztecs- ( module Aztecs.ECS,- asset,- load,- Camera (..),- CameraTarget (..),- Key (..),- KeyboardInput (..),- isKeyPressed,- wasKeyPressed,- wasKeyReleased,- MouseInput (..),- Time (..),- Transform (..),- Transform2D,- transform2d,- Size (..),- Size2D,- size2D,- Window (..),- )-where--import Aztecs.Asset (asset, load)-import Aztecs.Camera-import Aztecs.ECS-import Aztecs.Input- ( Key (..),- KeyboardInput (..),- MouseInput (..),- isKeyPressed,- wasKeyPressed,- wasKeyReleased,- )-import Aztecs.Time-import Aztecs.Transform-import Aztecs.Window+-- | Aztecs is a type-safe and friendly ECS for games and more. +-- +-- An ECS is a modern approach to organizing your application state as a database, +-- providing patterns for data-oriented design and parallel processing. +module Aztecs (module Aztecs.ECS, module Aztecs.Hierarchy) where + +import Aztecs.ECS +import Aztecs.Hierarchy
− src/Aztecs/Asset.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.Asset--- 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.Asset- ( AssetId (..),- AssetServer (..),- MonadAssetLoader (..),- Asset (..),- Handle (..),- lookupAsset,- setup,- loadAssets,- load,- )-where--import Aztecs.Asset.AssetLoader-import Aztecs.Asset.AssetServer-import Aztecs.Asset.Class
− src/Aztecs/Asset/AssetLoader.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- |--- Module : Aztecs.Asset.AssetLoader--- 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.Asset.AssetLoader- ( AssetLoader,- AssetLoaderT (..),- MonadAssetLoader (..),- load,- loadQuery,- )-where--import Aztecs.Asset.AssetLoader.Class-import Aztecs.Asset.AssetServer-import Aztecs.Asset.Class-import Aztecs.ECS-import Aztecs.ECS.Query (QueryT (..))-import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Dynamic (DynamicQueryT (DynamicQuery, runDynQuery))-import qualified Aztecs.ECS.System as S-import Control.Concurrent-import Control.Monad.Identity-import Control.Monad.State.Strict-import Control.Monad.Writer-import Data.IORef-import qualified Data.Map.Strict as Map---- | @since 0.9-type AssetLoader a o = AssetLoaderT a Identity o---- | Asset loader monad.------ @since 0.9-newtype AssetLoaderT a m o = AssetLoaderT- { -- | State of the asset loader.- --- -- @since 0.9- unAssetLoader :: StateT (AssetServer a) m o- }- deriving newtype (Functor, Applicative, Monad)---- | @since 0.9-instance (Monad m, Asset a) => MonadAssetLoader a (AssetLoaderT a m) where- asset path cfg = AssetLoaderT $ do- server <- get- let assetId = nextAssetId server- go = do- v <- newIORef Nothing- _ <- forkIO $ do- a <- loadAsset path cfg- writeIORef v (Just a)- return v- put $- server- { loadingAssets = Map.insert assetId (Left go) (loadingAssets server),- nextAssetId = AssetId (unAssetId assetId + 1)- }- return $ Handle assetId---- | Query to load assets.------ @since 0.9-loadQuery :: (Asset a) => AssetLoader a o -> Query o-loadQuery a =- -- TODO- Query $ \cs ->- let q =- Q.adjustM- ( \_ server -> do- let (o, server') = runState (unAssetLoader a) server- tell [o]- return server'- )- (pure ())- (rws, cs', dynQ) = runQuery q cs- in ( rws,- cs',- DynamicQuery $ \arch ->- let ((_, arch'), os) = runWriter $ runDynQuery dynQ arch in return (os, arch')- )---- | System to load assets.------ @since 0.9-load :: (MonadSystem Query s, Asset a) => AssetLoader a o -> s o-load a = S.mapSingle $ loadQuery a
− src/Aztecs/Asset/AssetLoader/Class.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.Asset.AssetLoader.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.Asset.AssetLoader.Class (MonadAssetLoader (..)) where--import Aztecs.Asset.AssetServer-import Aztecs.Asset.Class---- | Monadic interface for loading assets.------ @since 0.9-class MonadAssetLoader a m | m -> a where- -- | Load an asset from a file path with a configuration.- --- -- @since 0.9- asset :: FilePath -> AssetConfig a -> m (Handle a)
− src/Aztecs/Asset/AssetServer.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module : Aztecs.Asset.AssetServer--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.Asset.AssetServer- ( AssetId (..),- Handle (..),- AssetServer (..),- assetServer,- lookupAsset,- setup,- loadAssets,- loadAssetServer,- )-where--import Aztecs.ECS-import qualified Aztecs.ECS.Access as A-import qualified Aztecs.ECS.Query as Q-import qualified Aztecs.ECS.System as S-import Control.DeepSeq-import Control.Monad-import Control.Monad.IO.Class-import Data.Data-import Data.Foldable-import Data.IORef-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import GHC.Generics---- | Unique identifier for an asset.------ @since 0.9-newtype AssetId = AssetId- { -- | Unique integer identifier.- --- -- @since 0.9- unAssetId :: Int- }- deriving (Eq, Ord, Show)---- | Asset server.------ @since 0.9-data AssetServer a = AssetServer- { -- | Loaded assets.- --- -- @since 0.9- assetServerAssets :: !(Map AssetId a),- -- | Assets currently being loaded.- --- -- @since 0.9- loadingAssets :: !(Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))),- -- | Next unique asset identifier.- --- -- @since 0.9- nextAssetId :: !AssetId- }- deriving (Generic)---- | @since 0.9-instance (Typeable a) => Component (AssetServer a)---- | @since 0.9-instance NFData (AssetServer a) where- rnf = rwhnf---- | Empty asset server.------ @since 0.9-assetServer :: AssetServer a-assetServer =- AssetServer- { assetServerAssets = Map.empty,- loadingAssets = Map.empty,- nextAssetId = AssetId 0- }---- | Handle to an asset.------ @since 0.9-newtype Handle a = Handle- { -- | Asset ID.- --- -- @since 0.9- handleId :: AssetId- }- deriving (Eq, Ord, Show)---- | @since 0.9-instance NFData (Handle a) where- rnf = rwhnf---- | Lookup an asset by its handle.------ @since 0.9-lookupAsset :: Handle a -> AssetServer a -> Maybe a-lookupAsset h server = Map.lookup (handleId h) (assetServerAssets server)---- | Setup the asset server.------ @since 0.9-setup :: forall m b a. (Typeable a, MonadAccess b m) => m ()-setup = A.spawn_ . bundle $ assetServer @a---- | Load any pending assets.------ @since 0.9-loadAssets :: forall a q s m. (Typeable a, QueryF m q, Applicative q, MonadSystem q s, MonadIO m) => s ()-loadAssets = void $ S.map (Q.adjustM (\_ s -> loadAssetServer @m @a s) (pure ())) -- TODO Q.setM---- | Load any pending assets in an `AssetServer`.------ @since 0.9-loadAssetServer :: (MonadIO m) => AssetServer a -> m (AssetServer a)-loadAssetServer server =- let go (aId, v) acc = do- case v of- Right r -> do- maybeSurface <- readIORef r- case maybeSurface of- Just surface ->- return- acc- { assetServerAssets = Map.insert aId surface (assetServerAssets acc),- loadingAssets = Map.delete aId (loadingAssets acc)- }- Nothing -> return acc- Left f -> do- v' <- f- return $ acc {loadingAssets = Map.insert aId (Right v') (loadingAssets server)}- in liftIO . foldrM go server . Map.toList $ loadingAssets server
− src/Aztecs/Asset/Class.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.Asset.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.Asset.Class (Asset (..)) where--import Data.Data---- | Loadable asset.------ @since 0.9-class (Typeable a) => Asset a where- -- | Configuration for loading an asset.- --- -- @since 0.9- type AssetConfig a-- -- | Load an asset from a file path with a configuration.- --- -- @since 0.9- loadAsset :: FilePath -> AssetConfig a -> IO a
− src/Aztecs/Camera.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module : Aztecs.Camera--- 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.Camera- ( Camera (..),- CameraTarget (..),- addCameraTargets,- )-where--import Aztecs.ECS-import qualified Aztecs.ECS.Access as A-import qualified Aztecs.ECS.Query.Reader as Q-import qualified Aztecs.ECS.System as S-import Aztecs.Window-import Control.DeepSeq-import GHC.Generics-import Linear---- | Camera component.------ @since 0.9-data Camera = Camera- { -- | Camera viewport size.- --- -- @since 0.9- cameraViewport :: !(V2 Int),- -- | Camera scale factor.- --- -- @since 0.9- cameraScale :: !(V2 Float)- }- deriving (Show, Generic, NFData)---- | @since 0.9-instance Component Camera---- | Camera target component.------ @since 0.9-newtype CameraTarget = CameraTarget- { -- | This camera's target window.- --- -- @since 0.9- cameraTargetWindow :: EntityID- }- deriving (Eq, Show, Generic, NFData)---- | @since 0.9-instance Component CameraTarget---- | Add `CameraTarget` components to entities with a new `Draw` component.------ @since 0.9-addCameraTargets ::- ( Applicative qr,- QueryReaderF qr,- DynamicQueryReaderF qr,- MonadReaderSystem qr s,- MonadAccess b m- ) =>- s (m ())-addCameraTargets = do- windows <- S.all ((,) <$> Q.entity <*> Q.fetch @_ @Window)- newCameras <- S.filter ((,) <$> Q.entity <*> Q.fetch @_ @Camera) (without @CameraTarget)- let go = case windows of- (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId . bundle $ CameraTarget windowEId) newCameras- _ -> return ()- return go
src/Aztecs/ECS.hs view
@@ -1,100 +1,125 @@--- | Aztecs is a type-safe and friendly ECS for games and more.------ An ECS is a modern approach to organizing your application state as a database,--- providing patterns for data-oriented design and parallel processing.------ The ECS architecture is composed of three main concepts:------ === Entities--- An entity is an object comprised of zero or more components.--- In Aztecs, entities are represented by their `EntityID`, a unique identifier.------ === Components--- A `Component` holds the data for a particular aspect of an entity.--- For example, a zombie entity might have a @Health@ and a @Transform@ component.------ > newtype Position = Position Int deriving (Show)--- > instance Component Position--- >--- > newtype Velocity = Velocity Int deriving (Show)--- > instance Component Velocity------ === Systems--- A `System` is a pipeline that processes entities and their components.--- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.------ Systems can access game state in two ways:------ ==== Access--- An `Access` can be queued for full access to the `World`, after a system is complete.--- `Access` allows for spawning, inserting, and removing components.------ > setup :: System () ()--- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)------ ==== Queries--- A `Query` can read and write matching components.------ > move :: System () ()--- > move =--- > S.map--- > ( proc () -> do--- > Velocity v <- Q.fetch -< ()--- > Position p <- Q.fetch -< ()--- > Q.set -< Position $ p + v--- > )--- > >>> S.run print------ Finally, systems can be run on a `World` to produce a result.------ > main :: IO ()--- > main = runSystem_ $ setup >>> S.forever move-module Aztecs.ECS- ( Access,- AccessT,- MonadAccess,- runAccessT,- runAccessT_,- Bundle,- MonoidBundle (..),- DynamicBundle,- MonoidDynamicBundle (..),- Component (..),- EntityID,- Query,- QueryT,- QueryReader,- QueryReaderF,- QueryF,- DynamicQueryReaderF,- DynamicQueryF,- QueryFilter,- with,- without,- System,- SystemT,- MonadReaderSystem,- MonadSystem,- World,- )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Component (Component (..))-import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.Query- ( DynamicQueryF,- DynamicQueryReaderF,- Query,- QueryF,- QueryFilter,- QueryReaderF,- QueryT,- with,- without,- )-import Aztecs.ECS.Query.Reader (QueryReader)-import Aztecs.ECS.System-import Aztecs.ECS.World (World)-import Aztecs.ECS.World.Bundle (Bundle, MonoidBundle (..))-import Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle, MonoidDynamicBundle (..))+-- | Aztecs is a type-safe and friendly ECS for games and more. +-- +-- An ECS is a modern approach to organizing your application state as a database, +-- providing patterns for data-oriented design and parallel processing. +-- +-- The ECS architecture is composed of three main concepts: +-- +-- === Entities +-- An entity is an object comprised of zero or more components. +-- In Aztecs, entities are represented by their `EntityID`, a unique identifier. +-- +-- === Components +-- A `Component` holds the data for a particular aspect of an entity. +-- For example, a zombie entity might have a @Health@ and a @Transform@ component. +-- +-- > newtype Position = Position Int deriving (Show) +-- > instance Component Position +-- > +-- > newtype Velocity = Velocity Int deriving (Show) +-- > instance Component Velocity +-- +-- === Systems +-- A `System` is a pipeline that processes entities and their components. +-- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access. +-- +-- Systems can access game state in two ways: +-- +-- ==== Access +-- An `Access` can be queued for full access to the `World`, after a system is complete. +-- `Access` allows for spawning, inserting, and removing components. +-- +-- > setup :: System () () +-- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1) +-- +-- ==== Queries +-- A `Query` can read and write matching components. +-- +-- > move :: System () () +-- > move = +-- > S.map +-- > ( proc () -> do +-- > Velocity v <- Q.query -< () +-- > Position p <- Q.query -< () +-- > Q.set -< Position $ p + v +-- > ) +-- > >>> S.run print +-- +-- Finally, systems can be run on a `World` to produce a result. +-- +-- > main :: IO () +-- > main = runSystem_ $ setup >>> S.forever move +module Aztecs.ECS + ( module Aztecs.ECS.Access, + module Aztecs.ECS.System, + Bundle, + BundleT, + bundle, + DynamicBundle, + MonoidDynamicBundle (..), + Component (..), + EntityID, + Query, + query, + queryMaybe, + queryMap, + queryMapM, + queryMapWith, + queryMapWith_, + queryMapWithM, + queryMapAccum, + queryMapAccumM, + queryMapWithAccum, + queryMapWithAccumM, + DynamicQueryF (..), + QueryFilter, + with, + without, + World, + + -- * Events + Event, + OnInsert (..), + OnChange (..), + OnRemove (..), + + -- * Observers + Observer, + observer, + observerFor, + observerGlobal, + ) +where + +import Aztecs.ECS.Access +import Aztecs.ECS.Component (Component (..)) +import Aztecs.ECS.Entity (EntityID) +import Aztecs.ECS.Event (Event, OnChange (..), OnInsert (..), OnRemove (..)) +import Aztecs.ECS.Observer + ( Observer (..), + observer, + observerFor, + observerGlobal, + ) +import Aztecs.ECS.Query + ( DynamicQueryF (..), + Query, + QueryFilter, + query, + queryMap, + queryMapAccum, + queryMapAccumM, + queryMapM, + queryMapWith, + queryMapWithAccum, + queryMapWithAccumM, + queryMapWithM, + queryMapWith_, + queryMaybe, + with, + without, + ) +import Aztecs.ECS.System +import Aztecs.ECS.World (World) +import Aztecs.ECS.World.Bundle (Bundle, BundleT, bundle) +import Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle, MonoidDynamicBundle (..))
src/Aztecs/ECS/Access.hs view
@@ -1,176 +1,110 @@-{-# LANGUAGE BangPatterns #-}-{-# 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 (..),- MonadAccess (..),- runAccessT,- runAccessT_,- system,- )-where--import Aztecs.ECS.Access.Class-import Aztecs.ECS.Query (QueryT (..))-import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Dynamic (DynamicQueryT)-import qualified Aztecs.ECS.Query.Dynamic as Q-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader)-import qualified Aztecs.ECS.Query.Dynamic.Reader as Q-import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System-import Aztecs.ECS.World (World (..))-import qualified Aztecs.ECS.World as W-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (Node (..))-import Aztecs.ECS.World.Bundle-import qualified Aztecs.ECS.World.Entities as E-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Monad.Fix-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State.Strict-import qualified Data.Foldable as F---- | @since 0.9-type Access = AccessT Identity---- | Access into the `World`.------ @since 0.9-newtype AccessT m a = AccessT {unAccessT :: StateT World m a}- deriving (Functor, Applicative, MonadFix, MonadIO)---- | @since 0.9-instance (Monad m) => Monad (AccessT m) where- a >>= f = AccessT $ do- !w <- get- (a', w') <- lift $ runAccessT a w- put (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---- | @since 0.9-instance (Monad m) => MonadAccess Bundle (AccessT m) where- spawn b = AccessT $ do- !w <- get- let !(e, w') = W.spawn b w- put w'- return e- insert e c = AccessT $ do- !w <- get- let !w' = W.insert e c w- put w'- lookup e = AccessT $ do- !w <- get- return $ W.lookup e w- remove e = AccessT $ do- !w <- get- let !(a, w') = W.remove e w- put w'- return a- despawn e = AccessT $ do- !w <- get- let !(_, w') = W.despawn e w- put w'---- | @since 0.9-instance (Monad m) => MonadReaderSystem QueryReader (AccessT m) where- all q = AccessT $ do- w <- get- let (cIds, cs, dynQ) = runQueryReader q . E.components $ entities w- put w {entities = (entities w) {E.components = cs}}- unAccessT $ allDyn cIds dynQ- filter q f = AccessT $ do- w <- get- let (cIds, cs, dynQ) = runQueryReader q . E.components $ entities w- (dynF, cs') = runQueryFilter f cs- put w {entities = (entities w) {E.components = cs'}}- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- unAccessT $ filterDyn cIds dynQ f'---- | @since 0.9-instance (Monad m) => MonadSystem (QueryT m) (AccessT m) where- map q = AccessT $ do- !w <- get- let (rws, cs, dynQ) = runQuery q . E.components $ entities w- put w {entities = (entities w) {E.components = cs}}- unAccessT $ mapDyn (Q.reads rws <> Q.writes rws) dynQ- mapSingleMaybe q = AccessT $ do- !w <- get- let (rws, cs, dynQ) = runQuery q . E.components $ entities w- put w {entities = (entities w) {E.components = cs}}- unAccessT $ mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ- filterMap q f = AccessT $ do- !w <- get- let (rws, cs, dynQ) = runQuery q . E.components $ entities w- (dynF, cs') = runQueryFilter f cs- put w {entities = (entities w) {E.components = cs'}}- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- unAccessT $ filterMapDyn (Q.reads rws <> Q.writes rws) f' dynQ---- | @since 0.9-instance (Monad m) => MonadDynamicReaderSystem DynamicQueryReader (AccessT m) where- allDyn cIds q = AccessT $ do- !w <- get- return . Q.allDyn cIds q $ entities w- filterDyn cIds q f = AccessT $ do- !w <- get- return . Q.filterDyn cIds f q $ entities w---- | @since 0.9-instance (Monad m) => MonadDynamicSystem (DynamicQueryT m) (AccessT m) where- mapDyn cIds q = AccessT $ do- !w <- get- (as, es) <- lift . Q.mapDyn cIds q $ entities w- put w {entities = es}- return as- mapSingleMaybeDyn cIds q = AccessT $ do- !w <- get- (res, es) <- lift . Q.mapSingleMaybeDyn cIds q $ entities w- put w {entities = es}- return res- filterMapDyn cIds f q = AccessT $ do- !w <- get- (as, es) <- lift . Q.filterMapDyn cIds f q $ entities w- put w {entities = es}- return as---- | Run a `System`.------ @since 0.9-system :: System a -> AccessT IO a-system s = AccessT $ do- !w <- get- esVar <- lift . newTVarIO $ entities w- a <- lift . atomically $ runReaderT (runSystemT s) esVar- es <- lift $ readTVarIO esVar- put w {entities = es}- return a+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module : Aztecs.ECS.Access +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Access + ( Access (..), + runAccess, + runAccess_, + spawn, + spawn_, + insert, + insertUntracked, + lookup, + remove, + despawn, + system, + triggerEvent, + triggerEntityEvent, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.System (System (..)) +import qualified Aztecs.ECS.System as S +import Aztecs.ECS.World (World) +import qualified Aztecs.ECS.World as W +import Aztecs.ECS.World.Bundle +import qualified Aztecs.ECS.World.Entities as E +import Control.Monad +import Control.Monad.State +import Prelude hiding (all, filter, lookup, map, mapM) + +-- | Run an `Access` on a `World`, returning the output and updated `World`. +runAccess :: (Functor m) => Access m a -> World m -> m (a, World m) +runAccess a = runStateT $ unAccess a + +-- | Run an `Access` on an empty `World`. +runAccess_ :: (Monad m) => Access m a -> m a +runAccess_ a = fmap fst . runAccess a $ W.empty + +spawn :: (Monad m) => BundleT m -> Access m EntityID +spawn b = Access $ do + !w <- get + let (e, w', hook) = W.spawn b w + put w' + unAccess hook + return e + +spawn_ :: (Monad m) => BundleT m -> Access m () +spawn_ = void . spawn + +insert :: (Monad m) => EntityID -> BundleT m -> Access m () +insert e c = Access $ do + !w <- get + let (w', hook) = W.insert e c w + put w' + unAccess hook + +-- | Insert a component into an entity without running lifecycle hooks. +insertUntracked :: (Monad m) => EntityID -> BundleT m -> Access m () +insertUntracked e c = Access $ do + !w <- get + let w' = W.insertUntracked e c w + put w' + +lookup :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a) +lookup e = Access $ do + !w <- get + return $ W.lookup @m e w + +remove :: forall m a. (Monad m, Component m a) => EntityID -> Access m (Maybe a) +remove e = Access $ do + !w <- get + let (a, w', hook) = W.remove @m e w + put w' + unAccess hook + return a + +despawn :: (Monad m) => EntityID -> Access m () +despawn e = Access $ do + !w <- get + let !(_, w') = W.despawn e w + put w' + +-- | Run a `System` on the `World`. +system :: (Monad m) => System m a -> Access m a +system sys = Access $ do + !w <- get + let !es = W.entities w + !(cs', dynSys) = S.runSystem sys $ E.components es + (a, es', hook) <- lift $ S.runDynamicSystem dynSys es + put w {W.entities = es' {E.components = cs'}} + unAccess hook + return a +{-# INLINE system #-}
− src/Aztecs/ECS/Access/Class.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.Access.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Access.Class (MonadAccess (..)) where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Bundle.Class---- | Monadic access to a `World`.------ @since 0.9-class (MonoidBundle b, Monad m) => MonadAccess b m | m -> b where- -- | Spawn an entity with a component.- --- -- @since 0.9- spawn :: b -> m EntityID-- -- | Spawn an entity with a component.- --- -- @since 0.9- spawn_ :: b -> m ()- spawn_ c = do- _ <- spawn c- return ()-- -- | Insert a component into an entity.- --- -- @since 0.9- insert :: EntityID -> b -> m ()-- -- | Lookup a component on an entity.- --- -- @since 0.9- lookup :: (Component a) => EntityID -> m (Maybe a)-- -- | Remove a component from an entity.- --- -- @since 0.9- remove :: (Component a) => EntityID -> m (Maybe a)-- -- | Despawn an entity.- --- -- @since 0.9- despawn :: EntityID -> m ()
+ src/Aztecs/ECS/Access/Internal.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Aztecs.ECS.Access.Internal +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Access.Internal + ( Access (..), + runAccessWith, + evalAccess, + triggerEvent, + triggerEntityEvent, + ) +where + +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import Aztecs.ECS.World.Internal +import qualified Aztecs.ECS.World.Observers as O +import Aztecs.ECS.World.Observers.Internal +import Control.Monad +import Control.Monad.Fix +import Control.Monad.State +import Data.Dynamic +import Data.Maybe +import qualified Data.Set as Set +import Data.Typeable + +-- | Access into a `World`. +newtype Access m a = Access {unAccess :: StateT (World m) m a} + deriving (Functor, Applicative, Monad, MonadFix, MonadIO) + +instance MonadTrans Access where + lift = Access . lift + +-- | Run an `Access` with a given `World`, returning the result and updated world. +runAccessWith :: Access m a -> World m -> m (a, World m) +runAccessWith a = runStateT (unAccess a) + +-- | Run an `Access` with a given `World`, returning only the result. +evalAccess :: (Monad m) => Access m a -> World m -> m a +evalAccess a = evalStateT (unAccess a) + +-- | Trigger an event. +triggerEvent :: forall m e. (Monad m, Event e) => e -> Access m () +triggerEvent evt = Access $ do + !w <- get + let eventTypeRep = typeOf (Proxy @e) + globalOs = O.lookupGlobalObservers eventTypeRep $ observers w + callbacks = mapMaybe (\oId -> O.lookupCallback oId (observers w)) $ Set.toList globalOs + dynEvt = toDyn evt + forM_ callbacks $ \cb -> case cb of + DynEventObserver f -> f dynEvt + DynEntityObserver _ -> pure () + +-- | Trigger an event for a specific entity. +triggerEntityEvent :: + forall m e. + (Monad m, Event e) => + EntityID -> + e -> + Access m () +triggerEntityEvent targetEntity evt = Access $ do + !w <- get + let eventTypeRep = typeOf $ Proxy @e + entityOs = O.lookupEntityObservers eventTypeRep targetEntity $ observers w + callbacks = mapMaybe (\oId -> O.lookupCallback oId (observers w)) $ Set.toList entityOs + dynEvt = toDyn evt + forM_ callbacks $ \cb -> case cb of + DynEntityObserver f -> f targetEntity dynEvt + DynEventObserver _ -> pure ()
src/Aztecs/ECS/Component.hs view
@@ -1,41 +1,46 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.Component--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Component where--import Aztecs.ECS.World.Storage-import 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 FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Component +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Component + ( ComponentID (..), + Component (..), + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component.Internal (ComponentID (..)) +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Storage +import Data.Typeable +import Data.Vector (Vector) + +-- | Component that can be stored in the `World`. +class (Monad m, Typeable a, Storage a (StorageT a)) => Component m a where + -- | `Storage` of this component. + type StorageT a + + type StorageT a = Vector a + + -- | Lifecycle hook called when a component is inserted. + componentOnInsert :: EntityID -> a -> Access m () + componentOnInsert _ _ = pure () + {-# INLINEABLE componentOnInsert #-} + + -- | Lifecycle hook called when a component is changed. + componentOnChange :: EntityID -> a -> a -> Access m () + componentOnChange _ _ _ = pure () + {-# INLINEABLE componentOnChange #-} + + -- | Lifecycle hook called when a component is removed. + componentOnRemove :: EntityID -> a -> Access m () + componentOnRemove _ _ = pure () + {-# INLINEABLE componentOnRemove #-}
+ src/Aztecs/ECS/Component/Internal.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module : Aztecs.ECS.Component.Internal+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Component.Internal (ComponentID (..)) where++import GHC.Generics++-- | Unique component identifier.+newtype ComponentID = ComponentID+ { -- | Unique integer identifier.+ unComponentId :: Int+ }+ deriving (Eq, Ord, Show, Generic)
src/Aztecs/ECS/Entity.hs view
@@ -11,16 +11,11 @@ -- 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)+ deriving (Eq, Ord, Show, Generic)
+ src/Aztecs/ECS/Event.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Event +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Event + ( Event, + OnInsert (..), + OnChange (..), + OnRemove (..), + ) +where + +import Data.Typeable +import GHC.Generics + +-- | An event in the ECS. +class (Typeable e) => Event e + +-- | Event triggered when a component is inserted. +newtype OnInsert a = OnInsert {unOnInsert :: a} + deriving (Show, Eq, Generic) + +instance (Typeable a) => Event (OnInsert a) + +-- | Event triggered when a component is changed. +data OnChange a = OnChange + { onChangeOld :: a, + onChangeNew :: a + } + deriving (Show, Eq, Generic) + +instance (Typeable a) => Event (OnChange a) + +-- | Event triggered when a component is removed. +newtype OnRemove a = OnRemove {unOnRemove :: a} + deriving (Show, Eq, Generic) + +instance (Typeable a) => Event (OnRemove a)
+ src/Aztecs/ECS/Observer.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Observer +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Observer + ( Observer (..), + ObserverID (..), + ObserverKind (..), + observer, + observerFor, + observerGlobal, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import qualified Aztecs.ECS.World as W +import Aztecs.ECS.World.Bundle +import Aztecs.ECS.World.Internal (World (..)) +import qualified Aztecs.ECS.World.Observers as O +import Aztecs.ECS.World.Observers.Internal +import Control.Monad.State +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable +import Data.Vector (Vector) + +-- | The kind of observer - either entity-specific or global. +data ObserverKind m e + = -- | Observe events on specific entities (callback receives EntityID and event). + EntityObserver !(Set EntityID) !(EntityID -> e -> Access m ()) + | -- | Observe all events of this type globally (callback receives just the event). + EventObserver !(e -> Access m ()) + +-- | Observer component +data Observer m e = Observer + { -- | The kind and callback for this observer. + observerKind :: !(ObserverKind m e), + -- | The ObserverID assigned after registration (Nothing before registration). + observerId :: !(Maybe ObserverID) + } + +instance Show (ObserverKind m e) where + show (EntityObserver targets _) = "EntityObserver " ++ show targets + show (EventObserver _) = "EventObserver" + +instance Show (Observer m e) where + show o = "Observer { kind = " ++ show (observerKind o) ++ ", id = " ++ show (observerId o) ++ " }" + +instance (Monad m, Typeable m, Event e) => Component m (Observer m e) where + type StorageT (Observer m e) = Vector (Observer m e) + + componentOnInsert ownerEntity o = Access $ do + !w <- get + (oId, observers') <- case observerKind o of + EntityObserver targets f -> do + let f' eId evt = unAccess $ f eId evt + (oId, observers') = O.insertEntityObserver @e f' $ observers w + observers'' = foldr (\e os -> O.addEntityObserver @_ @e e oId os) observers' targets + return (oId, observers'') + EventObserver callback -> do + let wrappedCallback evt = unAccess $ callback evt + (oId, observers') = O.insertEventObserver @e wrappedCallback (observers w) + observers'' = O.addGlobalObserver @_ @e oId observers' + return (oId, observers'') + let o' = o {observerId = Just oId} + w' = W.insertUntracked ownerEntity (bundleUntracked o') w {observers = observers'} + put w' + + componentOnRemove _ownerEntity o = Access $ case observerId o of + Just oId -> do + !w <- get + put w {observers = O.removeObserver oId (observers w)} + Nothing -> pure () + +-- | Create an observer for specific entities. +observerFor :: forall m e. (Event e) => Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e +observerFor targets callback = Observer {observerKind = EntityObserver targets callback, observerId = Nothing} + +-- | Create a global observer (observes all events of this type). +observerGlobal :: forall m e. (Event e) => (e -> Access m ()) -> Observer m e +observerGlobal callback = Observer {observerKind = EventObserver callback, observerId = Nothing} + +-- | Create an observer for a single entity. +observer :: forall m e. (Event e) => EntityID -> (EntityID -> e -> Access m ()) -> Observer m e +observer e = observerFor (Set.singleton e)
src/Aztecs/ECS/Query.hs view
@@ -1,316 +1,404 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.Query--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)------ Query for matching entities.------ === Do notation:--- > move :: (ArrowQuery arr) => arr () Position--- > move = proc () -> do--- > Velocity v <- Q.fetch -< ()--- > Position p <- Q.fetch -< ()--- > Q.set -< Position $ p + v------ === Arrow combinators:--- > move :: (ArrowQuery arr) => arr () Position--- > move = Q.fetch &&& Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set------ === Applicative combinators:--- > move :: (ArrowQuery arr) => arr () Position--- > move = (,) <$> Q.fetch <*> Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set-module Aztecs.ECS.Query- ( -- * Queries- Query,- QueryT (..),- QueryReaderF (..),- QueryF (..),- DynamicQueryReaderF (..),- DynamicQueryF (..),-- -- ** Running- all,- all',- single,- single',- singleMaybe,- singleMaybe',- map,- mapSingle,- mapSingleMaybe,-- -- ** Conversion- fromReader,- toReader,- fromDyn,-- -- * Filters- QueryFilter (..),- with,- without,-- -- * Reads and writes- ReadsWrites (..),- disjoint,- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Class-import Aztecs.ECS.Query.Dynamic-import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReader (..), with, without)-import qualified Aztecs.ECS.Query.Reader as QR-import Aztecs.ECS.Query.Reader.Class-import Aztecs.ECS.World.Components (Components)-import qualified Aztecs.ECS.World.Components as CS-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Category-import Control.Monad.Identity-import Control.Monad.Writer-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Stack-import Prelude hiding (all, id, map, reads, (.))---- | @since 0.10-type Query = QueryT Identity---- | Query for matching entities.------ @since 0.10-newtype QueryT f a = Query- { -- | Run a query, producing a `DynamicQueryT`.- --- -- @since 0.10- runQuery :: Components -> (ReadsWrites, Components, DynamicQueryT f a)- }- deriving (Functor)---- | @since 0.10-instance (Applicative f) => Applicative (QueryT f) where- {-# INLINE pure #-}- pure a = Query (mempty,,pure a)-- {-# INLINE (<*>) #-}- (Query f) <*> (Query g) = Query $ \cs ->- let !(cIdsG, cs', aQS) = g cs- !(cIdsF, cs'', bQS) = f cs'- in (cIdsG <> cIdsF, cs'', bQS <*> aQS)---- | @since 0.10-instance (Applicative f) => QueryReaderF (QueryT f) where- {-# INLINE fetch #-}- fetch = fromReader fetch-- {-# INLINE fetchMaybe #-}- fetchMaybe = fromReader fetchMaybe---- | @since 0.10-instance (Applicative f) => DynamicQueryReaderF (QueryT f) where- {-# INLINE entity #-}- entity = fromReader entity-- {-# INLINE fetchDyn #-}- fetchDyn = fromReader . fetchDyn-- {-# INLINE fetchMaybeDyn #-}- fetchMaybeDyn = fromReader . fetchMaybeDyn---- | @since 0.10-instance (Applicative f) => DynamicQueryF f (QueryT f) where- {-# INLINE adjustDyn #-}- adjustDyn f = fromDynInternal $ adjustDyn f-- {-# INLINE adjustDyn_ #-}- adjustDyn_ f = fromDynInternal $ adjustDyn_ f-- {-# INLINE adjustDynM #-}- adjustDynM f = fromDynInternal $ adjustDynM f-- {-# INLINE setDyn #-}- setDyn = fromDynInternal setDyn---- | @since 0.9-instance (Monad m) => QueryF m (QueryT m) where- {-# INLINE adjust #-}- adjust :: forall a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m a- adjust f = fromWriterInternal @a $ adjustDyn f-- {-# INLINE adjust_ #-}- adjust_ :: forall a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m ()- adjust_ f = fromWriterInternal @a $ adjustDyn_ f-- {-# INLINE adjustM #-}- adjustM :: forall a b. (Component a, Monad m) => (b -> a -> m a) -> QueryT m b -> QueryT m a- adjustM f = fromWriterInternal @a $ adjustDynM f-- {-# INLINE set #-}- set :: forall a. (Component a) => QueryT m a -> QueryT m a- set = fromWriterInternal @a setDyn---- | Convert a `QueryReader` to a `Query`.------ @since 0.9-{-# INLINE fromReader #-}-fromReader :: (Applicative f) => QueryReader a -> QueryT f a-fromReader (QueryReader f) = Query $ \cs ->- let !(cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ)---- | Convert a `Query` to a `QueryReader`.------ @since 0.10-{-# INLINE toReader #-}-toReader :: Query a -> QueryReader a-toReader (Query f) = QueryReader $ \cs ->- let !(rws, cs', dynQ) = f cs in (reads rws, cs', toDynReader dynQ)---- | Convert a `DynamicQueryT` to a `QueryT`.------ @since 0.10-{-# INLINE fromDyn #-}-fromDyn :: ReadsWrites -> DynamicQueryT f a -> QueryT f a-fromDyn rws q = Query (rws,,q)--{-# INLINE fromDynInternal #-}-fromDynInternal ::- (ComponentID -> DynamicQueryT f b -> DynamicQueryT f a) ->- ComponentID ->- QueryT f b ->- QueryT f a-fromDynInternal f cId q = Query $ \cs ->- let !(rws, cs', dynQ) = runQuery q cs- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', f cId dynQ)--{-# INLINE fromWriterInternal #-}-fromWriterInternal ::- forall c f a b.- (Applicative f, 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- !(rws, cs'', dynQ) = runQuery q cs'- in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', f cId dynQ)---- | Reads and writes of a `Query`.------ @since 0.9-data ReadsWrites = ReadsWrites- { -- | Component IDs being read.- --- -- @since 0.9- reads :: !(Set ComponentID),- -- | Component IDs being written.- --- -- @since 0.9- writes :: !(Set ComponentID)- }- deriving (Show)---- | @since 0.9-instance Semigroup ReadsWrites where- ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2)---- | @since 0.9-instance Monoid ReadsWrites where- mempty = ReadsWrites mempty mempty---- | `True` if the reads and writes of two `Query`s overlap.------ @since 0.9-disjoint :: ReadsWrites -> ReadsWrites -> Bool-disjoint a b =- Set.disjoint (reads a) (writes b)- || Set.disjoint (reads b) (writes a)- || Set.disjoint (writes b) (writes a)---- | Match all entities.------ @since 0.10-{-# INLINE all #-}-all :: Query a -> Entities -> ([a], Entities)-all = QR.all . toReader---- | Match all entities.------ @since 0.10-{-# INLINE all' #-}-all' :: Query a -> Entities -> ([a], Components)-all' = QR.all' . toReader---- | Match a single entity.------ @since 0.10-{-# INLINE single #-}-single :: (HasCallStack) => Query a -> Entities -> (a, Entities)-single = QR.single . toReader---- | Match a single entity.------ @since 0.10-{-# INLINE single' #-}-single' :: (HasCallStack) => Query a -> Entities -> (a, Components)-single' = QR.single' . toReader---- | Match a single entity, or `Nothing`.------ @since 0.10-{-# INLINE singleMaybe #-}-singleMaybe :: Query a -> Entities -> (Maybe a, Entities)-singleMaybe = QR.singleMaybe . toReader---- | Match a single entity, or `Nothing`.------ @since 0.10-{-# INLINE singleMaybe' #-}-singleMaybe' :: Query a -> Entities -> (Maybe a, Components)-singleMaybe' = QR.singleMaybe' . toReader---- | Map all matched entities.------ @since 0.10-{-# INLINE map #-}-map :: (Monad m) => QueryT m o -> Entities -> m ([o], Entities)-map q es = do- let !(rws, cs', dynQ) = runQuery q $ components es- !cIds = reads rws <> writes rws- (as, es') <- mapDyn cIds dynQ es- return (as, es' {components = cs'})---- | Map a single matched entity.------ @since 0.10-{-# INLINE mapSingle #-}-mapSingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities)-mapSingle q es = do- let !(rws, cs', dynQ) = runQuery q $ components es- !cIds = reads rws <> writes rws- (as, es') <- mapSingleDyn cIds dynQ es- return (as, es' {components = cs'})---- | Map a single matched entity, or `Nothing`.------ @since 0.10-{-# INLINE mapSingleMaybe #-}-mapSingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities)-mapSingleMaybe q es = do- let !(rws, cs', dynQ) = runQuery q $ components es- !cIds = reads rws <> writes rws- (as, es') <- mapSingleMaybeDyn cIds dynQ es- return (as, es' {components = cs'})+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Query +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Query for matching entities. +module Aztecs.ECS.Query + ( -- * Queries + Query (..), + DynamicQueryF (..), + + -- ** Operations + query, + queryMaybe, + queryMap, + queryMap_, + queryMapM, + queryMapWith, + queryMapWith_, + queryMapWithM, + queryMapAccum, + queryMapAccumM, + queryMapWithAccum, + queryMapWithAccumM, + + -- ** Running + readQuery, + readQuery', + readQuerySingle, + readQuerySingle', + readQuerySingleMaybe, + readQuerySingleMaybe', + runQuery, + runQuerySingle, + runQuerySingleMaybe, + + -- * Filters + QueryFilter (..), + with, + without, + + -- * Reads and writes + ReadsWrites (..), + disjoint, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Query.Dynamic +import Aztecs.ECS.World.Components (Components) +import qualified Aztecs.ECS.World.Components as CS +import Aztecs.ECS.World.Entities (Entities (..)) +import qualified Aztecs.ECS.World.Entities as E +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import GHC.Stack +import Prelude hiding (reads) + +-- | Query for matching entities. +newtype Query m a = Query + { -- | Run a query, producing a `DynamicQuery`. + -- + -- @since 0.10 + runQuery' :: Components -> (ReadsWrites, Components, DynamicQuery m a) + } + deriving (Functor) + +instance (Monad m) => Applicative (Query m) where + pure a = Query (mempty,,pure a) + {-# INLINE pure #-} + + (Query f) <*> (Query g) = Query $ \cs -> + let !(cIdsG, cs', aQS) = g cs + !(cIdsF, cs'', bQS) = f cs' + in (cIdsG <> cIdsF, cs'', bQS <*> aQS) + {-# INLINE (<*>) #-} + +instance (Monad m) => DynamicQueryF m (Query m) where + entity = Query (mempty,,entity) + {-# INLINE entity #-} + + queryDyn = dynQueryReader queryDyn + {-# INLINE queryDyn #-} + + queryMaybeDyn = dynQueryReader queryMaybeDyn + {-# INLINE queryMaybeDyn #-} + + queryMapDyn f = dynQueryWriter' $ queryMapDyn f + {-# INLINE queryMapDyn #-} + + queryMapDyn_ f = dynQueryWriter' $ queryMapDyn_ f + {-# INLINE queryMapDyn_ #-} + + queryMapDynM f = dynQueryWriter' $ queryMapDynM f + {-# INLINE queryMapDynM #-} + + queryMapDynWith f = dynQueryWriter $ queryMapDynWith f + {-# INLINE queryMapDynWith #-} + + queryMapDynWith_ f = dynQueryWriter $ queryMapDynWith_ f + {-# INLINE queryMapDynWith_ #-} + + queryMapDynWithM f = dynQueryWriter $ queryMapDynWithM f + {-# INLINE queryMapDynWithM #-} + + queryMapDynWithAccum f = dynQueryWriter $ queryMapDynWithAccum f + {-# INLINE queryMapDynWithAccum #-} + + queryUntracked (Query q) = Query $ \cs -> + let !(rws, cs', dynQ) = q cs + in (rws, cs', queryUntracked dynQ) + {-# INLINE queryUntracked #-} + + queryMapDynWithAccumM f = dynQueryWriter $ queryMapDynWithAccumM f + {-# INLINE queryMapDynWithAccumM #-} + + queryFilterMap p (Query q) = Query $ \cs -> + let !(rws, cs', dynQ) = q cs + in (rws, cs', queryFilterMap p dynQ) + {-# INLINE queryFilterMap #-} + +-- | Query a component. +query :: forall m a. (Monad m, Component m a) => Query m a +query = queryReader @m @a queryDyn +{-# INLINE query #-} + +-- | Optionally query a component, returning @Nothing@ if it does not exist. +queryMaybe :: forall m a. (Monad m, Component m a) => Query m (Maybe a) +queryMaybe = queryReader @m @a queryMaybeDyn +{-# INLINE queryMaybe #-} + +-- | Query a component and update it. +queryMap :: forall m a. (Monad m, Component m a) => (a -> a) -> Query m a +queryMap f = queryWriter' @m @a $ queryMapDyn f +{-# INLINE queryMap #-} + +-- | Query a component and update it, ignoring any output. +queryMap_ :: forall m a. (Monad m, Component m a) => (a -> a) -> Query m () +queryMap_ f = queryWriter' @m @a $ queryMapDyn_ f +{-# INLINE queryMap_ #-} + +-- | Query a component and update it with a monadic action. +queryMapM :: forall m a. (Monad m, Component m a) => (a -> m a) -> Query m a +queryMapM f = queryWriter' @m @a $ queryMapDynM f +{-# INLINE queryMapM #-} + +-- | Query a component with input and update it. +queryMapWith :: forall m a b. (Monad m, Component m b) => (a -> b -> b) -> Query m a -> Query m b +queryMapWith f = queryWriter @m @b $ queryMapDynWith f +{-# INLINE queryMapWith #-} + +-- | Query a component with input and update it, ignoring any output. +queryMapWith_ :: forall m a b. (Monad m, Component m b) => (a -> b -> b) -> Query m a -> Query m () +queryMapWith_ f = queryWriter @m @b $ queryMapDynWith_ f +{-# INLINE queryMapWith_ #-} + +-- | Query a component with input and update it with a monadic action. +queryMapWithM :: + forall m a b. + (Monad m, Component m b) => + (a -> b -> m b) -> + Query m a -> + Query m b +queryMapWithM f = queryWriter @m @b $ queryMapDynWithM f +{-# INLINE queryMapWithM #-} + +-- | Query a component with input, returning a tuple of the result and the updated component. +queryMapAccum :: + forall m a b. + (Monad m, Component m b) => + (b -> (a, b)) -> + Query m (a, b) +queryMapAccum f = queryMapWithAccum (const f) (pure ()) +{-# INLINE queryMapAccum #-} + +-- | Query a component with input and update it with a monadic action, returning a tuple. +queryMapAccumM :: + forall m a b. + (Monad m, Component m b) => + (b -> m (a, b)) -> + Query m (a, b) +queryMapAccumM f = queryMapWithAccumM (const f) (pure ()) +{-# INLINE queryMapAccumM #-} + +-- | Query a component with input, returning a tuple of the result and the updated component. +queryMapWithAccum :: + forall m a b c. + (Monad m, Component m c) => + (b -> c -> (a, c)) -> + Query m b -> + Query m (a, c) +queryMapWithAccum f = queryWriter @m @c $ queryMapDynWithAccum f +{-# INLINE queryMapWithAccum #-} + +-- | Query a component with input and update it with a monadic action, returning a tuple. +queryMapWithAccumM :: + forall m a b c. + (Monad m, Component m c) => + (b -> c -> m (a, c)) -> + Query m b -> + Query m (a, c) +queryMapWithAccumM f = queryWriter @m @c $ queryMapDynWithAccumM f +{-# INLINE queryMapWithAccumM #-} + +dynQueryReader :: (ComponentID -> DynamicQuery m a) -> ComponentID -> Query m a +dynQueryReader f cId = Query (ReadsWrites {reads = Set.singleton cId, writes = Set.empty},,f cId) +{-# INLINE dynQueryReader #-} + +dynQueryWriter :: + ( ComponentID -> + DynamicQuery m a -> + DynamicQuery m b + ) -> + ComponentID -> + Query m a -> + Query m b +dynQueryWriter f cId q = Query $ \cs -> + let !(rws, cs', dynQ) = runQuery' q cs + in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', f cId dynQ) +{-# INLINE dynQueryWriter #-} + +dynQueryWriter' :: (ComponentID -> DynamicQuery m a) -> ComponentID -> Query m a +dynQueryWriter' f cId = Query (ReadsWrites {reads = Set.empty, writes = Set.singleton cId},,f cId) +{-# INLINE dynQueryWriter' #-} + +queryReader :: forall m a b. (Component m a) => (ComponentID -> DynamicQuery m b) -> Query m b +queryReader f = Query $ \cs -> + let !(cId, cs') = CS.insert @a @m cs + in (ReadsWrites {reads = Set.singleton cId, writes = Set.empty}, cs', f cId) +{-# INLINE queryReader #-} + +queryWriter :: + forall m a b c. + (Component m a) => + ( ComponentID -> + DynamicQuery m b -> + DynamicQuery m c + ) -> + Query m b -> + Query m c +queryWriter f (Query g) = Query $ \cs -> + let !(rws, cs', dynQ) = g cs + !(cId, cs'') = CS.insert @a @m cs' + in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', f cId dynQ) +{-# INLINE queryWriter #-} + +queryWriter' :: forall m a b. (Component m a) => (ComponentID -> DynamicQuery m b) -> Query m b +queryWriter' f = Query $ \cs -> + let !(cId, cs') = CS.insert @a @m cs + in (ReadsWrites {reads = Set.empty, writes = Set.singleton cId}, cs', f cId) +{-# INLINE queryWriter' #-} + +-- | Reads and writes of a `Query`. +data ReadsWrites = ReadsWrites + { -- | Component IDs being read. + reads :: !(Set ComponentID), + -- | Component IDs being written. + writes :: !(Set ComponentID) + } + deriving (Show) + +instance Semigroup ReadsWrites where + ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2) + {-# INLINE (<>) #-} + +instance Monoid ReadsWrites where + mempty = ReadsWrites mempty mempty + {-# INLINE mempty #-} + +-- | `True` if the reads and writes of two `Query`s overlap. +disjoint :: ReadsWrites -> ReadsWrites -> Bool +disjoint a b = + Set.disjoint (reads a) (writes b) + || Set.disjoint (reads b) (writes a) + || Set.disjoint (writes b) (writes a) + +-- | Match all entities. +readQuery :: (Monad m) => Query m a -> Entities m -> m (Vector a, Entities m) +readQuery q es = do + (as, cs) <- readQuery' q es + return (as, es {E.components = cs}) +{-# INLINE readQuery #-} + +-- | Match all entities. +readQuery' :: (Monad m) => Query m a -> Entities m -> m (Vector a, Components) +readQuery' q es = do + let !(rws, cs', dynQ) = runQuery' q (E.components es) + !cIds = reads rws <> writes rws + as <- readQueryDyn cIds dynQ es + return (as, cs') +{-# INLINE readQuery' #-} + +-- | Match a single entity. +readQuerySingle :: (HasCallStack, Monad m) => Query m a -> Entities m -> m (a, Entities m) +readQuerySingle q es = do + (a, cs) <- readQuerySingle' q es + return (a, es {E.components = cs}) +{-# INLINE readQuerySingle #-} + +-- | Match a single entity. +readQuerySingle' :: (HasCallStack, Monad m) => Query m a -> Entities m -> m (a, Components) +readQuerySingle' q es = do + let !(rws, cs', dynQ) = runQuery' q (E.components es) + !cIds = reads rws <> writes rws + a <- readQuerySingleDyn cIds dynQ es + return (a, cs') +{-# INLINE readQuerySingle' #-} + +-- | Match a single entity. +readQuerySingleMaybe :: (Monad m) => Query m a -> Entities m -> m (Maybe a, Entities m) +readQuerySingleMaybe q es = do + (a, cs) <- readQuerySingleMaybe' q es + return (a, es {E.components = cs}) +{-# INLINE readQuerySingleMaybe #-} + +-- | Match a single entity. +readQuerySingleMaybe' :: (Monad m) => Query m a -> Entities m -> m (Maybe a, Components) +readQuerySingleMaybe' q es = do + let !(rws, cs', dynQ) = runQuery' q (E.components es) + !cIds = reads rws <> writes rws + a <- readQuerySingleMaybeDyn cIds dynQ es + return (a, cs') +{-# INLINE readQuerySingleMaybe' #-} + +-- | Map all matched entities. +runQuery :: (Monad m) => Query m o -> Entities m -> m (Vector o, Entities m, Access m ()) +runQuery q es = do + let !(rws, cs', dynQ) = runQuery' q $ components es + !cIds = reads rws <> writes rws + (as, es', hook) <- runQueryDyn cIds dynQ es + return (as, es' {components = cs'}, hook) +{-# INLINE runQuery #-} + +-- | Map a single matched entity. +runQuerySingle :: + (HasCallStack, Monad m) => + Query m a -> + Entities m -> + m (a, Entities m, Access m ()) +runQuerySingle q es = do + let !(rws, cs', dynQ) = runQuery' q $ components es + !cIds = reads rws <> writes rws + (as, es', hook) <- runQuerySingleDyn cIds dynQ es + return (as, es' {components = cs'}, hook) +{-# INLINE runQuerySingle #-} + +-- | Map a single matched entity, or `Nothing`. +runQuerySingleMaybe :: + (Monad m) => + Query m a -> + Entities m -> + m (Maybe a, Entities m, Access m ()) +runQuerySingleMaybe q es = do + let !(rws, cs', dynQ) = runQuery' q $ components es + !cIds = reads rws <> writes rws + (as, es', hook) <- runQuerySingleMaybeDyn cIds dynQ es + return (as, es' {components = cs'}, hook) +{-# INLINE runQuerySingleMaybe #-} + +-- | Filter for a `Query`. +newtype QueryFilter = QueryFilter + { -- | Run a query filter. + runQueryFilter :: Components -> (DynamicQueryFilter, Components) + } + +instance Semigroup QueryFilter where + a <> b = + QueryFilter + ( \cs -> + let !(withA', cs') = runQueryFilter a cs + !(withB', cs'') = runQueryFilter b cs' + in (withA' <> withB', cs'') + ) + +instance Monoid QueryFilter where + mempty = QueryFilter (mempty,) + +-- | Filter for entities containing this component. +with :: forall m a. (Component m a) => QueryFilter +with = QueryFilter $ \cs -> + let !(cId, cs') = CS.insert @a @m cs in (mempty {filterWith = Set.singleton cId}, cs') + +-- | Filter out entities containing this component. +without :: forall m a. (Component m a) => QueryFilter +without = QueryFilter $ \cs -> + let !(cId, cs') = CS.insert @a @m cs in (mempty {filterWithout = Set.singleton cId}, cs')
− src/Aztecs/ECS/Query/Class.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module : Aztecs.ECS.Query.Reader.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Class (QueryF (..)) where--import Aztecs.ECS.Component-import Control.Monad---- | Query functor.------ @since 0.10-class (Applicative g, Functor f) => QueryF g f | f -> g where- -- | Adjust a `Component` by its type.- --- -- @since 0.10- adjust :: (Component a) => (b -> a -> a) -> f b -> f a-- -- | Adjust a `Component` by its type, ignoring any output.- --- -- @since 0.10- adjust_ :: (Component a) => (b -> a -> a) -> f b -> f ()- adjust_ f = void . adjust f-- -- | Adjust a `Component` by its type with some `Monad` @m@.- --- -- @since 0.10- adjustM :: (Component a) => (b -> a -> g a) -> f b -> f a-- -- | Set a `Component` by its type.- --- -- @since 0.10- set :: (Component a) => f a -> f a
src/Aztecs/ECS/Query/Dynamic.hs view
@@ -1,200 +1,288 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.Query.Dynamic--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Dynamic- ( -- * Dynamic queries- DynamicQuery,- DynamicQueryT (..),- DynamicQueryReaderF (..),- DynamicQueryF (..),-- -- ** Conversion- fromDynReader,- toDynReader,-- -- ** Running- mapDyn,- filterMapDyn,- mapSingleDyn,- mapSingleMaybeDyn,-- -- * Dynamic query filters- DynamicQueryFilter (..),- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic.Class-import Aztecs.ECS.Query.Dynamic.Reader-import Aztecs.ECS.World.Archetype (Archetype)-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (ArchetypeID, Node (..))-import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Monad.Identity-import Data.Foldable-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Stack--type DynamicQuery = DynamicQueryT Identity---- | Dynamic query for components by ID.------ @since 0.10-newtype DynamicQueryT f a- = DynamicQuery- { -- | Run a dynamic query.- --- -- @since 0.10- runDynQuery :: Archetype -> f ([a], Archetype)- }- deriving (Functor)---- | @since 0.10-instance (Applicative f) => Applicative (DynamicQueryT f) where- {-# INLINE pure #-}- pure a = DynamicQuery $ \arch -> pure (replicate (length $ A.entities arch) a, arch)-- {-# INLINE (<*>) #-}- f <*> g = DynamicQuery $ \arch -> do- x <- runDynQuery g arch- y <- runDynQuery f arch- return $- let (as, arch') = x- (bs, arch'') = y- in (zipWith ($) bs as, arch' <> arch'')---- | @since 0.10-instance DynamicQueryReaderF DynamicQuery where- {-# INLINE entity #-}- entity = fromDynReader entity-- {-# INLINE fetchDyn #-}- fetchDyn = fromDynReader . fetchDyn-- {-# INLINE fetchMaybeDyn #-}- fetchMaybeDyn = fromDynReader . fetchMaybeDyn---- | @since 0.10-instance (Applicative f) => DynamicQueryF f (DynamicQueryT f) where- {-# INLINE adjustDyn #-}- adjustDyn f cId q =- DynamicQuery (fmap (\(bs, arch') -> A.zipWith bs f cId arch') . runDynQuery q)-- {-# INLINE adjustDyn_ #-}- adjustDyn_ f cId q = DynamicQuery $ \arch ->- fmap (\(bs, arch') -> (map (const ()) bs, A.zipWith_ bs f cId arch')) (runDynQuery q arch)-- {-# INLINE adjustDynM #-}- adjustDynM f cId q = DynamicQuery $ \arch -> do- (bs, arch') <- runDynQuery q arch- A.zipWithM bs f cId arch'-- {-# INLINE setDyn #-}- setDyn cId q =- DynamicQuery (fmap (\(bs, arch') -> (bs, A.insertAscList cId bs arch')) . runDynQuery q)---- | Convert a `DynamicQueryReaderT` to a `DynamicQueryT`.------ @since 0.10-{-# INLINE fromDynReader #-}-fromDynReader :: (Applicative m) => DynamicQueryReader a -> DynamicQueryT m a-fromDynReader q = DynamicQuery $ \arch -> let !os = runDynQueryReader q arch in pure (os, arch)---- | Convert a `DynamicQueryT` to a `DynamicQueryReaderT`.------ @since 0.10-{-# INLINE toDynReader #-}-toDynReader :: DynamicQuery a -> DynamicQueryReader a-toDynReader q = DynamicQueryReader $ \arch -> fst $ runIdentity $ runDynQuery q arch---- | Map all matched entities.------ @since 0.10-{-# INLINE mapDyn #-}-mapDyn :: (Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m ([a], Entities)-mapDyn cIds = mapDyn' cIds id---- | Map all matched entities with a filter.------ @since 0.10-{-# INLINE filterMapDyn #-}-filterMapDyn ::- (Monad m) =>- Set ComponentID ->- (Node -> Bool) ->- DynamicQueryT m a ->- Entities ->- m ([a], Entities)-filterMapDyn cIds f = mapDyn' cIds (Map.filter f)--{-# INLINE mapDyn' #-}-mapDyn' ::- (Monad m) =>- Set ComponentID ->- (Map ArchetypeID Node -> Map ArchetypeID Node) ->- DynamicQueryT m a ->- Entities ->- m ([a], Entities)-mapDyn' cIds f q es =- let go = runDynQuery q- in if Set.null cIds- then do- (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es}- return (as, es)- 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 cIds $ archetypes es---- | Map a single matched entity.------ @since 0.10-mapSingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (a, Entities)-mapSingleDyn cIds q es = do- res <- mapSingleMaybeDyn cIds q es- return $ case res of- (Just a, es') -> (a, es')- _ -> error "mapSingleDyn: expected single matching entity"---- | Map a single matched entity, or @Nothing@.------ @since 0.10-{-# INLINE mapSingleMaybeDyn #-}-mapSingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (Maybe a, Entities)-mapSingleMaybeDyn cIds q es =- if Set.null cIds- then case Map.keys $ entities es of- [eId] -> do- res <- runDynQuery q $ A.singleton eId- return $ case res of- ([a], _) -> (Just a, es)- _ -> (Nothing, es)- _ -> pure (Nothing, es)- else case Map.toList $ AS.find cIds $ 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)+{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.Query.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.Query.Dynamic + ( -- * Dynamic queries + DynamicQuery (..), + DynamicQueryF (..), + + -- ** Running + readQueryDyn, + readQueryFilteredDyn, + readQuerySingleDyn, + readQuerySingleMaybeDyn, + runQueryDyn, + runQueryFilteredDyn, + runQuerySingleDyn, + runQuerySingleMaybeDyn, + + -- * Dynamic query filters + DynamicQueryFilter (..), + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Query.Dynamic.Class +import Aztecs.ECS.World.Archetype (Archetype) +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Archetypes (Node (..)) +import qualified Aztecs.ECS.World.Archetypes as AS +import Aztecs.ECS.World.Entities (Entities (..)) +import Aztecs.ECS.World.Storage.Dynamic +import Data.Foldable +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Stack + +-- | Dynamic query for components by ID. +newtype DynamicQuery m a + = DynamicQuery + { -- | Run a dynamic query. + -- + -- @since 0.10 + runDynQuery :: Archetype m -> m (Vector a, Archetype m, Access m ()) + } + deriving (Functor) + +instance (Monad m) => Applicative (DynamicQuery m) where + pure a = DynamicQuery $ \arch -> pure (V.replicate (length $ A.entities arch) a, arch, return ()) + {-# INLINE pure #-} + + f <*> g = DynamicQuery $ \arch -> do + x <- runDynQuery g arch + y <- runDynQuery f arch + return $ + let (as, arch', hook1) = x + (bs, arch'', hook2) = y + in (V.zipWith ($) bs as, arch' <> arch'', hook1 >> hook2) + {-# INLINE (<*>) #-} + +instance (Monad m) => DynamicQueryF m (DynamicQuery m) where + entity = DynamicQuery $ \arch -> pure (V.fromList . Set.toList $ A.entities arch, arch, return ()) + {-# INLINE entity #-} + + queryDyn cId = DynamicQuery $ \arch -> pure (A.lookupComponentsAsc cId arch, arch, return ()) + {-# INLINE queryDyn #-} + + queryMaybeDyn cId = DynamicQuery $ \arch -> case A.lookupComponentsAscMaybe cId arch of + Just as -> pure (V.map Just as, arch, return ()) + Nothing -> pure (V.replicate (length $ A.entities arch) Nothing, arch, return ()) + {-# INLINE queryMaybeDyn #-} + + queryMapDyn f cId = DynamicQuery $ \arch -> do + let (cs, arch', hook) = A.zipWith (V.replicate (length $ A.entities arch) ()) (const f) cId arch + return (cs, arch', hook) + {-# INLINE queryMapDyn #-} + + queryMapDyn_ f cId = DynamicQuery $ \arch -> do + let (arch', hook) = A.zipWith_ (V.replicate (length $ A.entities arch) ()) (const f) cId arch + return (V.replicate (length $ A.entities arch) (), arch', hook) + {-# INLINE queryMapDyn_ #-} + + queryMapDynM f cId = DynamicQuery $ \arch -> do + (cs, arch', hook) <- A.zipWithM (V.replicate (length $ A.entities arch) ()) (const f) cId arch + return (cs, arch', hook) + {-# INLINE queryMapDynM #-} + + queryMapDynWith f cId q = DynamicQuery $ \arch -> do + (as, arch', hook1) <- runDynQuery q arch + let (cs, arch'', hook2) = A.zipWith as f cId arch' + return (cs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWith #-} + + queryMapDynWith_ f cId q = DynamicQuery $ \arch -> do + (as, arch', hook1) <- runDynQuery q arch + let (arch'', hook2) = A.zipWith_ as f cId arch' + return (V.map (const ()) as, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWith_ #-} + + queryMapDynWithM f cId q = DynamicQuery $ \arch -> do + (as, arch', hook1) <- runDynQuery q arch + (cs, arch'', hook2) <- A.zipWithM as f cId arch' + return (cs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWithM #-} + + queryMapDynWithAccum f cId q = DynamicQuery $ \arch -> do + (bs, arch', hook1) <- runDynQuery q arch + let (pairs, arch'', hook2) = A.zipWithAccum bs f cId arch' + return (pairs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWithAccum #-} + + queryMapDynWithAccumM f cId q = DynamicQuery $ \arch -> do + (bs, arch', hook1) <- runDynQuery q arch + (pairs, arch'', hook2) <- A.zipWithAccumM bs f cId arch' + return (pairs, arch'', hook1 >> hook2) + {-# INLINE queryMapDynWithAccumM #-} + + queryUntracked q = DynamicQuery $ \arch -> do + (as, arch', _hooks) <- runDynQuery q arch + return (as, arch', return ()) + {-# INLINE queryUntracked #-} + + queryFilterMap p q = DynamicQuery $ \arch -> do + (as, _, _) <- runDynQuery q arch + let eIds = V.fromList . Set.toList $ A.entities arch + mapped = V.map p as + (filteredEIds, indices, filteredBs) = V.unzip3 . V.imapMaybe (\i (e, mb) -> (\b -> (e, i, b)) <$> mb) $ V.zip eIds mapped + filteredArch = filterArchetype indices arch + (_, filteredArch', hook) <- runDynQuery q filteredArch {A.entities = Set.fromList $ V.toList filteredEIds} + let resultArch = unfilterArchetype indices arch filteredArch' + return (filteredBs, resultArch, hook) + where + filterArchetype indices arch = + arch {A.storages = IntMap.map (filterStorage indices) $ A.storages arch} + filterStorage indices s = + let allVec = toAscVectorDyn s + filteredVec = V.map (allVec V.!) indices + in fromAscVectorDyn filteredVec s + unfilterArchetype indices original filtered = + original {A.storages = IntMap.mapWithKey go $ A.storages original} + where + go cId s = case IntMap.lookup cId (A.storages filtered) of + Just filteredStorage -> + let origVec = toAscVectorDyn s + filteredVec = toAscVectorDyn filteredStorage + mergedVec = V.accum (\_ new -> new) origVec (V.toList $ V.zip indices filteredVec) + in fromAscVectorDyn mergedVec s + Nothing -> s + {-# INLINE queryFilterMap #-} + +-- | Match all entities. +readQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a) +readQueryDyn cIds q es = + if Set.null cIds + then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} + else do + let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) + results <- mapM go . Map.elems $ AS.find cIds $ archetypes es + return $ V.concat results + +-- | Match all entities with a filter. +readQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a) +readQueryFilteredDyn cIds f q es = + if Set.null cIds + then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} + else do + let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) + results <- mapM go . Map.elems . Map.filter f $ AS.find cIds $ archetypes es + return $ V.concat results + +-- | Match a single entity. +readQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m a +readQuerySingleDyn cIds q es = do + res <- readQuerySingleMaybeDyn cIds q es + case res of + Just a -> return a + _ -> error "readQuerySingleDyn: expected a single entity" + +-- | Match a single entity, or `Nothing`. +readQuerySingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Maybe a) +readQuerySingleMaybeDyn cIds q es = + if Set.null cIds + then case Map.keys $ entities es of + [eId] -> do + (v, _, _) <- runDynQuery q $ A.singleton eId + return $ if V.length v == 1 then Just (V.head v) else Nothing + _ -> return Nothing + else case Map.elems $ AS.find cIds $ archetypes es of + [n] -> do + (v, _, _) <- runDynQuery q $ AS.nodeArchetype n + return $ if V.length v == 1 then Just (V.head v) else Nothing + _ -> return Nothing + +-- | Map all matched entities. +runQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) +runQueryDyn cIds q es = + let go = runDynQuery q + in if Set.null cIds + then do + (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es} + return (as, es, hook) + else + let go' (acc, esAcc, hooks) (aId, n) = do + (as', arch', hook) <- go $ nodeArchetype n + let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc + return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) + in foldlM go' (V.empty, es, return ()) $ Map.toList . AS.find cIds $ archetypes es +{-# INLINE runQueryDyn #-} + +-- | Map all matched entities. +runQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) +runQueryFilteredDyn cIds f q es = + let go = runDynQuery q + in if Set.null cIds + then do + (as, _, hook) <- go A.empty {A.entities = Map.keysSet $ entities es} + return (as, es, hook) + else + let go' (acc, esAcc, hooks) (aId, n) = do + (as', arch', hook) <- go $ nodeArchetype n + let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc + return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) + in foldlM go' (V.empty, es, return ()) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es +{-# INLINE runQueryFilteredDyn #-} + +-- | Map a single matched entity. +runQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (a, Entities m, Access m ()) +runQuerySingleDyn cIds q es = do + res <- runQuerySingleMaybeDyn cIds q es + return $ case res of + (Just a, es', hook) -> (a, es', hook) + _ -> error "querySingleDyn: expected single matching entity" + +-- | Map a single matched entity, or @Nothing@. +runQuerySingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Maybe a, Entities m, Access m ()) +runQuerySingleMaybeDyn cIds q es = + if Set.null cIds + then case Map.keys $ entities es of + [eId] -> do + res <- runDynQuery q $ A.singleton eId + return $ case res of + (v, _, hook) | V.length v == 1 -> (Just (V.head v), es, hook) + _ -> (Nothing, es, return ()) + _ -> pure (Nothing, es, return ()) + else case Map.toList $ AS.find cIds $ archetypes es of + [(aId, n)] -> do + res <- runDynQuery q $ AS.nodeArchetype n + return $ case res of + (v, arch', hook) + | V.length v == 1 -> + let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es + in (Just (V.head v), es {archetypes = (archetypes es) {AS.nodes = nodes}}, hook) + _ -> (Nothing, es, return ()) + _ -> pure (Nothing, es, return ()) +{-# INLINE runQuerySingleMaybeDyn #-} + +-- | Dynamic query filter. +data DynamicQueryFilter = DynamicQueryFilter + { -- | `ComponentID`s to include. + filterWith :: !(Set ComponentID), + -- | `ComponentID`s to exclude. + filterWithout :: !(Set ComponentID) + } + +instance Semigroup DynamicQueryFilter where + DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB = + DynamicQueryFilter (withA <> withB) (withoutA <> withoutB) + {-# INLINE (<>) #-} + +instance Monoid DynamicQueryFilter where + mempty = DynamicQueryFilter mempty mempty + {-# INLINE mempty #-}
src/Aztecs/ECS/Query/Dynamic/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} -- |@@ -11,29 +12,53 @@ module Aztecs.ECS.Query.Dynamic.Class (DynamicQueryF (..)) where import Aztecs.ECS.Component+import Aztecs.ECS.Entity import Control.Monad -- | Dynamic query functor.------ @since 0.10-class (Applicative m, Functor f) => DynamicQueryF m f | f -> m where- -- | Adjust a `Component` by its `ComponentID`.- --- -- @since 0.10- adjustDyn :: (Component a) => (b -> a -> a) -> ComponentID -> f b -> f a+class (Monad m, Functor f) => DynamicQueryF m f | f -> m where+ -- | Fetch the currently matched `EntityID`.+ entity :: f EntityID - -- | Adjust a `Component` by its `ComponentID`, ignoring any output.- --- -- @since 0.10- adjustDyn_ :: (Component a) => (b -> a -> a) -> ComponentID -> f b -> f ()- adjustDyn_ f cId = void . adjustDyn f cId+ -- | Fetch a `Component` by its `ComponentID`.+ queryDyn :: (Component m a) => ComponentID -> f a - -- | Adjust a `Component` by its `ComponentID` with some applicative functor @g@.- --- -- @since 0.10- adjustDynM :: (Monad m, Component a) => (b -> a -> m a) -> ComponentID -> f b -> f a+ -- | Try to query a `Component` by its `ComponentID`.+ queryMaybeDyn :: (Component m a) => ComponentID -> f (Maybe a)+ queryMaybeDyn cId = Just <$> queryDyn cId - -- | Set a `Component` by its `ComponentID`.- --- -- @since 0.10- setDyn :: (Component a) => ComponentID -> f a -> f a+ -- | Map over a `Component` by its `ComponentID`.+ queryMapDyn :: (Component m a) => (a -> a) -> ComponentID -> f a++ -- | Map over a `Component` by its `ComponentID`, ignoring any output.+ queryMapDyn_ :: (Component m a) => (a -> a) -> ComponentID -> f ()+ queryMapDyn_ f cId = void $ queryMapDyn f cId++ -- | Map over a `Component` by its `ComponentID` with a monadic function.+ queryMapDynM :: (Monad m, Component m a) => (a -> m a) -> ComponentID -> f a++ -- | Map over a `Component` by its `ComponentID` with input.+ queryMapDynWith :: (Component m b) => (a -> b -> b) -> ComponentID -> f a -> f b++ -- | Map over a `Component` by its `ComponentID` with input, ignoring any output.+ queryMapDynWith_ :: (Component m b) => (a -> b -> b) -> ComponentID -> f a -> f ()+ queryMapDynWith_ f cId = void . queryMapDynWith f cId++ -- | Map over a `Component` by its `ComponentID` with input and a monadic function.+ queryMapDynWithM :: (Monad m, Component m b) => (a -> b -> m b) -> ComponentID -> f a -> f b++ -- | Map over a `Component` by its `ComponentID` with input, returning a tuple of the result and the updated component.+ queryMapDynWithAccum :: (Component m c) => (b -> c -> (a, c)) -> ComponentID -> f b -> f (a, c)++ -- | Map over a `Component` by its `ComponentID` with input and a monadic function, returning a tuple.+ queryMapDynWithAccumM :: (Monad m, Component m c) => (b -> c -> m (a, c)) -> ComponentID -> f b -> f (a, c)++ -- | Filter a query and map the results, constraining the query to entities that satisfy the predicate.+ queryFilterMap :: (a -> Maybe b) -> f a -> f b++ -- | Filter a query, constraining it to entities that satisfy the predicate.+ queryFilter :: (a -> Bool) -> f a -> f a+ queryFilter p fa = queryFilterMap (\a -> if p a then Just a else Nothing) fa++ -- | Run a query without tracking changes.+ queryUntracked :: f a -> f a
− src/Aztecs/ECS/Query/Dynamic/Reader.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- |--- Module : Aztecs.ECS.Query.Dynamic.Reader--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Dynamic.Reader- ( -- * Dynamic queries- DynamicQueryReader (..),- DynamicQueryReaderF (..),-- -- ** Running- allDyn,- filterDyn,- singleDyn,- singleMaybeDyn,-- -- * Dynamic query filters- DynamicQueryFilter (..),- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic.Reader.Class-import Aztecs.ECS.World.Archetype (Archetype)-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (Node)-import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Entities (Entities (..))-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Stack---- | Dynamic query reader.------ @since 0.10-newtype DynamicQueryReader a = DynamicQueryReader- { -- | Run a dynamic query reader.- --- -- @since 0.10- runDynQueryReader :: Archetype -> [a]- }- deriving (Functor)---- | @since 0.10-instance Applicative DynamicQueryReader where- {-# INLINE pure #-}- pure a = DynamicQueryReader $ \arch -> replicate (length $ A.entities arch) a-- {-# INLINE (<*>) #-}- f <*> g = DynamicQueryReader $ \arch ->- zipWith ($) (runDynQueryReader f arch) $ runDynQueryReader g arch---- | @since 0.10-instance DynamicQueryReaderF DynamicQueryReader where- {-# INLINE entity #-}- entity = DynamicQueryReader $ \arch -> Set.toList $ A.entities arch-- {-# INLINE fetchDyn #-}- fetchDyn cId = DynamicQueryReader $ \arch -> A.lookupComponentsAsc cId arch-- {-# INLINE fetchMaybeDyn #-}- fetchMaybeDyn cId = DynamicQueryReader $ \arch -> case A.lookupComponentsAscMaybe cId arch of- Just as -> fmap Just as- Nothing -> replicate (length $ A.entities arch) Nothing---- | Dynamic query for components by ID.------ @since 0.9---- | Dynamic query filter.------ @since 0.9-data DynamicQueryFilter = DynamicQueryFilter- { -- | `ComponentID`s to include.- --- -- @since 0.9- filterWith :: !(Set ComponentID),- -- | `ComponentID`s to exclude.- --- -- @since 0.9- filterWithout :: !(Set ComponentID)- }---- | @since 0.9-instance Semigroup DynamicQueryFilter where- DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB =- DynamicQueryFilter (withA <> withB) (withoutA <> withoutB)---- | @since 0.9-instance Monoid DynamicQueryFilter where- mempty = DynamicQueryFilter mempty mempty---- | Match all entities.------ @since 0.10-allDyn :: Set ComponentID -> DynamicQueryReader a -> Entities -> [a]-allDyn cIds q es =- if Set.null cIds- then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities es}- else- let go n = runDynQueryReader q $ AS.nodeArchetype n- in concatMap go (AS.find cIds $ archetypes es)---- | Match all entities with a filter.------ @since 0.10-filterDyn :: Set ComponentID -> (Node -> Bool) -> DynamicQueryReader a -> Entities -> [a]-filterDyn cIds f q es =- if Set.null cIds- then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities es}- else- let go n = runDynQueryReader q $ AS.nodeArchetype n- in concatMap go (Map.filter f $ AS.find cIds $ archetypes es)---- | Match a single entity.------ @since 0.10-singleDyn :: (HasCallStack) => Set ComponentID -> DynamicQueryReader a -> Entities -> a-singleDyn cIds q es = case singleMaybeDyn cIds q es of- Just a -> a- _ -> error "singleDyn: expected a single entity"---- | Match a single entity, or `Nothing`.------ @since 0.10-singleMaybeDyn :: Set ComponentID -> DynamicQueryReader a -> Entities -> Maybe a-singleMaybeDyn cIds q es =- if Set.null cIds- then case Map.keys $ entities es of- [eId] -> case runDynQueryReader q $ A.singleton eId of- [a] -> Just a- _ -> Nothing- _ -> Nothing- else case Map.elems $ AS.find cIds $ archetypes es of- [n] -> case runDynQueryReader q $ AS.nodeArchetype n of- [a] -> Just a- _ -> Nothing- _ -> Nothing
− src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs
@@ -1,32 +0,0 @@--- |--- Module : Aztecs.ECS.Query.Dynamic.Reader.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Dynamic.Reader.Class (DynamicQueryReaderF (..)) where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity---- | Dynamic query reader functor.------ @since 0.10-class (Functor f) => DynamicQueryReaderF f where- -- | Fetch the currently matched `EntityID`.- --- -- @since 0.10- entity :: f EntityID-- -- | Fetch a `Component` by its `ComponentID`.- --- -- @since 0.10- fetchDyn :: (Component a) => ComponentID -> f a-- -- | Try to fetch a `Component` by its `ComponentID`.- --- -- @since 0.10- fetchMaybeDyn :: (Component a) => ComponentID -> f (Maybe a)- fetchMaybeDyn cId = Just <$> fetchDyn cId
− src/Aztecs/ECS/Query/Reader.hs
@@ -1,175 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.Query.Dynamic--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Reader- ( -- * Queries- QueryReader (..),- QueryReaderF (..),- DynamicQueryReaderF (..),-- -- ** Running- all,- all',- single,- single',- singleMaybe,- singleMaybe',-- -- * Filters- QueryFilter (..),- with,- without,- DynamicQueryFilter (..),- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic.Reader-import Aztecs.ECS.Query.Reader.Class-import Aztecs.ECS.World.Components (Components)-import qualified Aztecs.ECS.World.Components as CS-import Aztecs.ECS.World.Entities (Entities (..))-import qualified Aztecs.ECS.World.Entities as E-import Control.Monad.Identity-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Stack-import Prelude hiding (all)---- | Query to read from entities.------ @since 0.10-newtype QueryReader a- = QueryReader- { -- | Run a query reader.- --- -- @since 0.10- runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReader a)- }- deriving (Functor)---- | @since 0.10-instance Applicative QueryReader where- pure a = QueryReader (mempty,,pure a)- {-# INLINE pure #-}-- (QueryReader f) <*> (QueryReader g) = QueryReader $ \cs ->- let !(cIdsG, cs', aQS) = g cs- !(cIdsF, cs'', bQS) = f cs'- in (cIdsG <> cIdsF, cs'', bQS <*> aQS)- {-# INLINE (<*>) #-}---- | @since 0.10-instance QueryReaderF QueryReader where- fetch :: forall a. (Component a) => QueryReader a- fetch = QueryReader $ \cs ->- let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchDyn cId)- {-# INLINE fetch #-}-- fetchMaybe :: forall a. (Component a) => QueryReader (Maybe a)- fetchMaybe = QueryReader $ \cs ->- let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchMaybeDyn cId)- {-# INLINE fetchMaybe #-}---- | @since 0.10-instance DynamicQueryReaderF QueryReader where- {-# INLINE entity #-}- entity = QueryReader (mempty,,entity)- {-# INLINE fetchDyn #-}- fetchDyn cId = QueryReader (Set.singleton cId,,fetchDyn cId)- {-# INLINE fetchMaybeDyn #-}- fetchMaybeDyn cId = QueryReader (Set.singleton cId,,fetchMaybeDyn cId)---- | Filter for a `Query`.------ @since 0.9-newtype QueryFilter = QueryFilter- { -- | Run a query filter.- runQueryFilter :: Components -> (DynamicQueryFilter, Components)- }---- | @since 0.9-instance Semigroup QueryFilter where- a <> b =- QueryFilter- ( \cs ->- let !(withA', cs') = runQueryFilter a cs- !(withB', cs'') = runQueryFilter b cs'- in (withA' <> withB', cs'')- )---- | @since 0.9-instance Monoid QueryFilter where- mempty = QueryFilter (mempty,)---- | Filter for entities containing this component.------ @since 0.9-with :: forall a. (Component a) => QueryFilter-with = QueryFilter $ \cs ->- let !(cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')---- | Filter out entities containing this component.------ @since 0.9-without :: forall a. (Component a) => QueryFilter-without = QueryFilter $ \cs ->- let !(cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')---- | Match all entities.------ @since 0.10-{-# INLINE all #-}-all :: QueryReader a -> Entities -> ([a], Entities)-all q es = let !(as, cs) = all' q es in (as, es {E.components = cs})---- | Match all entities.------ @since 0.10-{-# INLINE all' #-}-all' :: QueryReader a -> Entities -> ([a], Components)-all' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (allDyn rs dynQ es, cs')---- | Match a single entity.------ @since 0.10-{-# INLINE single #-}-single :: (HasCallStack) => QueryReader a -> Entities -> (a, Entities)-single q es = let !(a, cs) = single' q es in (a, es {E.components = cs})---- | Match a single entity.------ @since 0.10-{-# INLINE single' #-}-single' :: (HasCallStack) => QueryReader a -> Entities -> (a, Components)-single' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleDyn rs dynQ es, cs')---- | Match a single entity.------ @since 0.10-{-# INLINE singleMaybe #-}-singleMaybe :: QueryReader a -> Entities -> (Maybe a, Entities)-singleMaybe q es = let !(a, cs) = singleMaybe' q es in (a, es {E.components = cs})---- | Match a single entity.------ @since 0.10-{-# INLINE singleMaybe' #-}-singleMaybe' :: QueryReader a -> Entities -> (Maybe a, Components)-singleMaybe' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleMaybeDyn rs dynQ es, cs')
− src/Aztecs/ECS/Query/Reader/Class.hs
@@ -1,26 +0,0 @@--- |--- Module : Aztecs.ECS.Query.Reader.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Reader.Class (QueryReaderF (..)) where--import Aztecs.ECS.Component---- | Query reader functor.------ @since 0.10-class (Functor f) => QueryReaderF f where- -- | Fetch a `Component` by its type.- --- -- @since 0.10- fetch :: (Component a) => f a-- -- | Fetch a `Component` by its type, returning `Nothing` if it doesn't exist.- --- -- @since 0.10- fetchMaybe :: (Component a) => f (Maybe a)- fetchMaybe = Just <$> fetch
src/Aztecs/ECS/System.hs view
@@ -1,8 +1,13 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Aztecs.ECS.System@@ -12,152 +17,132 @@ -- Maintainer : matt@hunzinger.me -- Stability : provisional -- Portability : non-portable (GHC extensions)------ Systems to process queries in parallel. module Aztecs.ECS.System- ( System,- SystemT (..),- MonadReaderSystem (..),- MonadSystem (..),- MonadDynamicReaderSystem (..),- MonadDynamicSystem (..),+ ( -- * Systems+ System (..),++ -- * Dynamic systems+ DynamicSystem (..),+ runDynamicSystem,++ -- ** Queries+ readQuery,+ readQueryFiltered,+ readQuerySingle,+ readQuerySingleMaybe,+ runQuery,+ runQueryFiltered,+ runQuerySingle,+ runQuerySingleMaybe,++ -- ** Dynamic queries+ readQueryDyn,+ readQueryFilteredDyn,+ readQuerySingleMaybeDyn,+ runQueryDyn,+ runQueryFilteredDyn,+ runQuerySingleMaybeDyn, ) where import Aztecs.ECS.Component-import Aztecs.ECS.Query+import Aztecs.ECS.Query (Query (..), QueryFilter (..)) import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Dynamic (DynamicQueryT)-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))-import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System.Class-import Aztecs.ECS.System.Dynamic.Class-import Aztecs.ECS.System.Dynamic.Reader.Class-import Aztecs.ECS.System.Reader.Class-import qualified Aztecs.ECS.View as V+import Aztecs.ECS.Query.Dynamic (DynamicQuery, DynamicQueryFilter (..))+import Aztecs.ECS.System.Dynamic (DynamicSystem (..), runDynamicSystem)+import qualified Aztecs.ECS.System.Dynamic as DS import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Archetypes (Node (..))-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Category-import Control.Concurrent.STM-import Control.Monad.Identity-import Control.Monad.Reader+import Aztecs.ECS.World.Components (Components) import qualified Data.Foldable as F-import qualified Data.Map as Map import Data.Set (Set)-import Prelude hiding (all, filter, id, map, (.))+import Data.Vector (Vector)+import GHC.Stack+import Prelude hiding (all, filter, map, mapM) --- | @since 0.9-type System = SystemT STM+-- | System for querying entities.+newtype System m a = System {runSystem :: Components -> (Components, DynamicSystem m a)} --- | System to process queries in parallel.------ @since 0.9-newtype SystemT m a = SystemT- { -- | Run a system on a collection of `Entities`.- --- -- @since 0.9- runSystemT :: ReaderT (TVar Entities) m a- }- deriving (Functor, Applicative, Monad)+instance Functor (System m) where+ fmap f (System g) = System $ \cs ->+ let !(cs', dynS) = g cs in (cs', fmap f dynS)+ {-# INLINE fmap #-} --- | @since 0.9-instance MonadDynamicSystem (DynamicQueryT STM) System where- mapDyn cIds q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.view cIds $ archetypes w- (o, v') <- lift $ V.mapDyn q v- lift . modifyTVar wVar $ V.unview v'- return o- mapSingleMaybeDyn cIds q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- case V.viewSingle cIds $ archetypes w of- Just v -> do- (o, v') <- lift $ V.mapSingleDyn q v- lift . modifyTVar wVar $ V.unview v'- return o- Nothing -> return Nothing- filterMapDyn cIds f q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.filterView cIds f $ archetypes w- (o, v') <- lift $ V.mapDyn q v- lift . modifyTVar wVar $ V.unview v'- return o+instance Applicative (System m) where+ pure a = System (,Pure a)+ {-# INLINE pure #-} --- | @since 0.9-instance MonadSystem (QueryT STM) System where- map q = SystemT $ do- (rws, dynQ) <- runSystemT $ fromQuery q- runSystemT $ mapDyn (Q.reads rws <> Q.writes rws) dynQ- mapSingleMaybe q = SystemT $ do- (rws, dynQ) <- runSystemT $ fromQuery q- runSystemT $ mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ- filterMap q qf = SystemT $ do- wVar <- ask- let go w =- let (rws, cs', dynQ) = runQuery q $ components w- (dynF, cs'') = runQueryFilter qf cs'- in ((rws, dynQ, dynF), w {components = cs''})- (rws, dynQ, dynF) <- lift $ stateTVar wVar go- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- runSystemT $ filterMapDyn (Q.reads rws <> Q.writes rws) f' dynQ+ (System f) <*> (System g) = System $ \cs ->+ let !(cs', dynF) = f cs+ !(cs'', dynG) = g cs'+ in (cs'', dynF <*> dynG)+ {-# INLINE (<*>) #-} --- | @since 0.9-instance MonadReaderSystem QueryReader System where- all q = SystemT $ do- (cIds, dynQ) <- runSystemT $ fromQueryReader q- runSystemT $ allDyn cIds dynQ- filter q qf = SystemT $ do- wVar <- ask- let go w =- let (cIds, cs', dynQ) = runQueryReader q $ components w- (dynF, cs'') = runQueryFilter qf cs'- in ((cIds, dynQ, dynF), w {components = cs''})- (cIds, dynQ, dynF) <- lift $ stateTVar wVar go- let f' n =- F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)- && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)- runSystemT $ filterDyn cIds dynQ f'+runner :: (Set ComponentID -> DynamicQuery m a -> DynamicSystem m b) -> Query m a -> System m b+runner f q = System $ \cs ->+ let (rws, cs', dynQ) = runQuery' q cs+ in (cs', f (Q.reads rws <> Q.writes rws) dynQ) --- | @since 0.9-instance MonadDynamicReaderSystem DynamicQueryReader System where- allDyn cIds q = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.view cIds $ archetypes w- return $- if V.null v- then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities w}- else V.allDyn q v- filterDyn cIds q f = SystemT $ do- wVar <- ask- w <- lift $ readTVar wVar- let !v = V.filterView cIds f $ archetypes w- return $ V.allDyn q v+-- | Match all entities.+readQuery :: (Monad m) => Query m a -> System m (Vector a)+readQuery = runner DS.readQuery --- | Convert a `QueryReaderT` to a `System`.------ @since 0.9-fromQueryReader :: QueryReader a -> System (Set ComponentID, DynamicQueryReader a)-fromQueryReader q = SystemT $ do- wVar <- ask- let go w =- let (cIds, cs', dynQ) = runQueryReader q $ components w- in ((cIds, dynQ), w {components = cs'})- lift $ stateTVar wVar go+readQuerySingle :: (HasCallStack, Monad m) => Query m a -> System m a+readQuerySingle = runner DS.readQuerySingle --- | Convert a `QueryT` to a `System`.------ @since 0.9-fromQuery :: QueryT STM a -> System (ReadsWrites, DynamicQueryT STM a)-fromQuery q = SystemT $ do- wVar <- ask- let go w =- let (rws, cs', dynQ) = runQuery q $ components w- in ((rws, dynQ), w {components = cs'})- lift $ stateTVar wVar go+readQuerySingleMaybe :: (Monad m) => Query m a -> System m (Maybe a)+readQuerySingleMaybe = runner DS.readQuerySingleMaybe++-- | Match all entities with a filter.+readQueryFiltered :: (Monad m) => Query m a -> QueryFilter -> System m (Vector a)+readQueryFiltered q f = System $ \cs ->+ let (rws, cs', dynQ) = runQuery' q cs+ (dynF, cs'') = runQueryFilter f cs'+ flt n =+ F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+ && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+ in (cs'', DS.readQueryFiltered (Q.reads rws <> Q.writes rws) flt dynQ)++-- | Map all matching entities.+runQuery :: (Monad m) => Query m a -> System m (Vector a)+runQuery = runner DS.runQuery++runQuerySingle :: (HasCallStack, Monad m) => Query m a -> System m a+runQuerySingle = runner DS.runQuerySingle++-- | Map a single matching entity, or @Nothing@.+runQuerySingleMaybe :: (Monad m) => Query m a -> System m (Maybe a)+runQuerySingleMaybe = runner DS.runQuerySingleMaybe++-- | Filter and map all matching entities.+runQueryFiltered :: (Monad m) => Query m a -> QueryFilter -> System m (Vector a)+runQueryFiltered q f = System $ \cs ->+ let (rws, cs', dynQ) = runQuery' q cs+ (dynF, cs'') = runQueryFilter f cs'+ flt n =+ F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+ && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+ in (cs'', DS.runQueryFiltered (Q.reads rws <> Q.writes rws) dynQ flt)++-- | Match all entities with a dynamic query.+readQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m (Vector a)+readQueryDyn cIds q = System (,DS.readQuery cIds q)++readQuerySingleMaybeDyn :: Set ComponentID -> DynamicQuery m a -> System m (Maybe a)+readQuerySingleMaybeDyn cIds q = System (,DS.readQuerySingleMaybe cIds q)++-- | Match all entities with a dynamic query and filter.+readQueryFilteredDyn :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> System m (Vector a)+readQueryFilteredDyn cIds q f = System (,DS.readQueryFiltered cIds f q)++-- | Map all entities with a dynamic query.+runQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m (Vector a)+runQueryDyn cIds q = System (,DS.runQuery cIds q)++-- | Map a single entity with a dynamic query.+runQuerySingleMaybeDyn :: Set ComponentID -> DynamicQuery m a -> System m (Maybe a)+runQuerySingleMaybeDyn cIds q = System (,DS.runQuerySingleMaybe cIds q)++-- | Filter and map all entities with a dynamic query.+runQueryFilteredDyn :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> System m (Vector a)+runQueryFilteredDyn cIds f q = System (,DS.runQueryFiltered cIds q f)
− src/Aztecs/ECS/System/Class.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.System.Class (MonadSystem (..)) where--import Aztecs.ECS.Query.Reader (QueryFilter (..))-import GHC.Stack-import Prelude hiding (map)---- | Monadic system.------ @since 0.9-class (Monad m) => MonadSystem q m | m -> q where- -- | Map all matching entities with a query.- --- -- @since 0.9- map :: q a -> m [a]-- -- | Map a single matching entity with a query, or @Nothing@.- --- -- @since 0.9- mapSingleMaybe :: q a -> m (Maybe a)-- -- | Map a single matching entity with a query.- --- -- @since 0.9- mapSingle :: (HasCallStack) => q a -> m a- mapSingle q = do- res <- mapSingleMaybe q- case res of- Just a -> return a- Nothing -> error "Expected a single matching entity."-- -- | Map all matching entities with a query and filter.- --- -- @since 0.9- filterMap :: q a -> QueryFilter -> m [a]
+ src/Aztecs/ECS/System/Dynamic.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module : Aztecs.ECS.System +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.System.Dynamic + ( -- * Dynamic systems + DynamicSystem (..), + runDynamicSystem, + + -- ** Queries + runQuery, + runQueryFiltered, + runQuerySingle, + runQuerySingleMaybe, + readQuery, + readQueryFiltered, + readQuerySingle, + readQuerySingleMaybe, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Query.Dynamic (DynamicQuery) +import qualified Aztecs.ECS.Query.Dynamic as DQ +import Aztecs.ECS.World.Archetypes (Node (..)) +import Aztecs.ECS.World.Entities (Entities) +import Data.Set (Set) +import Data.Vector (Vector) +import Prelude hiding (all, filter, map, mapM) + +-- | Query operation. +data Op m a where + RunQuery :: DynamicQuery m a -> Op m (Vector a) + RunFiltered :: (Node m -> Bool) -> DynamicQuery m a -> Op m (Vector a) + RunQuerySingle :: DynamicQuery m a -> Op m a + RunQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) + ReadQuery :: DynamicQuery m a -> Op m (Vector a) + ReadQueryFiltered :: DynamicQuery m a -> (Node m -> Bool) -> Op m (Vector a) + ReadQuerySingle :: DynamicQuery m a -> Op m a + ReadQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) + +-- | Run a query operation on entities. +runOp :: (Monad m) => Set ComponentID -> Op m a -> Entities m -> m (a, Entities m, Access m ()) +runOp cIds (RunQuery q) es = DQ.runQueryDyn cIds q es +runOp cIds (RunFiltered flt q) es = DQ.runQueryFilteredDyn cIds flt q es +runOp cIds (RunQuerySingle q) es = DQ.runQuerySingleDyn cIds q es +runOp cIds (RunQuerySingleMaybe q) es = DQ.runQuerySingleMaybeDyn cIds q es +runOp cIds (ReadQuery q) es = do + as <- DQ.readQueryDyn cIds q es + return (as, es, return ()) +runOp cIds (ReadQueryFiltered q flt) es = do + as <- DQ.readQueryFilteredDyn cIds flt q es + return (as, es, return ()) +runOp cIds (ReadQuerySingle q) es = do + a <- DQ.readQuerySingleDyn cIds q es + return (a, es, return ()) +runOp cIds (ReadQuerySingleMaybe q) es = do + a <- DQ.readQuerySingleMaybeDyn cIds q es + return (a, es, return ()) +{-# INLINE runOp #-} + +-- | Dynamic system. +data DynamicSystem m a where + -- | Pure value. + Pure :: a -> DynamicSystem m a + -- | Functor map. + Map :: (b -> a) -> DynamicSystem m b -> DynamicSystem m a + -- | Applicative apply. + Ap :: DynamicSystem m (b -> a) -> DynamicSystem m b -> DynamicSystem m a + -- | Query operation. + Op :: Set ComponentID -> Op m a -> DynamicSystem m a + +instance Functor (DynamicSystem m) where + fmap f (Pure a) = Pure (f a) + fmap f s = Map f s + {-# INLINE fmap #-} + +instance Applicative (DynamicSystem m) where + pure = Pure + {-# INLINE pure #-} + + Pure f <*> s = fmap f s + f <*> Pure a = fmap ($ a) f + f <*> s = Ap f s + {-# INLINE (<*>) #-} + +-- | Run a dynamic system on entities, returning results, updated entities, and hooks to run. +runDynamicSystem :: (Monad m) => DynamicSystem m a -> Entities m -> m (a, Entities m, Access m ()) +runDynamicSystem (Pure a) es = return (a, es, return ()) +runDynamicSystem (Map f s) es = do + (b, es', hook) <- runDynamicSystem s es + return (f b, es', hook) +runDynamicSystem (Ap sf sa) es = do + (f, es', hook1) <- runDynamicSystem sf es + (a, es'', hook2) <- runDynamicSystem sa es' + return (f a, es'', hook1 >> hook2) +runDynamicSystem (Op cIds op) es = runOp cIds op es +{-# INLINE runDynamicSystem #-} + +runQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) +runQuery cIds q = Op cIds (RunQuery q) +{-# INLINE runQuery #-} + +runQueryFiltered :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> DynamicSystem m (Vector a) +runQueryFiltered cIds q flt = Op cIds (RunFiltered flt q) +{-# INLINE runQueryFiltered #-} + +runQuerySingle :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m a +runQuerySingle cIds q = Op cIds (RunQuerySingle q) +{-# INLINE runQuerySingle #-} + +runQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Maybe a) +runQuerySingleMaybe cIds q = Op cIds (RunQuerySingleMaybe q) +{-# INLINE runQuerySingleMaybe #-} + +readQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) +readQuery cIds q = Op cIds (ReadQuery q) +{-# INLINE readQuery #-} + +readQueryFiltered :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> DynamicSystem m (Vector a) +readQueryFiltered cIds flt q = Op cIds (ReadQueryFiltered q flt) +{-# INLINE readQueryFiltered #-} + +readQuerySingle :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m a +readQuerySingle cIds q = Op cIds (ReadQuerySingle q) + +readQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Maybe a) +readQuerySingleMaybe cIds q = Op cIds (ReadQuerySingleMaybe q) +{-# INLINE readQuerySingleMaybe #-}
− src/Aztecs/ECS/System/Dynamic/Class.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Dynamic.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.System.Dynamic.Class (MonadDynamicSystem (..)) where--import Aztecs.ECS.Component (ComponentID)-import Aztecs.ECS.World.Archetypes (Node (..))-import Data.Set (Set)-import GHC.Stack---- | Monadic dynamic system.------ @since 0.9-class (Monad m) => MonadDynamicSystem q m | m -> q where- -- | Map all matching entities with a query.- --- -- @since 0.9- mapDyn :: Set ComponentID -> q a -> m [a]-- -- | Map a single matching entity with a query, or @Nothing@.- --- -- @since 0.9- mapSingleMaybeDyn :: Set ComponentID -> q a -> m (Maybe a)-- -- | Map a single matching entity with a query.- mapSingleDyn :: (HasCallStack) => Set ComponentID -> q a -> m a- mapSingleDyn cIds q = do- res <- mapSingleMaybeDyn cIds q- case res of- Just a -> return a- Nothing -> error "Expected a single matching entity."-- -- | Map all matching entities with a query and filter.- --- -- @since 0.9- filterMapDyn :: Set ComponentID -> (Node -> Bool) -> q a -> m [a]
− src/Aztecs/ECS/System/Dynamic/Reader/Class.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Dynamic.Reader.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.System.Dynamic.Reader.Class (MonadDynamicReaderSystem (..)) where--import Aztecs.ECS.Component-import Aztecs.ECS.World.Archetypes (Node)-import Data.Set (Set)-import GHC.Stack---- | Monadic dynamic reader system.------ @since 0.9-class (Monad m) => MonadDynamicReaderSystem q m | m -> q where- -- | Match all entities with a query.- --- -- @since 0.9- allDyn :: Set ComponentID -> q a -> m [a]-- -- | Match a single entity with a query.- --- -- @since 0.9- singleDyn :: (HasCallStack) => Set ComponentID -> q a -> m a- singleDyn cIds q = do- os <- allDyn cIds q- case os of- [o] -> return o- _ -> error "singleDyn: expected a single result, but got multiple"-- -- | Match a single entity with a query, or Nothing.- --- -- @since 0.9- singleMaybeDyn :: Set ComponentID -> q a -> m (Maybe a)- singleMaybeDyn cIds q = do- os <- allDyn cIds q- return $ case os of- [o] -> Just o- _ -> Nothing-- -- | Match all entities with a query and filter.- --- -- @since 0.9- filterDyn :: Set ComponentID -> q a -> (Node -> Bool) -> m [a]
− src/Aztecs/ECS/System/Reader/Class.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}---- |--- Module : Aztecs.ECS.System.Reader.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.System.Reader.Class (MonadReaderSystem (..)) where--import Aztecs.ECS.Query.Reader (QueryFilter (..))-import GHC.Stack-import Prelude hiding (all)---- | Monadic reader system.------ @since 0.9-class (Monad m) => MonadReaderSystem q m | m -> q where- -- | Match all entities with a query.- --- -- @since 0.9- all :: q a -> m [a]-- -- | Match a single entity with a query.- --- -- @since 0.9- single :: (HasCallStack) => q a -> m a- single q = do- os <- all q- case os of- [o] -> return o- _ -> error "single: expected a single result"-- -- | Match a single entity with a query, or @Nothing@.- --- -- @since 0.9- singleMaybe :: q a -> m (Maybe a)- singleMaybe q = do- os <- all q- return $ case os of- [o] -> Just o- _ -> Nothing-- -- | Match all entities with a query and filter.- --- -- @since 0.9- filter :: q a -> QueryFilter -> m [a]
src/Aztecs/ECS/View.hs view
@@ -25,64 +25,53 @@ ) where -import Aztecs.ECS.Query.Dynamic (DynamicQueryT (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.Access.Internal (Access)+import Aztecs.ECS.Query.Dynamic (DynamicQuery (..)) import Aztecs.ECS.World.Archetypes import qualified Aztecs.ECS.World.Archetypes as AS import Aztecs.ECS.World.Components import Aztecs.ECS.World.Entities (Entities) import qualified Aztecs.ECS.World.Entities as E-import Data.Foldable (foldl', foldlM)+import Control.Monad.Identity (Identity (runIdentity))+import Data.Foldable hiding (null) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set)+import Data.Vector (Vector)+import qualified Data.Vector as V import Prelude hiding (null) -- | View into a `World`, containing a subset of archetypes.------ @since 0.9-newtype View = View+newtype View m = View { -- | Archetypes contained in this view.- --- -- @since 0.9- viewArchetypes :: Map ArchetypeID Node+ viewArchetypes :: Map ArchetypeID (Node m) } deriving (Show, Semigroup, Monoid) -- | View into all archetypes containing the provided component IDs.------ @since 0.9-view :: Set ComponentID -> Archetypes -> View+view :: Set ComponentID -> Archetypes m -> View m view cIds as = View $ AS.find cIds as -- | View into a single archetype containing the provided component IDs.------ @since 0.9-viewSingle :: Set ComponentID -> Archetypes -> Maybe View+viewSingle :: Set ComponentID -> Archetypes m -> Maybe (View m) viewSingle cIds as = case Map.toList $ AS.find cIds as of [a] -> Just . View $ uncurry Map.singleton a _ -> Nothing -- | View into all archetypes containing the provided component IDs and matching the provided predicate.------ @since 0.9 filterView :: Set ComponentID ->- (Node -> Bool) ->- Archetypes ->- View+ (Node m -> Bool) ->+ Archetypes m ->+ View m filterView cIds f as = View $ Map.filter f (AS.find cIds as) -- | @True@ if the `View` is empty.------ @since 0.9-null :: View -> Bool+null :: View m -> Bool null = Map.null . viewArchetypes -- | "Un-view" a `View` back into a `World`.------ @since 0.9-unview :: View -> Entities -> Entities+unview :: View m -> Entities m -> Entities m unview v es = es { E.archetypes =@@ -93,47 +82,39 @@ } -- | Query all matching entities in a `View`.------ @since 0.9-allDyn :: DynamicQueryReader a -> View -> [a]+allDyn :: DynamicQuery Identity a -> View Identity -> Vector a allDyn q v = foldl' ( \acc n ->- let as = runDynQueryReader q $ nodeArchetype n- in as ++ acc+ let (as, _, _) = runIdentity . runDynQuery q $ nodeArchetype n+ in as V.++ acc )- []+ V.empty (viewArchetypes v) -- | Query all matching entities in a `View`.------ @since 0.9-singleDyn :: DynamicQueryReader a -> View -> Maybe a+singleDyn :: DynamicQuery Identity a -> View Identity -> Maybe a singleDyn q v = case allDyn q v of- [a] -> Just a+ as | V.length as == 1 -> Just (V.head as) _ -> Nothing --- | Map all matching entities in a `View`.------ @since 0.9-mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m ([a], View)+-- | Map all matching entities in a `View`. Returns the results, updated view, and hooks to run.+mapDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Vector a, View m, Access m ()) mapDyn q v = do- (as, arches) <-+ (as, arches, hooks) <- foldlM- ( \(acc, archAcc) (aId, n) -> do- (as', arch') <- runDynQuery q $ nodeArchetype n- return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)+ ( \(acc, archAcc, hooksAcc) (aId, n) -> do+ (as', arch', hook) <- runDynQuery q $ nodeArchetype n+ return (as' V.++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc, hooksAcc >> hook) )- ([], Map.empty)+ (V.empty, Map.empty, return ()) (Map.toList $ viewArchetypes v)- return (as, View arches)+ return (as, View arches, hooks) --- | Map a single matching entity in a `View`.------ @since 0.9-mapSingleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a, View)+-- | Map a single matching entity in a `View`. Returns the result, updated view, and hooks to run.+mapSingleDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Maybe a, View m, Access m ()) mapSingleDyn q v = do- (as, arches) <- mapDyn q v+ (as, arches, hooks) <- mapDyn q v return $ case as of- [a] -> (Just a, arches)- _ -> (Nothing, arches)+ a | V.length a == 1 -> (Just (V.head a), arches, hooks)+ _ -> (Nothing, arches, hooks)
src/Aztecs/ECS/World.hs view
@@ -1,105 +1,89 @@-{-# 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 FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World + ( World (..), + empty, + spawn, + spawnEmpty, + insert, + insertUntracked, + lookup, + remove, + removeWithId, + despawn, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Bundle +import qualified Aztecs.ECS.World.Entities as E +import Aztecs.ECS.World.Internal (World (..)) +import qualified Aztecs.ECS.World.Observers as O +import Data.Dynamic +import Data.IntMap (IntMap) +import Prelude hiding (lookup) + +-- | Empty `World`. +empty :: World m +empty = + World + { entities = E.empty, + nextEntityId = EntityID 0, + observers = O.empty + } + +-- | Spawn a `Bundle` into the `World`. Returns the entity ID, updated world, and onInsert hook. +spawn :: (Monad m) => BundleT m -> World m -> (EntityID, World m, Access m ()) +spawn b w = + let e = nextEntityId w + (es', hook) = E.spawn e b $ entities w + in (e, w {entities = es', nextEntityId = EntityID $ unEntityId e + 1}, hook) + +-- | Spawn an empty entity. +spawnEmpty :: World m -> (EntityID, World m) +spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID $ unEntityId e + 1}) + +-- | Insert a `Bundle` into an entity. Returns updated world and onInsert hook. +insert :: (Monad m) => EntityID -> BundleT m -> World m -> (World m, Access m ()) +insert e c w = + let (es', hook) = E.insert e c (entities w) + in (w {entities = es'}, hook) + +-- | Insert a `Bundle` into an entity without running lifecycle hooks. +insertUntracked :: (Monad m) => EntityID -> BundleT m -> World m -> World m +insertUntracked e c w = + let es' = E.insertUntracked e c (entities w) + in w {entities = es'} + +-- | Lookup a component in an entity. +lookup :: forall m a. (Component m a) => EntityID -> World m -> Maybe a +lookup e w = E.lookup e $ entities w + +-- | Remove a component from an entity. Returns the component (if found), updated world, and onRemove hook. +remove :: forall m a. (Component m a) => EntityID -> World m -> (Maybe a, World m, Access m ()) +remove e w = + let (a, es, hook) = E.remove e (entities w) + in (a, w {entities = es}, hook) + +-- | Remove a component from an entity with its `ComponentID`. Returns the component (if found), updated world, and onRemove hook. +removeWithId :: forall m a. (Component m a) => EntityID -> ComponentID -> World m -> (Maybe a, World m, Access m ()) +removeWithId e cId w = + let (a, es, hook) = E.removeWithId e cId (entities w) + in (a, w {entities = es}, hook) + +-- | Despawn an entity, returning its components. +despawn :: EntityID -> World m -> (IntMap Dynamic, World m) +despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es})
src/Aztecs/ECS/World/Archetype.hs view
@@ -1,261 +1,275 @@-{-# 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,- zipWith,- zipWith_,- zipWithM,- )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import qualified Aztecs.ECS.World.Storage as S-import Aztecs.ECS.World.Storage.Dynamic-import qualified Aztecs.ECS.World.Storage.Dynamic as S-import Control.DeepSeq-import Control.Monad.Writer- ( MonadWriter (..),- WriterT (..),- runWriter,- )-import Data.Dynamic-import Data.Foldable-import Data.IntMap (IntMap)-import qualified Data.IntMap.Strict as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics-import Prelude hiding (map, zipWith)---- | Archetype of entities and components.--- An archetype is guranteed to contain one of each stored component per entity.------ @since 0.9-data Archetype = Archetype- { -- | Component storages.- --- -- @since 0.9- storages :: !(IntMap DynamicStorage),- -- | Entities stored in this archetype.- --- -- @since 0.9- entities :: !(Set EntityID)- }- deriving (Show, Generic, 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---- | Zip a list of components with a function and a component storage.------ @since 0.9-{-# INLINE zipWith #-}-zipWith ::- forall a c. (Component c) => [a] -> (a -> c -> c) -> ComponentID -> Archetype -> ([c], Archetype)-zipWith as f cId arch =- let go maybeDyn = case maybeDyn of- Just dyn -> case fromDynamic $ storageDyn dyn of- Just s -> do- let !(cs', s') = S.zipWith @c @(StorageT c) f as s- tell cs'- return $ Just $ dyn {storageDyn = toDyn s'}- Nothing -> return maybeDyn- Nothing -> return Nothing- !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch- in (cs, arch {storages = storages'})---- | Zip a list of components with a monadic function and a component storage.------ @since 0.9-zipWithM ::- forall m a c. (Applicative m, Component c) => [a] -> (a -> c -> m c) -> ComponentID -> Archetype -> m ([c], Archetype)-zipWithM as f cId arch = do- let go maybeDyn = case maybeDyn of- Just dyn -> case fromDynamic $ storageDyn dyn of- Just s ->- WriterT $- fmap- (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs))- (S.zipWithM @c @(StorageT c) f as s)- Nothing -> pure maybeDyn- Nothing -> pure Nothing- res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch- return (snd res, arch {storages = fst res})---- | Zip a list of components with a function and a component storage.------ @since 0.9-{-# INLINE zipWith_ #-}-zipWith_ ::- forall a c. (Component c) => [a] -> (a -> c -> c) -> ComponentID -> Archetype -> Archetype-zipWith_ as f cId arch =- let maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of- Just dyn -> case fromDynamic $ storageDyn dyn of- Just s ->- let !s' = S.zipWith_ @c @(StorageT c) f as s in Just $ dyn {storageDyn = toDyn s'}- Nothing -> Nothing- Nothing -> Nothing- in (empty {storages = maybe IntMap.empty (IntMap.singleton (unComponentId cId)) maybeStorage})---- | 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 DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Archetype +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Archetype + ( Archetype (..), + empty, + singleton, + lookupComponent, + lookupComponents, + lookupComponentsAsc, + lookupComponentsAscMaybe, + lookupStorage, + member, + remove, + removeStorages, + insertComponent, + insertComponentUntracked, + insertComponents, + insertAscVector, + zipWith, + zipWith_, + zipWithM, + zipWithAccum, + zipWithAccumM, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import Aztecs.ECS.World.Archetype.Internal +import qualified Aztecs.ECS.World.Storage as S +import Aztecs.ECS.World.Storage.Dynamic +import qualified Aztecs.ECS.World.Storage.Dynamic as S +import Control.Monad.Writer +import Data.Dynamic +import Data.Foldable +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import Prelude hiding (map, zipWith) + +-- | Archetype with a single entity. +singleton :: EntityID -> Archetype m +singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e} + +-- | Lookup a component `Storage` by its `ComponentID`. +lookupStorage :: (Component m a) => ComponentID -> Archetype m -> Maybe (StorageT a) +lookupStorage cId w = do + !dynS <- IntMap.lookup (unComponentId cId) $ storages w + fromDynamic $ storageDyn dynS +{-# INLINE lookupStorage #-} + +-- | Lookup a component by its `EntityID` and `ComponentID`. +lookupComponent :: forall m a. (Component m a) => EntityID -> ComponentID -> Archetype m -> Maybe a +lookupComponent e cId w = lookupComponents cId w Map.!? e +{-# INLINE lookupComponent #-} + +-- | Lookup all components by their `ComponentID`. +lookupComponents :: forall m a. (Component m a) => ComponentID -> Archetype m -> Map EntityID a +lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of + Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) (V.toList as) + Nothing -> Map.empty +{-# INLINE lookupComponents #-} + +-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. +lookupComponentsAsc :: forall m a. (Component m a) => ComponentID -> Archetype m -> Vector a +lookupComponentsAsc cId = fromMaybe V.empty . lookupComponentsAscMaybe @m @a cId +{-# INLINE lookupComponentsAsc #-} + +-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. +lookupComponentsAscMaybe :: forall m a. (Component m a) => ComponentID -> Archetype m -> Maybe (Vector a) +lookupComponentsAscMaybe cId arch = S.toAscVector @a @(StorageT a) <$> lookupStorage @m @a cId arch +{-# INLINE lookupComponentsAscMaybe #-} + +-- | Insert a component into the archetype. +insertComponent :: + forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> (Archetype m, Access m ()) +insertComponent e cId c arch = + let oldComponents = lookupComponents @m @a cId arch + oldValue = oldComponents Map.!? e + !storage = + S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ oldComponents + hook = case oldValue of + Just old -> do + componentOnChange e old c + triggerEntityEvent e (OnChange old c) + Nothing -> do + componentOnInsert e c + triggerEntityEvent e (OnInsert c) + in (arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}, hook) + +-- | Insert a component into an archetype without running lifecycle hooks. +insertComponentUntracked :: + forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> Archetype m +insertComponentUntracked e cId c arch = + let !storage = + S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch + in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)} + +-- | @True@ if this archetype contains an entity with the provided `ComponentID`. +member :: ComponentID -> Archetype m -> Bool +member cId = IntMap.member (unComponentId cId) . storages + +-- | Zip a vector of components with a function and a component storage. +-- Returns the result vector, updated archetype, and the onChange hooks to run. +zipWith :: + forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Vector c, Archetype m, Access m ()) +zipWith as f cId arch = + let oldCs = lookupComponentsAsc @m @c cId arch + go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + let !(cs', s') = S.zipWith @c @(StorageT c) f as s + tell cs' + return $ Just $ dyn {storageDyn = toDyn s'} + Nothing -> return maybeDyn + Nothing -> return Nothing + (storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs) + in (cs, arch {storages = storages'}, hooks) +{-# INLINE zipWith #-} + +-- | Zip a vector of components with a monadic function and a component storage. +-- Returns the result vector, updated archetype, and the onChange hooks to run. +zipWithM :: + forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> m c) -> ComponentID -> Archetype m -> m (Vector c, Archetype m, Access m ()) +zipWithM as f cId arch = do + let oldCs = lookupComponentsAsc @m @c cId arch + go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> + WriterT $ + fmap + (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs)) + (S.zipWithM @c @(StorageT c) f as s) + Nothing -> pure maybeDyn + Nothing -> pure Nothing + res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch + let cs = snd res + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs) + return (cs, arch {storages = fst res}, hooks) + +-- | Zip a vector of components with a function and a component storage. +-- Returns the updated archetype and the onChange hooks to run. +zipWith_ :: + forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Archetype m, Access m ()) +zipWith_ as f cId arch = + let oldCs = lookupComponentsAsc @m @c cId arch + maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> + let !(cs, s') = S.zipWith @c @(StorageT c) f as s in Just (cs, dyn {storageDyn = toDyn s'}) + Nothing -> Nothing + Nothing -> Nothing + in case maybeStorage of + Just (cs, s) -> + let eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs) + in (empty {storages = IntMap.singleton (unComponentId cId) s}, hooks) + Nothing -> (empty {storages = IntMap.empty}, return ()) +{-# INLINE zipWith_ #-} + +-- | Zip a vector of components with a function returning a tuple. +zipWithAccum :: + forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> (o, c)) -> ComponentID -> Archetype m -> (Vector (o, c), Archetype m, Access m ()) +zipWithAccum as f cId arch = + let oldCs = lookupComponentsAsc @m @c cId arch + go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> do + let !(pairs', s') = S.zipWithAccum @c @(StorageT c) f as s + tell pairs' + return $ Just $ dyn {storageDyn = toDyn s'} + Nothing -> return maybeDyn + Nothing -> return Nothing + (storages', pairs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs pairs) + in (pairs, arch {storages = storages'}, hooks) +{-# INLINE zipWithAccum #-} + +-- | Zip a vector of components with a monadic function returning a tuple. +zipWithAccumM :: + forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> m (o, c)) -> ComponentID -> Archetype m -> m (Vector (o, c), Archetype m, Access m ()) +zipWithAccumM as f cId arch = do + let oldCs = lookupComponentsAsc @m @c cId arch + go maybeDyn = case maybeDyn of + Just dyn -> case fromDynamic $ storageDyn dyn of + Just s -> + WriterT $ + fmap + (\(pairs, s') -> (Just dyn {storageDyn = toDyn s'}, pairs)) + (S.zipWithAccumM @c @(StorageT c) f as s) + Nothing -> pure maybeDyn + Nothing -> pure Nothing + res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch + let pairs = snd res + eIds = V.fromList . Set.toList $ entities arch + hooks = V.foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs pairs) + return (pairs, arch {storages = fst res}, hooks) +{-# INLINE zipWithAccumM #-} + +-- | Insert a vector of components into the archetype, sorted in ascending order by their `EntityID`. +insertAscVector :: forall m a. (Component m a) => ComponentID -> Vector a -> Archetype m -> Archetype m +insertAscVector cId as arch = + let !storage = dynStorage @a $ S.fromAscVector @a @(StorageT a) as + in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch} +{-# INLINE insertAscVector #-} + +-- | Remove an entity from an archetype, returning its components. +remove :: EntityID -> Archetype m -> (IntMap Dynamic, Archetype m) +remove e arch = + let go (dynAcc, archAcc) (cId, dynS) = + let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS + !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs + dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS + !dynAcc' = case dynA of + Just d -> IntMap.insert cId d dynAcc + Nothing -> dynAcc + in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc}) + arch' = arch {entities = Set.delete e $ entities arch} + in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch' + +-- | Remove an entity from an archetype, returning its component storages. +removeStorages :: EntityID -> Archetype m -> (IntMap DynamicStorage, Archetype m) +removeStorages e arch = + let go (dynAcc, archAcc) (cId, dynS) = + let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS + !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs + dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS + !dynAcc' = case dynA of + Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc + Nothing -> dynAcc + in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc}) + arch' = arch {entities = Set.delete e $ entities arch} + in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch' + +-- | Insert a map of component storages and their `EntityID` into the archetype. +insertComponents :: EntityID -> IntMap Dynamic -> Archetype m -> Archetype m +insertComponents e cs arch = + let f archAcc (itemCId, dyn) = + let storages' = IntMap.adjust go itemCId (storages archAcc) + es = Set.toList $ entities archAcc + go s = + let ecs = V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip es . V.toList $ toAscVectorDyn s + in fromAscVectorDyn ecs s + in archAcc {storages = storages', entities = Set.insert e $ entities archAcc} + in foldl' f arch (IntMap.toList cs)
+ src/Aztecs/ECS/World/Archetype/Internal.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- Module : Aztecs.ECS.World.Archetype.Internal +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Archetype.Internal (Archetype (..), empty) where + +import Aztecs.ECS.Entity (EntityID) +import Aztecs.ECS.World.Storage.Dynamic (DynamicStorage) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Kind (Type) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics + +-- | Archetype of entities and components. +-- An archetype is guranteed to contain one of each stored component per entity. +data Archetype (m :: Type -> Type) = Archetype + { -- | Component storages. + storages :: !(IntMap DynamicStorage), + -- | Entities stored in this archetype. + entities :: !(Set EntityID) + } + deriving (Show, Generic) + +instance Semigroup (Archetype m) where + a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b} + +instance Monoid (Archetype m) where + mempty = empty + +-- | Empty archetype. +empty :: Archetype m +empty = Archetype {storages = IntMap.empty, entities = Set.empty}
src/Aztecs/ECS/World/Archetypes.hs view
@@ -1,254 +1,204 @@-{-# 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,- map,- 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.9-findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID-findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of- (aId : aIds') -> foldl' Set.intersection aId aIds'- [] -> Set.empty---- | Lookup `Archetype`s containing a set of `ComponentID`s.------ @since 0.9-find :: Set ComponentID -> Archetypes -> Map ArchetypeID Node-find cIds arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds cIds arches)---- | Map over `Archetype`s containing a set of `ComponentID`s.------ @since 0.9-map :: Set ComponentID -> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes)-map cIds f arches =- let go (acc, archAcc) aId =- let !node = nodes archAcc Map.! aId- !(a, arch') = f (nodeArchetype node)- nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc)- in (a : acc, archAcc {nodes = nodes'})- in foldl' go ([], arches) $ findArchetypeIds cIds arches---- | Lookup an `ArchetypeID` by its set of `ComponentID`s.------ @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 ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Aztecs.ECS.World.Archetypes +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Archetypes + ( ArchetypeID (..), + Node (..), + Archetypes (..), + empty, + insertArchetype, + lookupArchetypeId, + findArchetypeIds, + lookup, + find, + map, + adjustArchetype, + insert, + remove, + ) +where + +import Aztecs.ECS.Access.Internal +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import Aztecs.ECS.Event +import Aztecs.ECS.World.Archetype (Archetype (..)) +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Archetypes.Internal +import Aztecs.ECS.World.Bundle.Dynamic +import Aztecs.ECS.World.Storage.Dynamic +import Data.Dynamic +import Data.Foldable hiding (find) +import qualified Data.IntMap.Strict as IntMap +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector as V +import Prelude hiding (all, lookup, map) + +-- | Empty `Archetypes`. +empty :: Archetypes m +empty = + Archetypes + { nodes = mempty, + archetypeIds = mempty, + nextArchetypeId = ArchetypeID 0, + componentIds = mempty + } + +-- | Insert an archetype by its set of `ComponentID`s. +insertArchetype :: Set ComponentID -> Node m -> Archetypes m -> (ArchetypeID, Archetypes m) +insertArchetype cIds n arches = + let aId = nextArchetypeId arches + in ( aId, + arches + { nodes = Map.insert aId n (nodes arches), + archetypeIds = Map.insert cIds aId (archetypeIds arches), + nextArchetypeId = ArchetypeID (unArchetypeId aId + 1), + componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches) + } + ) + +-- | Adjust an `Archetype` by its `ArchetypeID`. +adjustArchetype :: ArchetypeID -> (Archetype m -> Archetype m) -> Archetypes m -> Archetypes m +adjustArchetype aId f arches = + arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)} + +-- | Find `ArchetypeID`s containing a set of `ComponentID`s. +findArchetypeIds :: Set ComponentID -> Archetypes m -> Set ArchetypeID +findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of + (aId : aIds') -> foldl' Set.intersection aId aIds' + [] -> Set.empty + +-- | Lookup `Archetype`s containing a set of `ComponentID`s. +find :: Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m) +find cIds arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds cIds arches) + +-- | Map over `Archetype`s containing a set of `ComponentID`s. +map :: Set ComponentID -> (Archetype m -> (a, Archetype m)) -> Archetypes m -> ([a], Archetypes m) +map cIds f arches = + let go (acc, archAcc) aId = + let !node = nodes archAcc Map.! aId + !(a, arch') = f (nodeArchetype node) + nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc) + in (a : acc, archAcc {nodes = nodes'}) + in foldl' go ([], arches) $ findArchetypeIds cIds arches + +-- | Lookup an `ArchetypeID` by its set of `ComponentID`s. +lookupArchetypeId :: Set ComponentID -> Archetypes m -> Maybe ArchetypeID +lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches) + +-- | Lookup an `Archetype` by its `ArchetypeID`. +lookup :: ArchetypeID -> Archetypes m -> Maybe (Node m) +lookup aId arches = Map.lookup aId (nodes arches) + +-- | Insert a component into an entity with its `ComponentID`. +insert :: + (Monad m) => + EntityID -> + ArchetypeID -> + Set ComponentID -> + DynamicBundle m -> + Archetypes m -> + (Maybe ArchetypeID, Archetypes m, Access m ()) +insert e aId cIds b arches = case lookup aId arches of + Just node -> + if Set.isSubsetOf cIds $ nodeComponentIds node + then + let go n = + let (arch', hook) = runDynamicBundle b e $ nodeArchetype n + in (n {nodeArchetype = arch'}, hook) + (hooks, nodes') = + Map.alterF + ( \maybeN -> case maybeN of + Just n -> let (n', hook) = go n in (hook, Just n') + Nothing -> (return (), Nothing) + ) + aId + $ nodes arches + in (Nothing, arches {nodes = nodes'}, hooks) + else + let cIds' = cIds <> nodeComponentIds node + in case lookupArchetypeId cIds' arches of + Just nextAId -> + let !(cs, arch) = A.remove e $ nodeArchetype node + node' = node {nodeArchetype = arch} + !nodes' = Map.insert aId node' $ nodes arches + adjustNode nextNode = + let nextArch = nodeArchetype nextNode + nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch} + !nextArch'' = A.insertComponents e cs nextArch' + (finalArch, hook) = runDynamicBundle b e nextArch'' + in (nextNode {nodeArchetype = finalArch}, hook) + (hooks, nodes'') = + Map.alterF + ( \maybeN -> case maybeN of + Just n -> let (n', hook) = adjustNode n in (hook, Just n') + Nothing -> (return (), Nothing) + ) + nextAId + nodes' + in (Just nextAId, arches {nodes = nodes''}, hooks) + Nothing -> + let !(s, arch) = A.removeStorages e $ nodeArchetype node + nodes' = Map.insert aId node {nodeArchetype = arch} $ nodes arches + (nextArch, hook) = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e} + !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch} + !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'} + in (Just nextAId, arches', hook) + Nothing -> (Nothing, arches, return ()) + +-- | Remove a component from an entity with its `ComponentID`. +remove :: + (Component m a) => + EntityID -> + ArchetypeID -> + ComponentID -> + Archetypes m -> + (Maybe (a, ArchetypeID), Archetypes m, Access m ()) +remove e aId cId arches = case lookup aId arches of + Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of + Just nextAId -> + let !(cs, arch') = A.remove e (nodeArchetype node) + !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)} + (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs + go' archAcc (itemCId, dyn) = + let adjustStorage s = fromAscVectorDyn (V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) . V.toList $ toAscVectorDyn s) s + in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)} + go nextNode = + nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')} + maybeA = a >>= fromDynamic + hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA + in ( (,nextAId) <$> maybeA, + arches' {nodes = Map.adjust go nextAId (nodes arches')}, + hook + ) + Nothing -> + let !(cs, arch') = A.removeStorages e (nodeArchetype node) + (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs + destCIds = Set.delete cId (nodeComponentIds node) + !n = + Node + { nodeComponentIds = destCIds, + nodeArchetype = Archetype {storages = cs', entities = Set.singleton e} + } + !(nextAId, arches') = insertArchetype destCIds n arches + node' = node {nodeArchetype = arch'} + maybeA = a >>= (\dynS -> V.headM (toAscVectorDyn dynS) >>= fromDynamic) + hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA + in ( (,nextAId) <$> maybeA, + arches' {nodes = Map.insert aId node' (nodes arches')}, + hook + ) + Nothing -> (Nothing, arches, return ())
+ src/Aztecs/ECS/World/Archetypes/Internal.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}++-- |+-- Module : Aztecs.ECS.World.Archetypes.Internal+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Archetypes.Internal+ ( ArchetypeID (..),+ Node (..),+ Archetypes (..),+ )+where++import Aztecs.ECS.Component.Internal (ComponentID)+import Aztecs.ECS.World.Archetype.Internal (Archetype)+import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Set (Set)+import GHC.Generics++-- | `Archetype` ID.+newtype ArchetypeID = ArchetypeID+ { -- | Unique integer identifier.+ unArchetypeId :: Int+ }+ deriving newtype (Eq, Ord, Show)++-- | Node in `Archetypes`.+data Node (m :: Type -> Type) = Node+ { -- | Unique set of `ComponentID`s of this `Node`.+ nodeComponentIds :: !(Set ComponentID),+ -- | `Archetype` of this `Node`.+ nodeArchetype :: !(Archetype m)+ }+ deriving (Show, Generic)++-- | `Archetype` map.+data Archetypes (m :: Type -> Type) = Archetypes+ { -- | Archetype nodes in the map.+ nodes :: !(Map ArchetypeID (Node m)),+ -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.+ archetypeIds :: !(Map (Set ComponentID) ArchetypeID),+ -- | Next unique `ArchetypeID`.+ nextArchetypeId :: !ArchetypeID,+ -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.+ componentIds :: !(Map ComponentID (Set ArchetypeID))+ }+ deriving (Show, Generic)
src/Aztecs/ECS/World/Bundle.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -16,59 +18,60 @@ -- Stability : provisional -- Portability : non-portable (GHC extensions) module Aztecs.ECS.World.Bundle- ( Bundle (..),- MonoidBundle (..),+ ( BundleT (..),+ Bundle, MonoidDynamicBundle (..),+ bundle,+ bundleUntracked, runBundle, ) where +import Aztecs.ECS.Access.Internal (Access) import Aztecs.ECS.Component import Aztecs.ECS.Entity import Aztecs.ECS.World.Archetype-import Aztecs.ECS.World.Bundle.Class import Aztecs.ECS.World.Bundle.Dynamic import Aztecs.ECS.World.Components import qualified Aztecs.ECS.World.Components as CS+import Control.Monad.Identity import Data.Set (Set) import qualified Data.Set as Set -- | Bundle of components.------ @since 0.9-newtype Bundle = Bundle+newtype BundleT m = BundleT { -- | Unwrap the bundle.- --- -- @since 0.9- unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)+ unBundle :: Components -> (Set ComponentID, Components, DynamicBundle m) } --- | @since 0.9-instance Monoid Bundle where- mempty = Bundle (Set.empty,,mempty)+-- | Pure bundle of components.+type Bundle = BundleT Identity --- | @since 0.9-instance Semigroup Bundle where- Bundle b1 <> Bundle b2 = Bundle $ \cs ->+instance (Monad m) => Monoid (BundleT m) where+ mempty = BundleT (Set.empty,,mempty)++instance (Monad m) => Semigroup (BundleT m) where+ BundleT b1 <> BundleT b2 = BundleT $ \cs -> let (cIds1, cs', d1) = b1 cs (cIds2, cs'', d2) = b2 cs' in (cIds1 <> cIds2, cs'', d1 <> d2) --- | @since 0.9-instance MonoidBundle Bundle where- bundle :: forall a. (Component a) => a -> Bundle- bundle a = Bundle $ \cs ->- let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', dynBundle cId a)+bundle :: forall m a. (Component m a) => a -> BundleT m+bundle a = BundleT $ \cs ->+ let (cId, cs') = CS.insert @a @m cs in (Set.singleton cId, cs', dynBundle @m cId a) --- | @since 0.9-instance MonoidDynamicBundle Bundle where- dynBundle cId c = Bundle (Set.singleton cId,,dynBundle cId c)+-- | Create a bundle that inserts without running lifecycle hooks.+bundleUntracked :: forall m a. (Component m a) => a -> BundleT m+bundleUntracked a = BundleT $ \cs ->+ let (cId, cs') = CS.insert @a @m cs in (Set.singleton cId, cs', dynBundleUntracked @m cId a) +instance (Monad m) => MonoidDynamicBundle m (BundleT m) where+ dynBundle cId c = BundleT (Set.singleton cId,,dynBundle @m cId c)+ dynBundleUntracked cId c = BundleT (Set.singleton cId,,dynBundleUntracked @m cId c)+ -- | Insert a bundle of components into an archetype.------ @since 0.9-runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype)+runBundle :: (Monad m) => BundleT m -> Components -> EntityID -> Archetype m -> (Components, Archetype m, Access m ()) runBundle b cs eId arch = let !(_, cs', d) = unBundle b cs- !arch' = runDynamicBundle d eId arch- in (cs', arch')+ !(arch', hook) = runDynamicBundle d eId arch+ in (cs', arch', hook)
− src/Aztecs/ECS/World/Bundle/Class.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---- |--- Module : Aztecs.ECS.World.Bundle.Class--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Bundle.Class (MonoidBundle (..)) where--import Aztecs.ECS.Component---- | Monoid bundle of components.------ @since 0.9-class (Monoid a) => MonoidBundle a where- -- | Add a component to the bundle.- --- -- @since 0.9- bundle :: forall c. (Component c) => c -> a
src/Aztecs/ECS/World/Bundle/Dynamic.hs view
@@ -1,30 +1,39 @@--- |--- Module : Aztecs.ECS.World.Bundle.Dynamic--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), MonoidDynamicBundle (..)) where--import Aztecs.ECS.Entity-import Aztecs.ECS.World.Archetype-import Aztecs.ECS.World.Bundle.Dynamic.Class---- | Dynamic bundle of components.------ @since 0.9-newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}---- | @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.9-instance MonoidDynamicBundle DynamicBundle where- dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Aztecs.ECS.World.Bundle.Dynamic +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), MonoidDynamicBundle (..)) where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Archetype +import Aztecs.ECS.World.Bundle.Dynamic.Class + +-- | Dynamic bundle of components. +newtype DynamicBundle m = DynamicBundle + { -- | Insert components into an archetype. + runDynamicBundle :: EntityID -> Archetype m -> (Archetype m, Access m ()) + } + +instance (Monad m) => Semigroup (DynamicBundle m) where + DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle go + where + go eId arch = + let (arch', hook1) = d1 eId arch + (arch'', hook2) = d2 eId arch' + in (arch'', hook1 >> hook2) + +instance (Monad m) => Monoid (DynamicBundle m) where + mempty = DynamicBundle (\_ arch -> (arch, return ())) + +instance (Monad m) => MonoidDynamicBundle m (DynamicBundle m) where + dynBundle cId a = DynamicBundle (\eId arch -> insertComponent eId cId a arch) + dynBundleUntracked cId a = DynamicBundle (\eId arch -> (insertComponentUntracked eId cId a arch, return ()))
src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ -- | -- Module : Aztecs.ECS.World.Bundle.Dynamic.Class -- Copyright : (c) Matt Hunzinger, 2025@@ -11,10 +15,9 @@ import Aztecs.ECS.Component -- | Monoid bundle of dynamic components.------ @since 0.9-class MonoidDynamicBundle a where+class MonoidDynamicBundle m a where -- | Add a component to the bundle by its `ComponentID`.- --- -- @since 0.9- dynBundle :: (Component c) => ComponentID -> c -> a+ dynBundle :: (Component m c) => ComponentID -> c -> a++ -- | Add a component to the bundle by its `ComponentID` without running lifecycle hooks.+ dynBundleUntracked :: (Component m c) => ComponentID -> c -> a
src/Aztecs/ECS/World/Components.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -24,31 +22,12 @@ where import Aztecs.ECS.Component-import Control.DeepSeq-import Data.Map.Strict (Map)+import Aztecs.ECS.World.Components.Internal (Components (..)) import qualified Data.Map.Strict as Map import Data.Typeable-import GHC.Generics import Prelude hiding (lookup) --- | Component ID map.------ @since 0.9-data Components = Components- { -- | Map of component types to identifiers.- --- -- @since 0.9- componentIds :: !(Map TypeRep ComponentID),- -- | Next unique component identifier.- --- -- @since 0.9- nextComponentId :: !ComponentID- }- deriving (Show, Generic, NFData)- -- | Empty `Components`.------ @since 0.9 empty :: Components empty = Components@@ -57,23 +36,17 @@ } -- | Lookup a component ID by type.------ @since 0.9 lookup :: forall a. (Typeable a) => Components -> Maybe ComponentID lookup cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs) -- | Insert a component ID by type, if it does not already exist.------ @since 0.9-insert :: forall a. (Component a) => Components -> (ComponentID, Components)+insert :: forall a m. (Component m a) => Components -> (ComponentID, Components) insert cs = case lookup @a cs of Just cId -> (cId, cs)- Nothing -> insert' @a cs+ Nothing -> insert' @a @m cs -- | Insert a component ID by type.------ @since 0.9-insert' :: forall c. (Component c) => Components -> (ComponentID, Components)+insert' :: forall c m. (Component m c) => Components -> (ComponentID, Components) insert' cs = let !cId = nextComponentId cs in ( cId,
+ src/Aztecs/ECS/World/Components/Internal.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module : Aztecs.ECS.World.Components.Internal+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Components.Internal (Components (..)) where++import Aztecs.ECS.Component.Internal+import Data.Map.Strict (Map)+import Data.Typeable+import GHC.Generics++-- | Component ID map.+data Components = Components+ { -- | Map of component types to identifiers.+ componentIds :: !(Map TypeRep ComponentID),+ -- | Next unique component identifier.+ nextComponentId :: !ComponentID+ }+ deriving (Show, Generic)
src/Aztecs/ECS/World/Entities.hs view
@@ -1,206 +1,187 @@-{-# 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 ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.ECS.World.Entities +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Entities + ( Entities (..), + empty, + spawn, + spawnWithArchetypeId, + insert, + insertDyn, + insertUntracked, + lookup, + remove, + removeWithId, + despawn, + ) +where + +import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Component +import Aztecs.ECS.Entity +import qualified Aztecs.ECS.World.Archetype as A +import Aztecs.ECS.World.Archetypes (ArchetypeID, Node (..)) +import qualified Aztecs.ECS.World.Archetypes as AS +import Aztecs.ECS.World.Bundle +import Aztecs.ECS.World.Bundle.Dynamic +import qualified Aztecs.ECS.World.Components as CS +import Aztecs.ECS.World.Entities.Internal (Entities (..)) +import Data.Dynamic +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (lookup) + +-- | Empty `World`. +empty :: Entities m +empty = + Entities + { archetypes = AS.empty, + components = CS.empty, + entities = mempty + } + +-- | Spawn a `Bundle`. Returns the updated entities and the onInsert hook to run. +spawn :: (Monad m) => EntityID -> BundleT m -> Entities m -> (Entities m, Access m ()) +spawn eId b w = + let (cIds, components', dynB) = unBundle b (components w) + in case AS.lookupArchetypeId cIds (archetypes w) of + Just aId -> case AS.lookup aId $ archetypes w of + Just node -> + let (arch', hook) = + runDynamicBundle + dynB + eId + ( (nodeArchetype node) + { A.entities = Set.insert eId . A.entities $ nodeArchetype node + } + ) + in ( w + { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, + components = components', + entities = Map.insert eId aId (entities w) + }, + hook + ) + Nothing -> (w, return ()) + Nothing -> + let (arch', hook) = runDynamicBundle dynB eId $ A.singleton eId + node' = Node {nodeComponentIds = cIds, nodeArchetype = arch'} + (aId, arches) = AS.insertArchetype cIds node' $ archetypes w + in ( w + { archetypes = arches, + entities = Map.insert eId aId (entities w), + components = components' + }, + hook + ) + +-- | Spawn a `DynamicBundle` with a specified `ArchetypeID`. Returns the updated entities and the onInsert hook. +spawnWithArchetypeId :: + (Monad m) => + EntityID -> + ArchetypeID -> + DynamicBundle m -> + Entities m -> + (Entities m, Access m ()) +spawnWithArchetypeId e aId b w = + let f n = + let (arch', hook) = runDynamicBundle b e ((nodeArchetype n) {A.entities = Set.insert e . A.entities $ nodeArchetype n}) + in (n {nodeArchetype = arch'}, hook) + (hooks, nodes') = + Map.alterF + ( \maybeN -> case maybeN of + Just n -> let (n', hook) = f n in (hook, Just n') + Nothing -> (return (), Nothing) + ) + aId + (AS.nodes $ archetypes w) + in ( w + { archetypes = (archetypes w) {AS.nodes = nodes'}, + entities = Map.insert e aId (entities w) + }, + hooks + ) + +-- | Insert a component into an entity. Returns the updated entities and the onInsert hook. +insert :: (Monad m) => EntityID -> BundleT m -> Entities m -> (Entities m, Access m ()) +insert e b w = + let !(cIds, components', dynB) = unBundle b (components w) + in insertDyn e cIds dynB w {components = components'} + +-- | Insert a component into an entity with its `ComponentID`. Returns the updated entities and the onInsert hook. +insertDyn :: (Monad m) => EntityID -> Set ComponentID -> DynamicBundle m -> Entities m -> (Entities m, Access m ()) +insertDyn e cIds b w = case Map.lookup e $ entities w of + Just aId -> + let (maybeNextAId, arches, hook) = AS.insert e aId cIds b $ archetypes w + es = case maybeNextAId of + Just nextAId -> Map.insert e nextAId $ entities w + Nothing -> entities w + in (w {archetypes = arches, entities = es}, hook) + Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of + Just aId -> spawnWithArchetypeId e aId b w + Nothing -> + let (arch, hook) = runDynamicBundle b e $ A.singleton e + node = Node {nodeComponentIds = cIds, nodeArchetype = arch} + (aId, arches) = AS.insertArchetype cIds node $ archetypes w + in (w {archetypes = arches, entities = Map.insert e aId (entities w)}, hook) + +-- | Insert a component into an entity without running lifecycle hooks. +insertUntracked :: (Monad m) => EntityID -> BundleT m -> Entities m -> Entities m +insertUntracked e b w = fst $ insert e b w + +-- | Lookup a component in an entity. +lookup :: forall m a. (Component m a) => EntityID -> Entities m -> Maybe a +lookup e w = do + !cId <- CS.lookup @a $ components w + !aId <- Map.lookup e $ entities w + !node <- AS.lookup aId $ archetypes w + A.lookupComponent e cId $ nodeArchetype node + +-- | Remove a component from an entity. Returns the component (if found), updated entities, and the onRemove hook. +remove :: forall m a. (Component m a) => EntityID -> Entities m -> (Maybe a, Entities m, Access m ()) +remove e w = + let !(cId, components') = CS.insert @a @m (components w) + in removeWithId e cId w {components = components'} + +-- | Remove a component from an entity with its `ComponentID`. Returns the component (if found), updated entities, and the onRemove hook. +removeWithId :: forall m a. (Component m a) => EntityID -> ComponentID -> Entities m -> (Maybe a, Entities m, Access m ()) +removeWithId e cId w = case Map.lookup e (entities w) of + Just aId -> + let (res, as, hook) = AS.remove @m @a e aId cId $ archetypes w + (maybeA, es) = case res of + Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w)) + Nothing -> (Nothing, entities w) + in (maybeA, w {archetypes = as, entities = es}, hook) + Nothing -> (Nothing, w, return ()) + +-- | Despawn an entity, returning its components. +despawn :: EntityID -> Entities m -> (IntMap Dynamic, Entities m) +despawn e w = + let res = do + !aId <- Map.lookup e $ entities w + !node <- AS.lookup aId $ archetypes w + return (aId, node) + in case res of + Just (aId, node) -> + let !(dynAcc, arch') = A.remove e (nodeArchetype node) + in ( dynAcc, + w + { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}, + entities = Map.delete e (entities w) + } + ) + Nothing -> (IntMap.empty, w)
+ src/Aztecs/ECS/World/Entities/Internal.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module : Aztecs.ECS.World.Entities.Internal+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Entities.Internal (Entities (..)) where++import Aztecs.ECS.Entity (EntityID)+import Aztecs.ECS.World.Archetypes.Internal (ArchetypeID, Archetypes)+import Aztecs.ECS.World.Components.Internal (Components)+import Data.Map (Map)+import GHC.Generics++-- | World of entities and their components.+data Entities m = Entities+ { -- | Archetypes.+ archetypes :: !(Archetypes m),+ -- | Components.+ components :: !Components,+ -- | Entities and their archetype identifiers.+ entities :: !(Map EntityID ArchetypeID)+ }+ deriving (Show, Generic)
+ src/Aztecs/ECS/World/Internal.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module : Aztecs.ECS.World.Internal +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Aztecs.ECS.World.Internal (World (..)) where + +import Aztecs.ECS.Entity +import Aztecs.ECS.World.Entities.Internal +import Aztecs.ECS.World.Observers.Internal +import Control.Monad.State + +-- | World of entities and their components. +data World m = World + { -- | Entities and their components. + entities :: !(Entities m), + -- | Next unique entity identifier. + nextEntityId :: !EntityID, + -- | Observers for events. + observers :: !(Observers (StateT (World m) m)) + }
+ src/Aztecs/ECS/World/Observers.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module : Aztecs.ECS.World.Observers+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Observers+ ( ObserverID (..),+ Observers (..),+ EntityObservers (..),+ DynamicObserver (..),+ empty,+ insertEntityObserver,+ insertEventObserver,+ addEntityObserver,+ addGlobalObserver,+ lookupEntityObservers,+ lookupGlobalObservers,+ lookupCallback,+ removeObserver,+ )+where++import Aztecs.ECS.Entity+import Aztecs.ECS.World.Observers.Internal+import Data.Dynamic+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Typeable++-- | Empty `Observers`.+empty :: Observers m+empty =+ Observers+ { entityObservers' = mempty,+ globalObservers = mempty,+ observerCallbacks = mempty,+ nextObserverId = ObserverID 0+ }++-- | Insert an entity observer callback.+insertEntityObserver ::+ forall e m.+ (Typeable e, Monad m) =>+ (EntityID -> e -> m ()) ->+ Observers m ->+ (ObserverID, Observers m)+insertEntityObserver callback os =+ let !oId = nextObserverId os+ dynCallback eId dyn = case fromDynamic dyn of+ Just evt -> callback eId evt+ Nothing -> pure ()+ in ( oId,+ os+ { observerCallbacks = Map.insert oId (DynEntityObserver dynCallback) (observerCallbacks os),+ nextObserverId = ObserverID (unObserverId oId + 1)+ }+ )++-- | Insert an event observer callback.+insertEventObserver ::+ forall e m.+ (Typeable e, Monad m) =>+ (e -> m ()) ->+ Observers m ->+ (ObserverID, Observers m)+insertEventObserver callback os =+ let !oId = nextObserverId os+ dynCallback dyn = case fromDynamic dyn of+ Just evt -> callback evt+ Nothing -> pure ()+ in ( oId,+ os+ { observerCallbacks = Map.insert oId (DynEventObserver dynCallback) (observerCallbacks os),+ nextObserverId = ObserverID (unObserverId oId + 1)+ }+ )++-- | Add an observer to a specific entity for a given event type.+addEntityObserver :: forall m e. (Typeable e) => EntityID -> ObserverID -> Observers m -> Observers m+addEntityObserver e oId os =+ let eventTypeRep = typeOf (Proxy @e)+ updateEntityObs Nothing =+ Just $ EntityObservers {eventObservers = Map.singleton eventTypeRep (Set.singleton oId)}+ updateEntityObs (Just eo) =+ Just $ eo {eventObservers = Map.insertWith Set.union eventTypeRep (Set.singleton oId) (eventObservers eo)}+ in os {entityObservers' = Map.alter updateEntityObs e (entityObservers' os)}++-- | Add a global observer for a given event type.+addGlobalObserver :: forall m e. (Typeable e) => ObserverID -> Observers m -> Observers m+addGlobalObserver oId os =+ let eventTypeRep = typeOf (Proxy @e)+ in os {globalObservers = Map.insertWith Set.union eventTypeRep (Set.singleton oId) (globalObservers os)}++-- | Lookup all observer IDs for an entity and event type.+lookupEntityObservers :: TypeRep -> EntityID -> Observers m -> Set.Set ObserverID+lookupEntityObservers eventTypeRep e os =+ case Map.lookup e (entityObservers' os) of+ Just eo -> Map.findWithDefault Set.empty eventTypeRep (eventObservers eo)+ Nothing -> Set.empty++-- | Lookup all global observer IDs for an event type.+lookupGlobalObservers :: TypeRep -> Observers m -> Set.Set ObserverID+lookupGlobalObservers eventTypeRep os = Map.findWithDefault Set.empty eventTypeRep (globalObservers os)++-- | Lookup an observer callback by ID.+lookupCallback :: ObserverID -> Observers m -> Maybe (DynamicObserver m)+lookupCallback oId os = Map.lookup oId (observerCallbacks os)++-- | Remove an observer by ID.+removeObserver :: ObserverID -> Observers m -> Observers m+removeObserver oId os =+ os+ { observerCallbacks = Map.delete oId (observerCallbacks os),+ entityObservers' = Map.map removeFromEntity (entityObservers' os),+ globalObservers = Map.map (Set.delete oId) (globalObservers os)+ }+ where+ removeFromEntity eo = eo {eventObservers = Map.map (Set.delete oId) (eventObservers eo)}
+ src/Aztecs/ECS/World/Observers/Internal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Aztecs.ECS.World.Observers.Internal+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Observers.Internal+ ( ObserverID (..),+ Observers (..),+ EntityObservers (..),+ DynamicObserver (..),+ )+where++import Aztecs.ECS.Entity+import Data.Dynamic+import Data.Map.Strict (Map)+import Data.Set (Set)+import Data.Typeable+import GHC.Generics++-- | Observer identifier+newtype ObserverID = ObserverID+ { -- | Unique integer identifier+ unObserverId :: Int+ }+ deriving (Eq, Ord, Show, Generic)++-- | Dynamic observer callback+data DynamicObserver m+ = -- | Entity observer callback+ DynEntityObserver !(EntityID -> Dynamic -> m ())+ | -- | Event observer callback+ DynEventObserver !(Dynamic -> m ())++-- | Observers for a specific entity+newtype EntityObservers = EntityObservers {eventObservers :: Map TypeRep (Set ObserverID)}+ deriving (Show, Generic, Semigroup, Monoid)++-- | Global observer storage+data Observers m = Observers+ { entityObservers' :: !(Map EntityID EntityObservers),+ globalObservers :: !(Map TypeRep (Set ObserverID)),+ observerCallbacks :: !(Map ObserverID (DynamicObserver m)),+ nextObserverId :: !ObserverID+ }
src/Aztecs/ECS/World/Storage.hs view
@@ -11,66 +11,71 @@ -- Portability : non-portable (GHC extensions) module Aztecs.ECS.World.Storage (Storage (..)) where -import Control.DeepSeq-import qualified Control.Monad import Data.Data-import Prelude hiding (zipWith)-import qualified Prelude+import Data.Vector (Vector)+import qualified Data.Vector as V+import Prelude hiding (map, zipWith) -- | 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+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]+ -- | Vector of all components in the storage in ascending order.+ toAscVector :: s -> Vector a - -- | Convert a sorted list of components (in ascending order) into a storage.- --- -- @since 0.9- fromAscList :: [a] -> s+ -- | Convert a sorted vector of components (in ascending order) into a storage.+ fromAscVector :: Vector a -> s -- | Map a function over all components in the storage.- --- --- -- @since 0.9 map :: (a -> a) -> s -> s -- | Map a function with some input over all components in the storage.- --- -- @since 0.9- zipWith :: (i -> a -> a) -> [i] -> s -> ([a], s)+ zipWith :: (i -> a -> a) -> Vector i -> s -> (Vector a, s) -- | Map an applicative functor with some input over all components in the storage.- --- -- @since 0.9- zipWithM :: (Applicative m) => (i -> a -> m a) -> [i] -> s -> m ([a], s)+ zipWithM :: (Monad m) => (i -> a -> m a) -> Vector i -> s -> m (Vector a, s) -- | Map a function with some input over all components in the storage.- --- -- @since 0.9- zipWith_ :: (i -> a -> a) -> [i] -> s -> s+ zipWith_ :: (i -> a -> a) -> Vector i -> s -> s zipWith_ f is as = snd $ zipWith f is as --- | @since 0.9-instance (Typeable a, NFData a) => Storage a [a] where+ -- | Map a function with some input over all components, returning a tuple result and updated storage.+ zipWithAccum :: (i -> a -> (o, a)) -> Vector i -> s -> (Vector (o, a), s)++ -- | Map a monadic function with some input over all components, returning a tuple result and updated storage.+ zipWithAccumM :: (Monad m) => (i -> a -> m (o, a)) -> Vector i -> s -> m (Vector (o, a), s)++instance (Typeable a) => Storage a (Vector a) where+ singleton a = V.singleton a {-# INLINE singleton #-}- singleton a = [a]- {-# INLINE toAscList #-}- toAscList = id- {-# INLINE fromAscList #-}- fromAscList = id++ toAscVector = id+ {-# INLINE toAscVector #-}++ fromAscVector = id+ {-# INLINE fromAscVector #-}++ map = V.map {-# INLINE map #-}- map = fmap++ zipWith f is as = let as' = V.zipWith f is as in (as', as') {-# INLINE zipWith #-}- zipWith f is as = let as' = Prelude.zipWith f is as in (as', as')++ zipWith_ f is as = V.zipWith f is as {-# INLINE zipWith_ #-}- zipWith_ = Prelude.zipWith++ zipWithM f is as = (\as' -> (as', as')) <$> V.zipWithM f is as {-# INLINE zipWithM #-}- zipWithM f is as = (\as' -> (as', as')) <$> Control.Monad.zipWithM f is as++ zipWithAccum f is as =+ let pairs = V.zipWith f is as+ as' = V.map snd pairs+ in (pairs, as')+ {-# INLINE zipWithAccum #-}++ zipWithAccumM f is as = do+ pairs <- V.zipWithM f is as+ let as' = V.map snd pairs+ return (pairs, as')+ {-# INLINE zipWithAccumM #-}
src/Aztecs/ECS/World/Storage/Dynamic.hs view
@@ -1,97 +1,70 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module : Aztecs.ECS.World.Storage.Dynamic--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Storage.Dynamic- ( DynamicStorage (..),- dynStorage,- singletonDyn,- 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, + fromAscVectorDyn, + toAscVectorDyn, + ) +where + +import qualified Aztecs.ECS.World.Storage as S +import Data.Dynamic +import Data.Maybe +import Data.Vector (Vector) +import qualified Data.Vector as V + +-- | Dynamic storage of components. +data DynamicStorage = DynamicStorage + { -- | Dynamic storage. + storageDyn :: !Dynamic, + -- | Singleton storage. + singletonDyn' :: !(Dynamic -> Dynamic), + -- | Convert this storage to an ascending vector. + toAscVectorDyn' :: !(Dynamic -> Vector Dynamic), + -- | Convert from an ascending vector. + fromAscVectorDyn' :: !(Vector Dynamic -> Dynamic) + } + +instance Show DynamicStorage where + show s = "DynamicStorage " ++ show (storageDyn s) + +-- | Create a dynamic storage from a storage. +dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage +dynStorage s = + DynamicStorage + { storageDyn = toDyn s, + singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic, + toAscVectorDyn' = \d -> V.map toDyn (S.toAscVector @a @s (fromMaybe (error "TODO") $ fromDynamic d)), + fromAscVectorDyn' = toDyn . S.fromAscVector @a @s . V.map (fromMaybe (error "TODO") . fromDynamic) + } +{-# INLINE dynStorage #-} + +-- | Singleton dynamic storage. +singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage +singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} + +-- | Convert from an ascending vector. +fromAscVectorDyn :: Vector Dynamic -> DynamicStorage -> DynamicStorage +fromAscVectorDyn dyns s = s {storageDyn = fromAscVectorDyn' s dyns} + +-- | Convert this storage to an ascending vector. +toAscVectorDyn :: DynamicStorage -> Vector Dynamic +toAscVectorDyn = toAscVectorDyn' <*> storageDyn
src/Aztecs/Hierarchy.hs view
@@ -1,255 +1,184 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module : Aztecs.Asset.AssetServer--- Copyright : (c) Matt Hunzinger, 2025--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : matt@hunzinger.me--- Stability : provisional--- Portability : non-portable (GHC extensions)------ Hierarchical relationships.--- A `Children` component forms a one-to-many relationship with `Parent` components.-module Aztecs.Hierarchy- ( Parent (..),- Children (..),- update,- Hierarchy (..),- toList,- foldWithKey,- mapWithKey,- mapWithAccum,- hierarchy,- hierarchies,- ParentState (..),- ChildState (..),- )-where--import Aztecs.ECS-import qualified Aztecs.ECS.Access as A-import qualified Aztecs.ECS.Query as Q-import qualified Aztecs.ECS.System as S-import Control.DeepSeq-import Control.Monad-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics---- | Parent component.------ @since 0.9-newtype Parent = Parent- { -- | Parent entity ID.- --- -- @since 0.9- unParent :: EntityID- }- deriving (Eq, Ord, Show, Generic, NFData)---- | @since 0.9-instance Component Parent---- | Parent internal state component.------ @since 0.9-newtype ParentState = ParentState {unParentState :: EntityID}- deriving (Show, Generic, NFData)---- | @since 0.9-instance Component ParentState---- | Children component.------ @since 0.9-newtype Children = Children {unChildren :: Set EntityID}- deriving (Eq, Ord, Show, Semigroup, Monoid, Generic, NFData)---- | @since 0.9-instance Component Children---- | Child internal state component.-newtype ChildState = ChildState {unChildState :: Set EntityID}- deriving (Show, Generic, NFData)---- | @since 0.9-instance Component ChildState---- | Update the parent-child relationships.------ @since 0.9-update ::- ( Applicative qr,- QueryReaderF qr,- DynamicQueryReaderF qr,- MonadReaderSystem qr s,- MonadAccess b m- ) =>- s (m ())-update = do- parents <- S.all $ do- entity <- Q.entity- parent <- Q.fetch- maybeParentState <- Q.fetchMaybe @_ @ParentState- return (entity, unParent parent, maybeParentState)-- children <- S.all $ do- entity <- Q.entity- cs <- Q.fetch- maybeChildState <- Q.fetchMaybe @_ @ChildState- return (entity, unChildren cs, maybeChildState)-- let go = do- mapM_- ( \(entity, parent, maybeParentState) -> case maybeParentState of- Just (ParentState parentState) -> do- when (parent /= parentState) $ do- A.insert parent . bundle $ ParentState parent-- -- Remove this entity from the previous parent's children.- maybeLastChildren <- A.lookup parentState- let lastChildren = maybe mempty unChildren maybeLastChildren- let lastChildren' = Set.filter (/= entity) lastChildren- A.insert parentState . bundle . Children $ lastChildren'-- -- Add this entity to the new parent's children.- maybeChildren <- A.lookup parent- let parentChildren = maybe mempty unChildren maybeChildren- A.insert parent . bundle . Children $ Set.insert entity parentChildren- Nothing -> do- A.spawn_ . bundle $ ParentState parent- maybeChildren <- A.lookup parent- let parentChildren = maybe mempty unChildren maybeChildren- A.insert parent . bundle . Children $ Set.insert entity parentChildren- )- parents- mapM_- ( \(entity, children', maybeChildState) -> case maybeChildState of- Just (ChildState childState) -> do- when (children' /= childState) $ do- A.insert entity . bundle $ ChildState children'- let added = Set.difference children' childState- removed = Set.difference childState children'- mapM_ (\e -> A.insert e . bundle . Parent $ entity) added- mapM_ (A.remove @_ @_ @Parent) removed- Nothing -> do- A.insert entity . bundle $ ChildState children'- mapM_ (\e -> A.insert e . bundle . Parent $ entity) children'- )- children- return go---- | Hierarchy of entities.------ @since 0.9-data Hierarchy a = Node- { -- | Entity ID.- --- -- @since 0.9- nodeEntityId :: EntityID,- -- | Entity components.- nodeEntity :: a,- -- | Child nodes.- --- -- @since 0.9- nodeChildren :: [Hierarchy a]- }- deriving (Functor)---- | @since 0.9-instance Foldable Hierarchy where- foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n)---- | @since 0.9-instance Traversable Hierarchy where- traverse f n =- Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n)---- | Convert a hierarchy to a list of entity IDs and components.------ @since 0.9-toList :: Hierarchy a -> [(EntityID, a)]-toList n = (nodeEntityId n, nodeEntity n) : concatMap toList (nodeChildren n)---- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator.------ @since 0.9-foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b-foldWithKey f n b = f (nodeEntityId n) (nodeEntity n) (foldr (foldWithKey f) b (nodeChildren n))---- | Map a hierarchy with a function that takes the entity ID and entity.------ @since 0.9-mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b-mapWithKey f n =- Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n))---- | Map a hierarchy with a function that takes the entity ID, entity, and accumulator.------ @since 0.9-mapWithAccum :: (EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c-mapWithAccum f b n = case f (nodeEntityId n) (nodeEntity n) b of- (c, b') -> Node (nodeEntityId n) c (map (mapWithAccum f b') (nodeChildren n))---- | System to read a hierarchy of parents to children with the given query.------ @since 0.9-hierarchy ::- (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) =>- EntityID ->- q a ->- s (Maybe (Hierarchy a))-hierarchy e q = do- children <- S.all $ do- entity <- Q.entity- cs <- Q.fetch- a <- q- return (entity, (unChildren cs, a))-- let childMap = Map.fromList children- return $ hierarchy' e childMap---- | Build all hierarchies of parents to children, joined with the given query.------ @since 0.9-hierarchies ::- (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) =>- q a ->- s [Hierarchy a]-hierarchies q = do- children <-- S.all- ( do- entity <- Q.entity- cs <- Q.fetch- a <- q- return (entity, (unChildren cs, a))- )-- let childMap = Map.fromList children- roots <- S.filter Q.entity $ with @Children <> without @Parent- return $ mapMaybe (`hierarchy'` childMap) roots---- | Build a hierarchy of parents to children.------ @since 0.9-hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)-hierarchy' e childMap = case Map.lookup e childMap of- Just (cs, a) ->- let bs = mapMaybe (`hierarchy'` childMap) (Set.toList cs)- in Just- Node- { nodeEntityId = e,- nodeEntity = a,- nodeChildren = bs- }- Nothing -> Nothing+{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Aztecs.Asset.AssetServer +-- Copyright : (c) Matt Hunzinger, 2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : matt@hunzinger.me +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Hierarchical relationships. +-- A `Children` component forms a one-to-many relationship with `Parent` components. +module Aztecs.Hierarchy + ( Parent (..), + Children (..), + Hierarchy (..), + toList, + foldWithKey, + mapWithKey, + mapWithAccum, + hierarchy, + hierarchies, + ) +where + +import Aztecs.ECS +import qualified Aztecs.ECS.Access as A +import qualified Aztecs.ECS.Query as Q +import qualified Aztecs.ECS.System as S +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics + +-- | Parent component. +newtype Parent = Parent + { -- | Parent entity ID. + unParent :: EntityID + } + deriving (Eq, Ord, Show, Generic) + +instance (Monad m) => Component m Parent where + componentOnInsert e (Parent parent) = do + -- Add this entity to the parent's children. + maybeChildren <- A.lookup parent + let parentChildren = maybe mempty unChildren maybeChildren + A.insertUntracked parent . bundle . Children $ Set.insert e parentChildren + + componentOnChange e (Parent oldParent) (Parent newParent) = do + -- Remove this entity from the old parent's children. + maybeOldChildren <- A.lookup oldParent + let oldChildren = maybe mempty unChildren maybeOldChildren + let oldChildren' = Set.filter (/= e) oldChildren + A.insertUntracked oldParent . bundle . Children $ oldChildren' + + -- Add this entity to the new parent's children. + maybeNewChildren <- A.lookup newParent + let newChildren = maybe mempty unChildren maybeNewChildren + A.insertUntracked newParent . bundle . Children $ Set.insert e newChildren + + componentOnRemove e (Parent parent) = do + -- Remove this entity from the parent's children. + maybeChildren <- A.lookup parent + let parentChildren = maybe mempty unChildren maybeChildren + let parentChildren' = Set.filter (/= e) parentChildren + A.insertUntracked parent . bundle . Children $ parentChildren' + +-- | Children component. +newtype Children = Children {unChildren :: Set EntityID} + deriving (Eq, Ord, Show, Semigroup, Monoid, Generic) + +instance (Monad m) => Component m Children where + componentOnInsert e (Children cs) = do + -- Set parent on all children. + mapM_ (\child -> A.insertUntracked child . bundle $ Parent e) cs + + componentOnChange e (Children oldCs) (Children newCs) = do + let added = Set.difference newCs oldCs + removed = Set.difference oldCs newCs + -- Set parent on added children. + mapM_ (\child -> A.insertUntracked child . bundle $ Parent e) added + -- Remove parent from removed children. + mapM_ (\child -> A.remove @_ @Parent child) removed + + componentOnRemove _ (Children cs) = do + -- Remove parent from all children. + mapM_ (\child -> A.remove @_ @Parent child) cs + +-- | Hierarchy of entities. +data Hierarchy a = Node + { -- | Entity ID. + nodeEntityId :: EntityID, + -- | Entity components. + nodeEntity :: a, + -- | Child nodes. + nodeChildren :: [Hierarchy a] + } + deriving (Functor) + +instance Foldable Hierarchy where + foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n) + +instance Traversable Hierarchy where + traverse f n = + Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n) + +-- | Convert a hierarchy to a vector of entity IDs and components. +toList :: Hierarchy a -> Vector (EntityID, a) +toList n = V.singleton (nodeEntityId n, nodeEntity n) <> V.concatMap toList (V.fromList $ nodeChildren n) + +-- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator. +foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b +foldWithKey f n b = f (nodeEntityId n) (nodeEntity n) (foldr (foldWithKey f) b (nodeChildren n)) + +-- | Map a hierarchy with a function that takes the entity ID and entity. +mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b +mapWithKey f n = + Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n)) + +-- | Map a hierarchy with a function that takes the entity ID, entity, and accumulator. +mapWithAccum :: (EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c +mapWithAccum f b n = case f (nodeEntityId n) (nodeEntity n) b of + (c, b') -> Node (nodeEntityId n) c (map (mapWithAccum f b') (nodeChildren n)) + +-- | System to read a hierarchy of parents to children with the given query. +hierarchy :: + (Monad m) => + EntityID -> + Query m a -> + Access m (Maybe (Hierarchy a)) +hierarchy e q = do + children <- A.system . S.readQuery $ do + e' <- Q.entity + cs <- Q.query + a <- q + return (e', (unChildren cs, a)) + let childMap = Map.fromList $ V.toList children + return $ hierarchy' e childMap + +-- | Build all hierarchies of parents to children, joined with the given query. +hierarchies :: + forall m a. + (Monad m) => + Query m a -> + Access m (Vector (Hierarchy a)) +hierarchies q = do + children <- + A.system . S.readQuery $ do + e <- Q.entity + cs <- Q.query + a <- q + return (e, (unChildren cs, a)) + + let childMap = Map.fromList $ V.toList children + roots <- A.system $ S.readQueryFiltered Q.entity (with @m @Children <> without @m @Parent) + return $ V.mapMaybe (`hierarchy'` childMap) roots + +-- | Build a hierarchy of parents to children. +hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a) +hierarchy' e childMap = case Map.lookup e childMap of + Just (cs, a) -> + let bs = mapMaybe (`hierarchy'` childMap) (Set.toList cs) + in Just + Node + { nodeEntityId = e, + nodeEntity = a, + nodeChildren = bs + } + Nothing -> Nothing
− src/Aztecs/Input.hs
@@ -1,258 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}---- |--- Module : Aztecs.Input--- 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.Input- ( Key (..),- InputMotion (..),- KeyboardInput (..),- keyboardInput,- isKeyPressed,- wasKeyPressed,- wasKeyReleased,- handleKeyboardEvent,- MouseButton (..),- MouseInput (..),- mouseInput,- handleMouseMotion,- )-where--import Aztecs.ECS-import Control.DeepSeq (NFData)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics (Generic)-import Linear (V2 (..))-import Linear.Affine (Point (..))---- | Keyboard key.------ @since 0.9-data Key- = KeyA- | KeyB- | KeyC- | KeyD- | KeyE- | KeyF- | KeyG- | KeyH- | KeyI- | KeyJ- | KeyK- | KeyL- | KeyM- | KeyN- | KeyO- | KeyP- | KeyQ- | KeyR- | KeyS- | KeyT- | KeyU- | KeyV- | KeyW- | KeyX- | KeyY- | KeyZ- | Key0- | Key1- | Key2- | Key3- | Key4- | Key5- | Key6- | Key7- | Key8- | Key9- | KeyF1- | KeyF2- | KeyF3- | KeyF4- | KeyF5- | KeyF6- | KeyF7- | KeyF8- | KeyF9- | KeyF10- | KeyF11- | KeyF12- | KeyEscape- | KeyEnter- | KeySpace- | KeyBackspace- | KeyTab- | KeyCapsLock- | KeyShift- | KeyCtrl- | KeyAlt- | KeyLeft- | KeyRight- | KeyUp- | KeyDown- | KeyHome- | KeyEnd- | KeyPageUp- | KeyPageDown- | KeyInsert- | KeyDelete- | KeyMinus- | KeyEquals- | KeyBracketLeft- | KeyBracketRight- | KeyBackslash- | KeySemicolon- | KeyComma- | KeyPeriod- | KeySlash- | KeyNumLock- | KeyNumpad0- | KeyNumpad1- | KeyNumpad2- | KeyNumpad3- | KeyNumpad4- | KeyNumpad5- | KeyNumpad6- | KeyNumpad7- | KeyNumpad8- | KeyNumpad9- | KeyNumpadDivide- | KeyNumpadMultiply- | KeyNumpadMinus- | KeyNumpadPlus- | KeyNumpadEnter- | KeyNumpadPeriod- | KeySuper- | KeyMenu- deriving (Show, Eq, Ord, Enum, Bounded, Generic, NFData)---- | Keyboard input component.------ @since 0.9-data KeyboardInput = KeyboardInput- { -- | Keyboard events that occured this frame.- --- -- @since 0.9- keyboardEvents :: !(Map Key InputMotion),- -- | Keys that are currently pressed.- --- -- @since 0.9- keyboardPressed :: !(Set Key)- }- deriving (Show, Generic, NFData)---- | @since 0.9-instance Component KeyboardInput---- | Empty keyboard input.------ @since 0.9-keyboardInput :: KeyboardInput-keyboardInput = KeyboardInput Map.empty Set.empty---- | Input motion kind.------ @since 0.9-data InputMotion = Pressed | Released- deriving (Show, Eq, Generic, NFData)---- | @True@ if this key is currently pressed.------ @since 0.9-isKeyPressed :: Key -> KeyboardInput -> Bool-isKeyPressed key kb = Set.member key $ keyboardPressed kb---- | Check for a key event that occured this frame.------ @since 0.9-keyEvent :: Key -> KeyboardInput -> Maybe InputMotion-keyEvent key kb = Map.lookup key $ keyboardEvents kb---- | @True@ if this key was pressed this frame.------ @since 0.9-wasKeyPressed :: Key -> KeyboardInput -> Bool-wasKeyPressed key kb = case keyEvent key kb of- Just Pressed -> True- _ -> False---- | @True@ if this key was released this frame.------ @since 0.9-wasKeyReleased :: Key -> KeyboardInput -> Bool-wasKeyReleased key kb = case keyEvent key kb of- Just Released -> True- _ -> False---- | Handle a keyboard event.------ @since 0.9-handleKeyboardEvent :: Key -> InputMotion -> KeyboardInput -> KeyboardInput-handleKeyboardEvent key motion kb =- KeyboardInput- { keyboardEvents = Map.insert key motion $ keyboardEvents kb,- keyboardPressed = case motion of- Pressed -> Set.insert key $ keyboardPressed kb- Released -> Set.delete key $ keyboardPressed kb- }---- | Mouse button kind.------ @since 0.9-data MouseButton- = ButtonLeft- | ButtonMiddle- | ButtonRight- | ButtonX1- | ButtonX2- | -- | An unknown mouse button.- ButtonExtra !Int- deriving (Eq, Ord, Show, Generic, NFData)---- | Mouse input component.------ @since 0.9-data MouseInput = MouseInput- { -- | Mouse position in screen-space.- --- -- @since 0.9- mousePosition :: !(Point V2 Int),- -- | Mouse offset since last frame.- --- -- @since 0.9- mouseOffset :: !(V2 Int),- -- | Mouse button states.- --- -- @since 0.9- mouseButtons :: !(Map MouseButton InputMotion)- }- deriving (Show, Generic, NFData)---- | @since 0.9-instance Component MouseInput---- | Empty mouse input.------ @since 0.9-mouseInput :: MouseInput-mouseInput = MouseInput (P 0) (V2 0 0) Map.empty---- | Handle a mouse motion event.------ @since 0.9-handleMouseMotion :: V2 Int -> MouseInput -> MouseInput-handleMouseMotion delta mouse =- mouse- { mouseOffset = delta,- mousePosition = mousePosition mouse + P delta- }
− src/Aztecs/Time.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- |--- Module : Aztecs.Time--- 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.Time (Time (..)) where--import Aztecs.ECS-import Control.DeepSeq-import Data.Word-import GHC.Generics---- | Time component.------ @since 0.9-newtype Time = Time- { -- | Elapsed time (in milliseconds).- --- -- @since 0.9- elapsedMS :: Word32- }- deriving (Eq, Ord, Num, Show, Generic, NFData)--instance Component Time
− src/Aztecs/Transform.hs
@@ -1,169 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module : Aztecs.Transform--- 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.Transform- ( -- * Transform- Transform (..),-- -- ** 2D- Transform2D,- transform2d,-- -- * Size- Size (..),-- -- ** 2D- Size2D,- size2D,-- -- * Systems- update,- update2d,- propagate,- propagate2d,- )-where--import Aztecs.ECS-import qualified Aztecs.ECS.Access as A-import qualified Aztecs.ECS.Query as Q-import Aztecs.Hierarchy (Hierarchy, hierarchies, mapWithAccum, toList)-import Control.DeepSeq-import GHC.Generics-import Linear---- | Transform component.------ @since 0.9-data Transform v r = Transform- { -- | Translation.- --- -- @since 0.9- transformTranslation :: !v,- -- | Rotation.- --- -- @since 0.9- transformRotation :: !r,- -- | Scale.- --- -- @since 0.9- transformScale :: !v- }- deriving (Eq, Show, Generic, NFData)---- | @since 0.9-instance (Num v, Num r) => Semigroup (Transform v r) where- Transform t1 r1 s1 <> Transform t2 r2 s2 = Transform (t1 + t2) (r1 + r2) (s1 + s2)---- | @since 0.9-instance (Num v, Num r) => Monoid (Transform v r) where- mempty = Transform 0 0 0---- | 2D transform component.------ @since 0.9-type Transform2D = Transform (V2 Int) Int---- | Empty transform.------ @since 0.9-transform2d :: Transform2D-transform2d = Transform (V2 0 0) 0 (V2 1 1)---- | @since 0.9-instance Component (Transform (V2 Int) Int)---- | Size component.------ @since 0.9-newtype Size v = Size {unSize :: v}- deriving (Generic, NFData)---- | @since 0.9-type Size2D = Size (V2 Int)---- | Empty size.------ @since 0.9-size2D :: Size (V2 Integer)-size2D = Size (V2 0 0)---- | @since 0.9-instance Component (Size (V2 Int))---- | Propagate a hierarchy of transform components.------ @since 0.9-propagateHierarchy :: (Component a, Monoid a) => Hierarchy a -> Hierarchy a-propagateHierarchy = mapWithAccum (\_ t acc -> let t' = t <> acc in (t', t')) mempty---- | Propagate and update all hierarchies of transform components.------ @since 0.9-update ::- forall q s b m a.- ( Applicative q,- QueryReaderF q,- DynamicQueryReaderF q,- MonadReaderSystem q s,- Component a,- Monoid a,- MonadAccess b m- ) =>- s (m ())-update = mapM_ (\(e, a) -> A.insert e $ bundle a) . concatMap toList <$> propagate @_ @_ @a---- | Propagate and update all hierarchies of transform components.------ @since 0.9-update2d ::- ( Applicative q,- QueryReaderF q,- DynamicQueryReaderF q,- MonadReaderSystem q s,- MonadAccess b m- ) =>- s (m ())-update2d = update @_ @_ @_ @_ @Transform2D---- | Propagate all hierarchies of transform components.------ @since 0.9-propagate ::- ( Applicative q,- QueryReaderF q,- DynamicQueryReaderF q,- MonadReaderSystem q s,- Component a,- Monoid a- ) =>- s [Hierarchy a]-propagate = do- hs <- hierarchies Q.fetch- return $ map propagateHierarchy hs---- | Propagate all hierarchies of `Transform2D` components.------ @since 0.9-propagate2d ::- ( Applicative q,- QueryReaderF q,- DynamicQueryReaderF q,- MonadReaderSystem q s- ) =>- s [Hierarchy Transform2D]-propagate2d = propagate
− src/Aztecs/Window.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}---- |--- Module : Aztecs.Window--- 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.Window (Window (..)) where--import Aztecs.ECS-import Control.DeepSeq-import GHC.Generics---- | Window component.------ @since 0.9-newtype Window = Window- { -- | Window title.- --- -- @since 0.9- windowTitle :: String- }- deriving (Show, Generic, NFData)---- | @since 0.9-instance Component Window
test/Main.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -13,24 +15,24 @@ import Aztecs.ECS.Component (ComponentID (ComponentID)) import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.World as W-import Control.DeepSeq import Data.Functor.Identity (Identity (runIdentity))+import qualified Data.Vector as V import Data.Word import GHC.Generics import Test.Hspec import Test.QuickCheck -newtype X = X Int deriving (Eq, Show, Arbitrary, Generic, NFData)+newtype X = X Int deriving (Eq, Show, Arbitrary, Generic) -instance Component X+instance (Monad m) => Component m X -newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic, NFData)+newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic) -instance Component Y+instance (Monad m) => Component m Y -newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic, NFData)+newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic) -instance Component Z+instance (Monad m) => Component m Z main :: IO () main = hspec $ do@@ -55,74 +57,80 @@ prop_queryEmpty :: Expectation prop_queryEmpty =- let res = fst $ Q.all (Q.fetch @_ @X) $ W.entities W.empty in res `shouldMatchList` []+ let res =+ fst+ . runIdentity+ . Q.readQuery (Q.query @_ @X)+ $ W.entities W.empty+ in V.toList res `shouldMatchList` [] -- | Query all components from a list of `ComponentID`s. queryComponentIds ::- forall q a.- (Applicative q, DynamicQueryReaderF q, Component a) =>+ forall m q a.+ (Applicative q, DynamicQueryF m q, Component m a) => [ComponentID] -> q (EntityID, [a]) queryComponentIds = let go cId qAcc = do- x' <- Q.fetchDyn @_ @a cId+ x' <- Q.queryDyn @_ @_ @a cId (e, xs) <- qAcc return (e, x' : xs) in foldr go ((,) <$> Q.entity <*> pure []) prop_queryDyn :: [[X]] -> Expectation prop_queryDyn xs =- let spawn xs' (acc, wAcc) =- let spawn' x (bAcc, cAcc, idAcc) =- ( dynBundle (ComponentID idAcc) x <> bAcc,+ let spawner :: [X] -> ([(EntityID, [(X, ComponentID)])], World Identity) -> ([(EntityID, [(X, ComponentID)])], World Identity)+ spawner xs' (acc, wAcc) =+ let spawner' x (bAcc, cAcc, idAcc) =+ ( dynBundle @Identity (ComponentID idAcc) x <> bAcc, (x, ComponentID idAcc) : cAcc, idAcc + 1 )- (b, cs, _) = foldr spawn' (mempty, [], 0) xs'- (e, wAcc') = W.spawn b wAcc+ (b, cs, _) = foldr spawner' (mempty, [], 0) xs'+ (e, wAcc', _) = W.spawn b wAcc in ((e, cs) : acc, wAcc')- (es, w) = foldr spawn ([], W.empty) xs+ (es, w) = foldr spawner ([], W.empty) xs go (e, cs) = do- let q = queryComponentIds $ map snd cs- (res, _) = Q.all q $ W.entities w- return $ res `shouldContain` [(e, map fst cs)]+ let q = queryComponentIds @Identity $ map snd cs+ (res, _) = runIdentity . Q.readQuery q $ W.entities w+ return $ V.toList res `shouldContain` [(e, map fst cs)] in mapM_ go es prop_queryTypedComponent :: [X] -> Expectation prop_queryTypedComponent xs = do- let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs- (res, _) = Q.all Q.fetch $ W.entities w- res `shouldMatchList` xs+ let w = foldr (\x -> (\(_, w', _) -> w') . W.spawn (bundle x)) W.empty xs+ (res, _) = runIdentity . Q.readQuery Q.query $ W.entities w+ V.toList res `shouldMatchList` xs prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation prop_queryTwoTypedComponents xys = do- let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys- (res, _) = Q.all ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w- res `shouldMatchList` xys+ let w = foldr (\(x, y) -> (\(_, w', _) -> w') . W.spawn (bundle x <> bundle y)) W.empty xys+ (res, _) = runIdentity $ Q.readQuery ((,) <$> Q.query <*> Q.query) $ W.entities w+ V.toList res `shouldMatchList` xys prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation prop_queryThreeTypedComponents xyzs = do- let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs+ let w = foldr (\(x, y, z) -> (\(_, w', _) -> w') . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs q = do- x <- Q.fetch- y <- Q.fetch- z <- Q.fetch+ x <- Q.query+ y <- Q.query+ z <- Q.query pure (x, y, z)- (res, _) = Q.all q $ W.entities w- res `shouldMatchList` xyzs+ (res, _) = runIdentity $ Q.readQuery q $ W.entities w+ V.toList res `shouldMatchList` xyzs prop_querySingle :: Expectation prop_querySingle =- let (_, w) = W.spawn (bundle $ X 1) W.empty- (res, _) = Q.single Q.fetch $ W.entities w+ let (_, w, _) = W.spawn (bundle $ X 1) W.empty+ (res, _) = runIdentity $ Q.readQuerySingle Q.query $ W.entities w in res `shouldBe` X 1 prop_queryMapSingle :: Word8 -> Expectation prop_queryMapSingle n =- let (_, w) = W.spawn (bundle $ X 0) W.empty- q = Q.adjust (\_ (X x) -> X $ x + 1) (pure ())- w' = foldr (\_ es -> snd . runIdentity $ Q.mapSingle q es) (W.entities w) [1 .. n]- (res, _) = Q.single Q.fetch w'+ let (_, w, _) = W.spawn (bundle $ X 0) W.empty+ q = Q.queryMap $ \(X x) -> X $ x + 1+ w' = foldr (\_ es -> (\(_, es', _) -> es') . runIdentity $ Q.runQuerySingle q es) (W.entities w) [1 .. n]+ (res, _) = runIdentity $ Q.readQuerySingle Q.query w' in res `shouldBe` X (fromIntegral n) {-TODO@@ -133,7 +141,7 @@ s = S.mapSingle q go _ wAcc = let (_, _, wAcc') = runIdentity $ runSchedule s wAcc () in wAcc' w' = foldr go w [1 .. n]- (res, _) = Q.single () Q.fetch (W.entities w')+ (res, _) = Q.single () Q.query (W.entities w') in res `shouldBe` X (fromIntegral n) prop_addParents :: Expectation@@ -141,7 +149,7 @@ let (_, w) = W.spawnEmpty W.empty (e, w') = W.spawn (bundle . Children $ Set.singleton e) w (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()- let (res, _) = Q.all () Q.fetch $ W.entities w''+ let (res, _) = Q.all () Q.query $ W.entities w'' res `shouldMatchList` [Parent e] prop_removeParents :: Expectation@@ -151,7 +159,7 @@ (_, _, w'') <- runSchedule (system Hierarchy.update) w' () let w''' = W.insert e (Children Set.empty) w'' (_, _, w'''') <- runSchedule (system Hierarchy.update) w''' ()- let (res, _) = Q.all () (Q.fetch @_ @Parent) $ W.entities w''''+ let (res, _) = Q.all () (Q.query @_ @Parent) $ W.entities w'''' res `shouldMatchList` [] -} @@ -177,7 +185,7 @@ system $ S.mapSingle ( proc () -> do- X x <- Q.fetch -< ()+ X x <- Q.query -< () Q.set -< X $ x + 1 returnA -< x )