aztecs 0.11.1 → 0.12.0

raw patch · 22 files changed

+3019/−2988 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +29/−29
• aztecs.cabal +89/−89
• bench/Bench.hs +33/−33
• examples/ECS.hs +30/−35
• src/Aztecs/ECS.hs +58/−52
• src/Aztecs/ECS/Access.hs +150/−150
• src/Aztecs/ECS/Component.hs +41/−41
• src/Aztecs/ECS/Entity.hs +26/−26
• src/Aztecs/ECS/Query.hs +270/−276
• src/Aztecs/ECS/Query/Dynamic.hs +502/−512
• src/Aztecs/ECS/System.hs +337/−216
• src/Aztecs/ECS/View.hs +127/−127
• src/Aztecs/ECS/World.hs +105/−105
• src/Aztecs/ECS/World/Archetype.hs +299/−301
• src/Aztecs/ECS/World/Archetypes.hs +245/−245
• src/Aztecs/ECS/World/Bundle.hs +69/−69
• src/Aztecs/ECS/World/Bundle/Dynamic.hs +30/−30
• src/Aztecs/ECS/World/Components.hs +84/−84
• src/Aztecs/ECS/World/Entities.hs +206/−206
• src/Aztecs/ECS/World/Storage.hs +75/−76
• src/Aztecs/ECS/World/Storage/Dynamic.hs +87/−97
• test/Main.hs +127/−189

@@ -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.

@@ -1,89 +1,89 @@-cabal-version: 2.4-name:          aztecs-version:       0.11.1-license:       BSD-3-Clause-license-file:  LICENSE-maintainer:    matt@hunzinger.me-author:        Matt Hunzinger-homepage:      https://github.com/aztecs-hs/aztecs-synopsis:-    A modular game engine and Entity-Component-System (ECS) for Haskell.--description:-    A modular game engine and Entity-Component-System (ECS) for Haskell.-    An ECS is a modern approach to organizing your application state as a database,-    providing patterns for data-oriented design and parallel processing.-    Aztecs provides side-effect free components and systems,-    as well as backends for rendering and input (such as `aztecs-sdl`),-    allowing you to structure your game as simple function of `Input -> World -> World`.--category:      Game Engine--source-repository head-    type:     git-    location: https://github.com/aztecs-hs/aztecs.git--library-    exposed-modules:-        Aztecs.ECS-        Aztecs.ECS.Access-        Aztecs.ECS.Component-        Aztecs.ECS.Entity-        Aztecs.ECS.Query-        Aztecs.ECS.Query.Dynamic-        Aztecs.ECS.System-        Aztecs.ECS.View-        Aztecs.ECS.World-        Aztecs.ECS.World.Archetype-        Aztecs.ECS.World.Archetypes-        Aztecs.ECS.World.Bundle-        Aztecs.ECS.World.Bundle.Dynamic-        Aztecs.ECS.World.Components-        Aztecs.ECS.World.Entities-        Aztecs.ECS.World.Storage-        Aztecs.ECS.World.Storage.Dynamic--    hs-source-dirs:   src-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base >=4.2 && <5,-        containers >=0.6,-        deepseq >=1,-        mtl >=2,-        stm >=2--executable ecs-    main-is:          examples/ECS.hs-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base,-        aztecs,-        deepseq >=1--test-suite aztecs-test-    type:             exitcode-stdio-1.0-    main-is:          Main.hs-    hs-source-dirs:   test-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base >=4.2 && <5,-        aztecs,-        containers >=0.6,-        deepseq >=1,-        hspec >=2,-        QuickCheck >=2--benchmark aztecs-bench-    type:             exitcode-stdio-1.0-    main-is:          Bench.hs-    hs-source-dirs:   bench-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base >=4.2 && <5,-        aztecs,-        criterion >=1,-        deepseq >=1+cabal-version: 2.4
+name:          aztecs
+version:       0.12.0
+license:       BSD-3-Clause
+license-file:  LICENSE
+maintainer:    matt@hunzinger.me
+author:        Matt Hunzinger
+homepage:      https://github.com/aztecs-hs/aztecs
+synopsis:
+    A modular game engine and Entity-Component-System (ECS) for Haskell.
+
+description:
+    A modular game engine and Entity-Component-System (ECS) for Haskell.
+    An ECS is a modern approach to organizing your application state as a database,
+    providing patterns for data-oriented design and parallel processing.
+    Aztecs provides side-effect free components and systems,
+    as well as backends for rendering and input (such as `aztecs-sdl`),
+    allowing you to structure your game as simple function of `Input -> World -> World`.
+
+category:      Game Engine
+
+source-repository head
+    type:     git
+    location: https://github.com/aztecs-hs/aztecs.git
+
+library
+    exposed-modules:
+        Aztecs.ECS
+        Aztecs.ECS.Access
+        Aztecs.ECS.Component
+        Aztecs.ECS.Entity
+        Aztecs.ECS.Query
+        Aztecs.ECS.Query.Dynamic
+        Aztecs.ECS.System
+        Aztecs.ECS.View
+        Aztecs.ECS.World
+        Aztecs.ECS.World.Archetype
+        Aztecs.ECS.World.Archetypes
+        Aztecs.ECS.World.Bundle
+        Aztecs.ECS.World.Bundle.Dynamic
+        Aztecs.ECS.World.Components
+        Aztecs.ECS.World.Entities
+        Aztecs.ECS.World.Storage
+        Aztecs.ECS.World.Storage.Dynamic
+
+    hs-source-dirs:   src
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base >=4.2 && <5,
+        containers >=0.6,
+        deepseq >=1,
+        mtl >=2,
+        stm >=2
+
+executable ecs
+    main-is:          examples/ECS.hs
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base,
+        aztecs,
+        deepseq >=1
+
+test-suite aztecs-test
+    type:             exitcode-stdio-1.0
+    main-is:          Main.hs
+    hs-source-dirs:   test
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base >=4.2 && <5,
+        aztecs,
+        containers >=0.6,
+        deepseq >=1,
+        hspec >=2,
+        QuickCheck >=2
+
+benchmark aztecs-bench
+    type:             exitcode-stdio-1.0
+    main-is:          Bench.hs
+    hs-source-dirs:   bench
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base >=4.2 && <5,
+        aztecs,
+        criterion >=1,
+        deepseq >=1

@@ -1,33 +1,33 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--import Aztecs.ECS-import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.World-import qualified Aztecs.ECS.World as W-import Control.DeepSeq-import Criterion.Main-import Data.Function-import Data.Functor.Identity-import GHC.Generics--newtype Position = Position Int deriving (Show, Generic, NFData)--instance Component Position--newtype Velocity = Velocity Int deriving (Show, Generic, NFData)--instance Component Velocity--q :: Query Position-q = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v)--run :: World -> [Position]-run = fst . runIdentity . Q.query q . entities--main :: IO ()-main = do-  let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc-      !w = foldr (const go) W.empty [0 :: Int .. 10000]-  defaultMain [bench "iter" $ nf run w]+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+import Aztecs.ECS
+import qualified Aztecs.ECS.Query as Q
+import Aztecs.ECS.World
+import qualified Aztecs.ECS.World as W
+import Control.DeepSeq
+import Criterion.Main
+import Data.Function
+import Data.Functor.Identity
+import GHC.Generics
+
+newtype Position = Position Int deriving (Show, Generic, NFData)
+
+instance Component Position
+
+newtype Velocity = Velocity Int deriving (Show, Generic, NFData)
+
+instance Component Velocity
+
+q :: Query Position
+q = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v)
+
+run :: World -> [Position]
+run = fst . runIdentity . Q.query q . entities
+
+main :: IO ()
+main = do
+  let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc
+      !w = foldr (const go) W.empty [0 :: Int .. 10000]
+  defaultMain [bench "iter" $ nf run w]

@@ -1,35 +1,30 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Main where--import Aztecs.ECS-import Control.DeepSeq-import Control.Monad-import Control.Monad.IO.Class-import Data.Function-import GHC.Generics--newtype Position = Position Int deriving (Show, Generic, NFData)--instance Component Position--newtype Velocity = Velocity Int deriving (Show, Generic, NFData)--instance Component Velocity--move :: (Monad m) => QueryT m Position-move = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v)--run :: SystemT IO ()-run = do-  positions <- query move-  liftIO $ print positions--app :: AccessT IO ()-app = do-  _ <- spawn $ bundle (Position 0) <> bundle (Velocity 1)-  forever $ system run--main :: IO ()-main = runAccessT_ app+module Main where
+
+import Aztecs.ECS
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Function
+
+newtype Position = Position Int deriving (Show)
+
+instance Component Position
+
+newtype Velocity = Velocity Int
+
+instance Component Velocity
+
+move :: Query Position
+move = fetch & zipFetchMap (\(Velocity v) (Position p) -> Position $ p + v)
+
+run :: SystemT IO ()
+run = do
+  positions <- query move
+  liftIO $ print positions
+
+app :: AccessT IO ()
+app = do
+  _ <- spawn $ bundle (Position 0) <> bundle (Velocity 1)
+  forever $ system run
+
+main :: IO ()
+main = runAccessT_ app

@@ -1,52 +1,58 @@--- | Aztecs is a type-safe and friendly ECS for games and more.------ An ECS is a modern approach to organizing your application state as a database,--- providing patterns for data-oriented design and parallel processing.------ The ECS architecture is composed of three main concepts:------ === Entities--- An entity is an object comprised of zero or more components.--- In Aztecs, entities are represented by their `EntityID`, a unique identifier.------ === Components--- A `Component` holds the data for a particular aspect of an entity.--- For example, a zombie entity might have a @Health@ and a @Transform@ component.------ > newtype Position = Position Int deriving (Show)--- > instance Component Position--- >--- > newtype Velocity = Velocity Int deriving (Show)--- > instance Component Velocity------ === Systems--- A `System` is a pipeline that processes entities and their components.-module Aztecs.ECS-  ( module Aztecs.ECS.System,-    module Aztecs.ECS.Query,-    Access,-    AccessT,-    runAccessT,-    runAccessT_,-    Bundle,-    bundle,-    fromDynBundle,-    DynamicBundle,-    dynBundle,-    Component (..),-    EntityID,-    spawn,-    system,-    concurrently,-    World,-  )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.Query hiding (query, querySingle, querySingleMaybe, readQueryEntities)-import Aztecs.ECS.System hiding (concurrently)-import Aztecs.ECS.World (World)-import Aztecs.ECS.World.Bundle-import Aztecs.ECS.World.Bundle.Dynamic+-- | Aztecs is a type-safe and friendly ECS for games and more.
+--
+-- An ECS is a modern approach to organizing your application state as a database,
+-- providing patterns for data-oriented design and parallel processing.
+--
+-- The ECS architecture is composed of three main concepts:
+--
+-- === Entities
+-- An entity is an object comprised of zero or more components.
+-- In Aztecs, entities are represented by their `EntityID`, a unique identifier.
+--
+-- === Components
+-- A `Component` holds the data for a particular aspect of an entity.
+-- For example, a zombie entity might have a @Health@ and a @Transform@ component.
+--
+-- > newtype Position = Position Int deriving (Show)
+-- > instance Component Position
+-- >
+-- > newtype Velocity = Velocity Int deriving (Show)
+-- > instance Component Velocity
+--
+-- === Systems
+-- A `System` is a pipeline that processes entities and their components.
+module Aztecs.ECS
+  ( module Aztecs.ECS.System,
+    module Aztecs.ECS.Query,
+    Access,
+    AccessT,
+    runAccessT,
+    runAccessT_,
+    Bundle,
+    bundle,
+    fromDynBundle,
+    DynamicBundle,
+    dynBundle,
+    Component (..),
+    EntityID,
+    spawn,
+    system,
+    concurrently,
+    World,
+  )
+where
+
+import Aztecs.ECS.Access
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.Query hiding
+  ( query,
+    querySingle,
+    querySingleMaybe,
+    readQuery,
+    readQueryEntities,
+  )
+import Aztecs.ECS.System hiding (concurrently)
+import Aztecs.ECS.World (World)
+import Aztecs.ECS.World.Bundle
+import Aztecs.ECS.World.Bundle.Dynamic

@@ -1,150 +1,150 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.Access--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Access-  ( Access,-    AccessT (..),-    spawn,-    insert,-    lookup,-    remove,-    despawn,-    runAccessT,-    runAccessT_,-    system,-    concurrently,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.System (SystemT (..), runSystemT)-import qualified Aztecs.ECS.System as S-import Aztecs.ECS.World (World (..))-import qualified Aztecs.ECS.World as W-import Aztecs.ECS.World.Bundle-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Monad.Fix-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State.Strict-import Prelude hiding (lookup)---- | @since 0.9-type Access = AccessT Identity---- | Access into the `World`.------ @since 0.9-newtype AccessT m a = AccessT {unAccessT :: StateT World m a}-  deriving (Functor, Applicative, MonadFix, MonadIO)---- | @since 0.9-instance (Monad m) => Monad (AccessT m) where-  a >>= f = AccessT $ do-    !w <- get-    (a', w') <- lift $ runAccessT a w-    put (rnf w' `seq` w')-    unAccessT $ f a'---- | Run an `Access` on a `World`, returning the output and updated `World`.------ @since 0.9-runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World)-runAccessT a = runStateT $ unAccessT a---- | Run an `Access` on an empty `World`.------ @since 0.9-runAccessT_ :: (Functor m) => AccessT m a -> m a-runAccessT_ a = fmap fst . runAccessT a $ W.empty---- | Spawn an entity with a `Bundle`.------ @since 0.11-spawn :: (Monad m) => Bundle -> AccessT m EntityID-spawn b = AccessT $ do-  !w <- get-  let !(e, w') = W.spawn b w-  put w'-  return e---- | Insert a `Bundle` into an entity.------ @since 0.11-insert :: (Monad m) => EntityID -> Bundle -> AccessT m ()-insert e c = AccessT $ do-  !w <- get-  let !w' = W.insert e c w-  put w'---- | Lookup a component by `EntityID`.------ @since 0.11-lookup :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a)-lookup e = AccessT $ do-  !w <- get-  return $ W.lookup e w---- | Remove a component by `EntityID`.------ @since 0.11-remove :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a)-remove e = AccessT $ do-  !w <- get-  let !(a, w') = W.remove e w-  put w'-  return a---- | Despawn an entity by `EntityID`.------ @since 0.11-despawn :: (Monad m) => EntityID -> AccessT m ()-despawn e = AccessT $ do-  !w <- get-  let !(_, w') = W.despawn e w-  put w'---- | Run a `System`.------ @since 0.11-system :: (Monad m) => SystemT m a -> AccessT m a-system s = AccessT $ do-  !w <- get-  let go f = do-        es <- get-        let es' = f es-        put es'-        return es'-  (a, es) <- lift $ runStateT (runSystemT s go) (entities w)-  put w {entities = es}-  return a---- | Run a `System` concurrently.------ @since 0.11-concurrently :: SystemT IO a -> AccessT IO a-concurrently s = AccessT $ do-  !w <- get-  esVar <- lift . newTVarIO $ entities w-  let go f = atomically $ do-        es <- readTVar esVar-        let es' = f es-        writeTVar esVar es'-        return es'-  a <- liftIO $ S.concurrently s go-  es <- lift $ readTVarIO esVar-  put w {entities = es}-  return a+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.Access
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.Access
+  ( Access,
+    AccessT (..),
+    spawn,
+    insert,
+    lookup,
+    remove,
+    despawn,
+    runAccessT,
+    runAccessT_,
+    system,
+    concurrently,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.System (SystemT (..), runSystemT)
+import qualified Aztecs.ECS.System as S
+import Aztecs.ECS.World (World (..))
+import qualified Aztecs.ECS.World as W
+import Aztecs.ECS.World.Bundle
+import Control.Concurrent.STM
+import Control.DeepSeq
+import Control.Monad.Fix
+import Control.Monad.Identity
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import Prelude hiding (lookup)
+
+-- | @since 0.9
+type Access = AccessT Identity
+
+-- | Access into the `World`.
+--
+-- @since 0.9
+newtype AccessT m a = AccessT {unAccessT :: StateT World m a}
+  deriving (Functor, Applicative, MonadFix, MonadIO)
+
+-- | @since 0.9
+instance (Monad m) => Monad (AccessT m) where
+  a >>= f = AccessT $ do
+    !w <- get
+    (a', w') <- lift $ runAccessT a w
+    put (rnf w' `seq` w')
+    unAccessT $ f a'
+
+-- | Run an `Access` on a `World`, returning the output and updated `World`.
+--
+-- @since 0.9
+runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World)
+runAccessT a = runStateT $ unAccessT a
+
+-- | Run an `Access` on an empty `World`.
+--
+-- @since 0.9
+runAccessT_ :: (Functor m) => AccessT m a -> m a
+runAccessT_ a = fmap fst . runAccessT a $ W.empty
+
+-- | Spawn an entity with a `Bundle`.
+--
+-- @since 0.11
+spawn :: (Monad m) => Bundle -> AccessT m EntityID
+spawn b = AccessT $ do
+  !w <- get
+  let !(e, w') = W.spawn b w
+  put w'
+  return e
+
+-- | Insert a `Bundle` into an entity.
+--
+-- @since 0.11
+insert :: (Monad m) => EntityID -> Bundle -> AccessT m ()
+insert e c = AccessT $ do
+  !w <- get
+  let !w' = W.insert e c w
+  put w'
+
+-- | Lookup a component by `EntityID`.
+--
+-- @since 0.11
+lookup :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a)
+lookup e = AccessT $ do
+  !w <- get
+  return $ W.lookup e w
+
+-- | Remove a component by `EntityID`.
+--
+-- @since 0.11
+remove :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a)
+remove e = AccessT $ do
+  !w <- get
+  let !(a, w') = W.remove e w
+  put w'
+  return a
+
+-- | Despawn an entity by `EntityID`.
+--
+-- @since 0.11
+despawn :: (Monad m) => EntityID -> AccessT m ()
+despawn e = AccessT $ do
+  !w <- get
+  let !(_, w') = W.despawn e w
+  put w'
+
+-- | Run a `System`.
+--
+-- @since 0.11
+system :: (Monad m) => SystemT m a -> AccessT m a
+system s = AccessT $ do
+  !w <- get
+  let go f = do
+        es <- get
+        let es' = f es
+        put es'
+        return es'
+  (a, es) <- lift $ runStateT (runSystemT s go) (entities w)
+  put w {entities = es}
+  return a
+
+-- | Run a `System` concurrently.
+--
+-- @since 0.11
+concurrently :: SystemT IO a -> AccessT IO a
+concurrently s = AccessT $ do
+  !w <- get
+  esVar <- lift . newTVarIO $ entities w
+  let go f = atomically $ do
+        es <- readTVar esVar
+        let es' = f es
+        writeTVar esVar es'
+        return es'
+  a <- liftIO $ S.concurrently s go
+  es <- lift $ readTVarIO esVar
+  put w {entities = es}
+  return a

@@ -1,41 +1,41 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.Component--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Component where--import Aztecs.ECS.World.Storage-import Control.DeepSeq-import Data.Typeable-import GHC.Generics---- | Unique component identifier.------ @since 0.9-newtype ComponentID = ComponentID-  { -- | Unique integer identifier.-    ---    -- @since 0.9-    unComponentId :: Int-  }-  deriving (Eq, Ord, Show, Generic, NFData)---- | Component that can be stored in the `World`.------ @since 0.9-class (Typeable a, Storage a (StorageT a)) => Component a where-  -- | `Storage` of this component.-  ---  -- @since 0.9-  type StorageT a--  type StorageT a = [a]+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.Component
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.Component where
+
+import Aztecs.ECS.World.Storage
+import Control.DeepSeq
+import Data.Typeable
+import GHC.Generics
+
+-- | Unique component identifier.
+--
+-- @since 0.9
+newtype ComponentID = ComponentID
+  { -- | Unique integer identifier.
+    --
+    -- @since 0.9
+    unComponentId :: Int
+  }
+  deriving (Eq, Ord, Show, Generic, NFData)
+
+-- | Component that can be stored in the `World`.
+--
+-- @since 0.9
+class (Typeable a, Storage a (StorageT a)) => Component a where
+  -- | `Storage` of this component.
+  --
+  -- @since 0.9
+  type StorageT a
+
+  type StorageT a = [a]

@@ -1,26 +1,26 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- |--- Module      : Aztecs.ECS.Entity--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Entity (EntityID (..)) where--import Control.DeepSeq-import GHC.Generics---- | Unique entity identifier.------ @since 0.9-newtype EntityID = EntityID-  { -- | Unique integer identifier.-    ---    -- @since 0.9-    unEntityId :: Int-  }-  deriving (Eq, Ord, Show, Generic, NFData)+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module      : Aztecs.ECS.Entity
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.Entity (EntityID (..)) where
+
+import Control.DeepSeq
+import GHC.Generics
+
+-- | Unique entity identifier.
+--
+-- @since 0.9
+newtype EntityID = EntityID
+  { -- | Unique integer identifier.
+    --
+    -- @since 0.9
+    unEntityId :: Int
+  }
+  deriving (Eq, Ord, Show, Generic, NFData)

@@ -1,276 +1,270 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.Query--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query-  ( -- * Queries-    Query,-    QueryT (..),--    -- ** Operations-    entity,-    fetch,-    fetchMap,-    fetchMapM,-    zipFetchMap,-    zipFetchMapAccum,-    zipFetchMapM,-    zipFetchMapAccumM,--    -- ** Filters-    with,-    without,--    -- ** Running-    query,-    readSingle,-    readSingle',-    readSingleMaybe,-    readSingleMaybe',-    querySingle,-    querySingleMaybe,-    queryEntities,-    readQueryEntities,--    -- ** Conversion-    fromDyn,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.Query.Dynamic-import Aztecs.ECS.World.Components (Components)-import qualified Aztecs.ECS.World.Components as CS-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Monad.Identity-import GHC.Stack---- | @since 0.11-type Query = QueryT Identity---- | Query for matching entities.------ @since 0.11-newtype QueryT f a = Query-  { -- | Run a query, producing a `DynamicQueryT`.-    ---    -- @since 0.11-    runQuery :: Components -> (Components, DynamicQueryT f a)-  }-  deriving (Functor)---- | @since 0.11-instance (Applicative f) => Applicative (QueryT f) where-  {-# INLINE pure #-}-  pure a = Query (,pure a)--  {-# INLINE (<*>) #-}-  (Query f) <*> (Query g) = Query $ \cs ->-    let !(cs', aQS) = g cs-        !(cs'', bQS) = f cs'-     in (cs'', bQS <*> aQS)---- | Fetch the current `EntityID`.------ @since 0.11-{-# INLINE entity #-}-entity :: QueryT f EntityID-entity = Query (,entityDyn)---- | Fetch a component.------ @since 0.11-{-# INLINE fetch #-}-fetch :: forall f a. (Component a) => QueryT f a-fetch = fromDynInternal @f @a $ fetchDyn---- | Fetch a component and map it, storing the result.------ @since 0.11-{-# INLINE fetchMap #-}-fetchMap :: forall m a. (Component a) => (a -> a) -> QueryT m a-fetchMap f = fromDynInternal @_ @a $ fetchMapDyn f---- | Fetch a component and map it with a monadic function, storing the result.------ @since 0.11-{-# INLINE fetchMapM #-}-fetchMapM :: forall m a. (Monad m, Component a) => (a -> m a) -> QueryT m a-fetchMapM f = fromDynInternal @_ @a $ fetchMapDynM f---- | Fetch a component and map it with some input, storing the result.------ @since 0.11-{-# INLINE zipFetchMap #-}-zipFetchMap :: forall m a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m a-zipFetchMap f = fromWriterInternal @a $ zipFetchMapDyn f---- | Fetch a component and map it with some input, storing the result and returning some output.------ @since 0.11-{-# INLINE zipFetchMapAccum #-}-zipFetchMapAccum ::-  forall m a b c. (Component a) => (b -> a -> (c, a)) -> QueryT m b -> QueryT m (c, a)-zipFetchMapAccum f = fromWriterInternal @a $ zipFetchMapAccumDyn f---- | Fetch a component and map it with some input and a monadic function, storing the result.------ @since 0.11-{-# INLINE zipFetchMapM #-}-zipFetchMapM :: forall m a b. (Monad m, Component a) => (b -> a -> m a) -> QueryT m b -> QueryT m a-zipFetchMapM f = fromWriterInternal @a $ zipFetchMapDynM f---- | Fetch a component and map it with some input and a monadic function,--- storing the result and returning some output.------ @since 0.11-{-# INLINE zipFetchMapAccumM #-}-zipFetchMapAccumM ::-  forall m a b c. (Monad m, Component a) => (b -> a -> m (c, a)) -> QueryT m b -> QueryT m (c, a)-zipFetchMapAccumM f = fromWriterInternal @a $ zipFetchMapAccumDynM f---- | Filter for entities with a component.------ @since 0.11-{-# INLINE with #-}-with :: forall f a. (Component a) => QueryT f ()-with = fromDynInternal @f @a $ withDyn---- | Filter for entities without a component.------ @since 0.11-{-# INLINE without #-}-without :: forall f a. (Component a) => QueryT f ()-without = fromDynInternal @f @a $ withDyn---- | Convert a `DynamicQueryT` to a `QueryT`.------ @since 0.11-{-# INLINE fromDyn #-}-fromDyn :: DynamicQueryT f a -> QueryT f a-fromDyn q = Query (,q)--{-# INLINE fromDynInternal #-}-fromDynInternal ::-  forall f a b.-  (Component a) =>-  (ComponentID -> DynamicQueryT f b) ->-  QueryT f b-fromDynInternal f = Query $ \cs ->-  let !(cId, cs') = CS.insert @a cs in (cs', f cId)--{-# INLINE fromWriterInternal #-}-fromWriterInternal ::-  forall c f a b.-  (Component c) =>-  (ComponentID -> DynamicQueryT f b -> DynamicQueryT f a) ->-  QueryT f b ->-  QueryT f a-fromWriterInternal f q = Query $ \cs ->-  let !(cId, cs') = CS.insert @c cs-      !(cs'', dynQ) = runQuery q cs'-   in (cs'', f cId dynQ)---- | Match and update all entities.------ @since 0.11-{-# INLINE query #-}-query :: (Monad m) => QueryT m a -> Entities -> m ([a], Entities)-query q es = do-  let !(cs', dynQ) = runQuery q $ components es-  (as, es') <- queryDyn dynQ es-  return (as, es' {components = cs'})---- | Match and update a single matched entity.------ @since 0.11-{-# INLINE querySingle #-}-querySingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities)-querySingle q es = do-  let !(cs', dynQ) = runQuery q $ components es-  (as, es') <- mapSingleDyn dynQ es-  return (as, es' {components = cs'})---- | Match and update a single matched entity, or `Nothing`.------ @since 0.11-{-# INLINE querySingleMaybe #-}-querySingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities)-querySingleMaybe q es = do-  let !(cs', dynQ) = runQuery q $ components es-  (as, es') <- mapSingleMaybeDyn dynQ es-  return (as, es' {components = cs'})---- | Match and update the specified entities.------ @since 0.11-queryEntities :: (Monad m) => [EntityID] -> QueryT m a -> Entities -> m ([a], Entities)-queryEntities eIds q es = do-  let !(cs', dynQ) = runQuery q $ components es-  (as, es') <- queryEntitiesDyn eIds dynQ es-  return (as, es' {components = cs'})---- | Match a single entity.------ @since 0.11-{-# INLINE readSingle #-}-readSingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities)-readSingle q es = do-  let !(cs', dynQ) = runQuery q $ components es-  as <- singleDyn dynQ es-  return (as, es {components = cs'})---- | Match a single entity.------ @since 0.11-{-# INLINE readSingle' #-}-readSingle' :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Components)-readSingle' q es = do-  let !(cs', dynQ) = runQuery q $ components es-  as <- singleDyn dynQ es-  return (as, cs')---- | Match a single entity, or `Nothing`.------ @since 0.11-{-# INLINE readSingleMaybe #-}-readSingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities)-readSingleMaybe q es = do-  let !(cs', dynQ) = runQuery q $ components es-  as <- singleMaybeDyn dynQ es-  return (as, es {components = cs'})---- | Match a single entity, or `Nothing`.------ @since 0.11-{-# INLINE readSingleMaybe' #-}-readSingleMaybe' :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Components)-readSingleMaybe' q es = do-  let !(cs', dynQ) = runQuery q $ components es-  as <- singleMaybeDyn dynQ es-  return (as, cs')---- | Match the specified entities.------ @since 0.11-readQueryEntities :: (Monad m) => [EntityID] -> QueryT m a -> Entities -> m ([a], Entities)-readQueryEntities eIds q es = do-  let !(cs', dynQ) = runQuery q $ components es-  as <- readQueryEntitiesDyn eIds dynQ es-  return (as, es {components = cs'})+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.Query
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.Query
+  ( -- * Queries
+    Query,
+    QueryT (..),
+
+    -- ** Operations
+    entity,
+    fetch,
+    fetchMaybe,
+    fetchMap,
+    fetchMapM,
+    zipFetchMap,
+    zipFetchMapAccum,
+    zipFetchMapM,
+    zipFetchMapAccumM,
+
+    -- ** Filters
+    with,
+    without,
+
+    -- ** Conversion
+    fromDyn,
+    liftQuery,
+
+    -- ** Running
+
+    -- *** Writing
+    query,
+    querySingle,
+    querySingleMaybe,
+    queryEntities,
+
+    -- *** Reading
+    readQueryEntities,
+    readQuery,
+    readQuerySingle,
+    readQuerySingleMaybe,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.Query.Dynamic
+import Aztecs.ECS.World.Components (Components)
+import qualified Aztecs.ECS.World.Components as CS
+import Aztecs.ECS.World.Entities (Entities (..))
+import Control.Monad.Identity
+import Control.Monad.Trans
+import GHC.Stack
+
+-- | @since 0.11
+type Query = QueryT Identity
+
+-- | Query for matching entities.
+--
+-- @since 0.11
+newtype QueryT f a = Query
+  { -- | Run a query, producing a `DynamicQueryT`.
+    --
+    -- @since 0.11
+    runQuery :: Components -> (Components, DynamicQueryT f a)
+  }
+  deriving (Functor)
+
+-- | @since 0.11
+instance (Applicative f) => Applicative (QueryT f) where
+  {-# INLINE pure #-}
+  pure a = Query (,pure a)
+
+  {-# INLINE (<*>) #-}
+  (Query f) <*> (Query g) = Query $ \cs ->
+    let !(cs', aQS) = g cs
+        !(cs'', bQS) = f cs'
+     in (cs'', bQS <*> aQS)
+
+-- | Fetch the current `EntityID`.
+--
+-- @since 0.11
+{-# INLINE entity #-}
+entity :: QueryT f EntityID
+entity = Query (,entityDyn)
+
+-- | Fetch a component.
+--
+-- @since 0.11
+{-# INLINE fetch #-}
+fetch :: forall f a. (Component a) => QueryT f a
+fetch = fromDynInternal @f @a $ fetchDyn
+
+-- | Fetch a component, or `Nothing`.
+--
+-- @since 0.12
+{-# INLINE fetchMaybe #-}
+fetchMaybe :: forall f a. (Component a) => QueryT f (Maybe a)
+fetchMaybe = fromDynInternal @f @a $ fetchMaybeDyn
+
+-- | Fetch a component and map it, storing the result.
+--
+-- @since 0.11
+{-# INLINE fetchMap #-}
+fetchMap :: forall f a. (Component a) => (a -> a) -> QueryT f a
+fetchMap f = fromDynInternal @_ @a $ fetchMapDyn f
+
+-- | Fetch a component and map it with a monadic function, storing the result.
+--
+-- @since 0.11
+{-# INLINE fetchMapM #-}
+fetchMapM :: forall f a. (Monad f, Component a) => (a -> f a) -> QueryT f a
+fetchMapM f = fromDynInternal @_ @a $ fetchMapDynM f
+
+-- | Fetch a component and map it with some input, storing the result.
+--
+-- @since 0.11
+{-# INLINE zipFetchMap #-}
+zipFetchMap :: forall f a b. (Component a) => (b -> a -> a) -> QueryT f b -> QueryT f a
+zipFetchMap f = fromWriterInternal @a $ zipFetchMapDyn f
+
+-- | Fetch a component and map it with some input, storing the result and returning some output.
+--
+-- @since 0.11
+{-# INLINE zipFetchMapAccum #-}
+zipFetchMapAccum ::
+  forall f a b c. (Component a) => (b -> a -> (c, a)) -> QueryT f b -> QueryT f (c, a)
+zipFetchMapAccum f = fromWriterInternal @a $ zipFetchMapAccumDyn f
+
+-- | Fetch a component and map it with some input and a monadic function, storing the result.
+--
+-- @since 0.11
+{-# INLINE zipFetchMapM #-}
+zipFetchMapM :: forall f a b. (Monad f, Component a) => (b -> a -> f a) -> QueryT f b -> QueryT f a
+zipFetchMapM f = fromWriterInternal @a $ zipFetchMapDynM f
+
+-- | Fetch a component and map it with some input and a monadic function,
+-- storing the result and returning some output.
+--
+-- @since 0.11
+{-# INLINE zipFetchMapAccumM #-}
+zipFetchMapAccumM ::
+  forall f a b c. (Monad f, Component a) => (b -> a -> f (c, a)) -> QueryT f b -> QueryT f (c, a)
+zipFetchMapAccumM f = fromWriterInternal @a $ zipFetchMapAccumDynM f
+
+-- | Filter for entities with a component.
+--
+-- @since 0.11
+{-# INLINE with #-}
+with :: forall f a. (Component a) => QueryT f ()
+with = fromDynInternal @f @a $ withDyn
+
+-- | Filter for entities without a component.
+--
+-- @since 0.11
+{-# INLINE without #-}
+without :: forall f a. (Component a) => QueryT f ()
+without = fromDynInternal @f @a $ withDyn
+
+-- | Convert a `DynamicQueryT` to a `QueryT`.
+--
+-- @since 0.11
+{-# INLINE fromDyn #-}
+fromDyn :: DynamicQueryT f a -> QueryT f a
+fromDyn q = Query (,q)
+
+{-# INLINE fromDynInternal #-}
+fromDynInternal ::
+  forall f a b.
+  (Component a) =>
+  (ComponentID -> DynamicQueryT f b) ->
+  QueryT f b
+fromDynInternal f = Query $ \cs ->
+  let !(cId, cs') = CS.insert @a cs in (cs', f cId)
+
+{-# INLINE fromWriterInternal #-}
+fromWriterInternal ::
+  forall c f a b.
+  (Component c) =>
+  (ComponentID -> DynamicQueryT f b -> DynamicQueryT f a) ->
+  QueryT f b ->
+  QueryT f a
+fromWriterInternal f q = Query $ \cs ->
+  let !(cId, cs') = CS.insert @c cs
+      !(cs'', dynQ) = runQuery q cs'
+   in (cs'', f cId dynQ)
+
+liftQuery :: (MonadTrans g, Monad (g f), Monad f) => QueryT f a -> QueryT (g f) a
+liftQuery q = Query $ \cs -> let !(cs', dynQ) = runQuery q cs in (cs', liftQueryDyn dynQ)
+
+-- | Match and update all entities.
+--
+-- @since 0.11
+{-# INLINE query #-}
+query :: (Applicative f) => QueryT f a -> Entities -> f ([a], Entities)
+query = runQueryWithDyn queryDyn
+
+-- | Match and update a single matched entity.
+--
+-- @since 0.12
+{-# INLINE querySingle #-}
+querySingle :: (HasCallStack, Applicative f) => QueryT f a -> Entities -> f (a, Entities)
+querySingle = runQueryWithDyn querySingleDyn
+
+-- | Match and update a single matched entity, or `Nothing`.
+--
+-- @since 0.12
+{-# INLINE querySingleMaybe #-}
+querySingleMaybe :: (Applicative m) => QueryT m a -> Entities -> m (Maybe a, Entities)
+querySingleMaybe = runQueryWithDyn querySingleMaybeDyn
+
+-- | Match and update the specified entities.
+--
+-- @since 0.12
+{-# INLINE queryEntities #-}
+queryEntities :: (Monad m) => [EntityID] -> QueryT m a -> Entities -> m ([a], Entities)
+queryEntities eIds = runQueryWithDyn $ queryEntitiesDyn eIds
+
+-- | Match and update all entities.
+--
+-- @since 0.12
+{-# INLINE readQuery #-}
+readQuery :: (Applicative f) => QueryT f a -> Entities -> f ([a], Entities)
+readQuery = runQueryWithDyn $ \q es -> (,es) <$> readQueryDyn q es
+
+-- | Match a single entity.
+--
+-- @since 0.12
+{-# INLINE readQuerySingle #-}
+readQuerySingle :: (HasCallStack, Applicative f) => QueryT f a -> Entities -> f (a, Entities)
+readQuerySingle = runQueryWithDyn $ \q es -> (,es) <$> readQuerySingleDyn q es
+
+-- | Match a single entity, or `Nothing`.
+--
+-- @since 0.12
+{-# INLINE readQuerySingleMaybe #-}
+readQuerySingleMaybe :: (Applicative f) => QueryT f a -> Entities -> f (Maybe a, Entities)
+readQuerySingleMaybe = runQueryWithDyn $ \q es -> (,es) <$> readQuerySingleMaybeDyn q es
+
+-- | Match the specified entities.
+--
+-- @since 0.12
+{-# INLINE readQueryEntities #-}
+readQueryEntities :: (Applicative f) => [EntityID] -> QueryT f a -> Entities -> f ([a], Entities)
+readQueryEntities eIds = runQueryWithDyn $ \q es -> (,es) <$> readQueryEntitiesDyn eIds q es
+
+{-# INLINE runQueryWithDyn #-}
+runQueryWithDyn ::
+  (Applicative f) =>
+  (DynamicQueryT f a -> Entities -> b) ->
+  QueryT f a ->
+  Entities ->
+  b
+runQueryWithDyn f q es =
+  let !(cs', dynQ) = runQuery q $ components es in f dynQ es {components = cs'}

@@ -1,512 +1,502 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.Query.Dynamic--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.Query.Dynamic-  ( -- * Dynamic queries-    DynamicQuery,-    DynamicQueryT (..),--    -- ** Operations-    entityDyn,-    fetchDyn,-    fetchMaybeDyn,-    fetchMapDyn,-    fetchMapDynM,-    zipFetchMapDyn,-    zipFetchMapAccumDyn,-    zipFetchMapDynM,-    zipFetchMapAccumDynM,--    -- ** Filters-    withDyn,-    withoutDyn,--    -- ** Running-    queryDyn,-    singleDyn,-    singleMaybeDyn,-    queryEntitiesDyn,-    readQueryDyn,-    mapSingleDyn,-    mapSingleMaybeDyn,-    readQueryEntitiesDyn,--    -- *** Internal-    QueryFilter (..),-    queryFilter,-    runDynQuery,-    runDynQueryEntities,-    readDynQuery,-    readDynQueryEntities,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Archetype (Archetype)-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (ArchetypeID, Node (..))-import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Entities-import Control.Applicative-import Control.Monad-import Control.Monad.Identity (Identity)-import Data.Bifunctor-import Data.Foldable-import Data.Map (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Stack-import Prelude hiding (reads)--data Operation f a where-  Entity :: Operation f EntityID-  Fetch :: (Component a) => !ComponentID -> Operation f a-  FetchMaybe :: (Component a) => !ComponentID -> Operation f (Maybe a)-  FetchMap :: (Component a) => !(a -> a) -> !ComponentID -> Operation f a-  FetchMapM :: (Monad f, Component a) => !(a -> f a) -> !ComponentID -> Operation f a-  Adjust :: (Component a) => !(b -> a -> (c, a)) -> !ComponentID -> !(DynamicQueryT f b) -> Operation f (c, a)-  AdjustM :: (Monad f, Component a) => !(b -> a -> f (c, a)) -> !ComponentID -> !(DynamicQueryT f b) -> Operation f (c, a)-  With :: !ComponentID -> Operation f ()-  Without :: !ComponentID -> Operation f ()---- @since 0.9-type DynamicQuery = DynamicQueryT Identity---- | Dynamic query for components by ID.------ @since 0.11-data DynamicQueryT f a where-  Pure :: !a -> DynamicQueryT f a-  Map :: !(a -> b) -> !(DynamicQueryT f a) -> DynamicQueryT f b-  Ap :: !(DynamicQueryT f (a -> b)) -> !(DynamicQueryT f a) -> DynamicQueryT f b-  Op :: !(Operation f a) -> DynamicQueryT f a--instance Functor (DynamicQueryT f) where-  {-# INLINE fmap #-}-  fmap = Map---- | @since 0.11-instance Applicative (DynamicQueryT f) where-  {-# INLINE pure #-}-  pure = Pure--  {-# INLINE (<*>) #-}-  (<*>) = Ap--{-# INLINE entityDyn #-}-entityDyn :: DynamicQueryT f EntityID-entityDyn = Op Entity--{-# INLINE fetchDyn #-}-fetchDyn :: (Component a) => ComponentID -> DynamicQueryT f a-fetchDyn = Op . Fetch--{-# INLINE fetchMaybeDyn #-}-fetchMaybeDyn :: (Component a) => ComponentID -> DynamicQueryT f (Maybe a)-fetchMaybeDyn = Op . FetchMaybe--{-# INLINE fetchMapDyn #-}-fetchMapDyn :: (Component a) => (a -> a) -> ComponentID -> DynamicQueryT f a-fetchMapDyn f = Op . FetchMap f--{-# INLINE fetchMapDynM #-}-fetchMapDynM :: (Monad f, Component a) => (a -> f a) -> ComponentID -> DynamicQueryT f a-fetchMapDynM f = Op . FetchMapM f--{-# INLINE zipFetchMapDyn #-}-zipFetchMapDyn :: (Component a) => (b -> a -> a) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f a-zipFetchMapDyn f cId q = snd <$> Op (Adjust (\b a -> ((), f b a)) cId q)--{-# INLINE zipFetchMapAccumDyn #-}-zipFetchMapAccumDyn :: (Component a) => (b -> a -> (c, a)) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f (c, a)-zipFetchMapAccumDyn f cId q = Op $ Adjust f cId q--{-# INLINE zipFetchMapDynM #-}-zipFetchMapDynM :: (Monad f, Component a) => (b -> a -> f a) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f a-zipFetchMapDynM f cId q = snd <$> zipFetchMapAccumDynM (\b a -> ((),) <$> f b a) cId q--{-# INLINE zipFetchMapAccumDynM #-}-zipFetchMapAccumDynM :: (Monad f, Component a) => (b -> a -> f (c, a)) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f (c, a)-zipFetchMapAccumDynM f cId q = Op $ AdjustM f cId q--{-# INLINE withDyn #-}-withDyn :: ComponentID -> DynamicQueryT f ()-withDyn = Op . With--{-# INLINE withoutDyn #-}-withoutDyn :: ComponentID -> DynamicQueryT f ()-withoutDyn = Op . Without--{-# INLINE opFilter #-}-opFilter :: Operation f a -> QueryFilter-opFilter Entity = mempty-opFilter (Fetch cId) = mempty {filterWith = Set.singleton cId}-opFilter (FetchMaybe cId) = mempty {filterWith = Set.singleton cId}-opFilter (FetchMap _ cId) = mempty {filterWith = Set.singleton cId}-opFilter (FetchMapM _ cId) = mempty {filterWith = Set.singleton cId}-opFilter (Adjust _ cId q) = queryFilter q <> mempty {filterWith = Set.singleton cId}-opFilter (AdjustM _ cId q) = queryFilter q <> mempty {filterWith = Set.singleton cId}-opFilter (With cId) = mempty {filterWith = Set.singleton cId}-opFilter (Without cId) = mempty {filterWithout = Set.singleton cId}--{-# INLINE queryFilter #-}-queryFilter :: DynamicQueryT f a -> QueryFilter-queryFilter (Pure _) = mempty-queryFilter (Map _ q) = queryFilter q-queryFilter (Ap f g) = queryFilter f <> queryFilter g-queryFilter (Op op) = opFilter op--{-# INLINE runOp #-}-runOp :: (Applicative f) => Operation f a -> Archetype -> f ([a], Archetype)-runOp Entity arch = pure (Set.toList $ A.entities arch, mempty)-runOp (Fetch cId) arch = pure (A.lookupComponentsAsc cId arch, mempty)-runOp (FetchMaybe cId) arch =-  pure-    ( case A.lookupComponentsAscMaybe cId arch of-        Just as -> fmap Just as-        Nothing -> replicate (length $ A.entities arch) Nothing,-      mempty-    )-runOp (FetchMap f cId) arch = pure $ A.map f cId arch-runOp (FetchMapM f cId) arch = do-  (as, arch') <- A.mapM f cId arch-  return (as, arch')-runOp (Adjust f cId q) arch = do-  res <- runDynQuery q arch-  return $-    let !(bs, arch') = res-        !(as, arch'') = A.zipWith bs f cId arch-     in (as, arch'' <> arch')-runOp (AdjustM f cId q) arch = do-  (as, arch') <- runDynQuery q arch-  (bs, arch'') <- A.zipWithM as f cId arch-  return (bs, arch'' <> arch')-runOp (With _) _ = pure ([], mempty)-runOp (Without _) _ = pure ([], mempty)--{-# INLINE readOp #-}-readOp :: (Applicative f) => Operation f a -> Archetype -> f [a]-readOp Entity arch = pure $ Set.toList $ A.entities arch-readOp (Fetch cId) arch = pure $ A.lookupComponentsAsc cId arch-readOp (FetchMaybe cId) arch =-  pure $-    case A.lookupComponentsAscMaybe cId arch of-      Just as -> fmap Just as-      Nothing -> replicate (length $ A.entities arch) Nothing-readOp (FetchMap f cId) arch = do-  bs <- readOp (Fetch cId) arch-  return $ map f bs-readOp (FetchMapM f cId) arch = do-  bs <- readOp (Fetch cId) arch-  mapM f bs-readOp (Adjust f cId q) arch = do-  as <- readDynQuery q arch-  bs <- readOp (Fetch cId) arch-  return $ zipWith f as bs-readOp (AdjustM f cId q) arch = do-  as <- readDynQuery q arch-  bs <- readOp (Fetch cId) arch-  zipWithM f as bs-readOp (With _) _ = pure []-readOp (Without _) _ = pure []--{-# INLINE queryEntitiesDyn #-}-queryEntitiesDyn ::-  (Monad m) =>-  [EntityID] ->-  DynamicQueryT m a ->-  Entities ->-  m ([a], Entities)-queryEntitiesDyn eIds q es =-  let qf = queryFilter q-      go = runDynQueryEntities eIds q-   in if Set.null $ filterWith qf-        then do-          (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es}-          return (as, es)-        else-          let go' (acc, esAcc) (aId, n) = do-                (as', arch') <- go $ nodeArchetype n-                let n' = n {nodeArchetype = arch' <> nodeArchetype n}-                    !nodes = Map.insert aId n' . AS.nodes $ archetypes esAcc-                return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})-           in foldlM go' ([], es) $ Map.toList . AS.find (filterWith qf) (filterWithout qf) $ archetypes es--readQueryEntitiesDyn :: (Monad m) => [EntityID] -> DynamicQueryT m a -> Entities -> m [a]-readQueryEntitiesDyn eIds q es =-  let qf = queryFilter q-   in if Set.null $ filterWith qf-        then readDynQueryEntities eIds q A.empty {A.entities = Map.keysSet $ entities es}-        else-          let go n = readDynQuery q $ AS.nodeArchetype n-           in concat <$> mapM go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es)--runOpEntities :: (Applicative f) => Operation f a -> [EntityID] -> Archetype -> f ([a], Archetype)-runOpEntities Entity es _ = pure (es, mempty)-runOpEntities (Fetch cId) es arch =-  pure-    ( map snd-        . filter (\(e, _) -> e `elem` es)-        . Map.toList-        $ A.lookupComponents cId arch,-      mempty-    )-runOpEntities (FetchMaybe cId) es arch =-  pure-    ( map (\(e, a) -> if e `elem` es then Just a else Nothing)-        . Map.toList-        $ A.lookupComponents cId arch,-      mempty-    )-runOpEntities (FetchMap f cId) es arch =-  pure $-    let go e a =-          if e `elem` es-            then let a' = f a in (Just a', a')-            else (Nothing, a)-        !(as, arch') = A.zipWith es go cId arch-     in (mapMaybe fst as, arch')-runOpEntities (FetchMapM f cId) es arch = do-  (as, arch') <- runOpEntities (AdjustM (\() a -> (,a) <$> f a) cId (pure ())) es arch-  return (map snd as, arch')-runOpEntities (Adjust f cId q) es arch = do-  res <- runDynQuery q arch-  return $-    let go (e, b) a =-          if e `elem` es-            then let (x, y) = f b a in (Just x, y)-            else (Nothing, a)-        !(bs, arch') = res-        !(as, arch'') = A.zipWith (zip es bs) go cId arch-     in (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch')-runOpEntities (AdjustM f cId q) es arch = do-  (bs, arch') <- runDynQuery q arch-  let go (e, b) a =-        if e `elem` es-          then do-            (x, y) <- f b a-            return (Just x, y)-          else return (Nothing, a)-  (as, arch'') <- A.zipWithM (zip es bs) go cId arch-  return (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch')-runOpEntities (With _) _ arch = pure ([], arch)-runOpEntities (Without _) _ arch = pure ([], arch)--runDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f ([a], Archetype)-runDynQueryEntities es (Pure a) _ = pure (replicate (length es) a, mempty)-runDynQueryEntities es (Map f q) arch = first (fmap f) <$> runDynQueryEntities es q arch-runDynQueryEntities es (Ap f g) arch = do-  res <- runDynQueryEntities es g arch-  res' <- runDynQueryEntities es f arch-  return $-    let (as, arch') = res-        (bs, arch'') = res'-     in (zipWith ($) bs as, arch'' <> arch')-runDynQueryEntities es (Op op) arch = runOpEntities op es arch--{-# INLINE readOpEntities #-}-readOpEntities :: (Applicative f) => Operation f a -> [EntityID] -> Archetype -> f [a]-readOpEntities Entity es _ = pure es-readOpEntities (Fetch cId) es arch =-  pure-    . map snd-    . filter (\(e, _) -> e `elem` es)-    . Map.toList-    $ A.lookupComponents cId arch-readOpEntities (FetchMaybe cId) es arch =-  pure-    . map (\(e, a) -> if e `elem` es then Just a else Nothing)-    . Map.toList-    $ A.lookupComponents cId arch-readOpEntities (FetchMap f cId) es arch = do-  b <- readOpEntities (Fetch cId) es arch-  pure $ map f b-readOpEntities (FetchMapM f cId) es arch = do-  b <- readOpEntities (Fetch cId) es arch-  mapM f b-readOpEntities (Adjust f cId q) es arch = do-  a <- readDynQueryEntities es q arch-  b <- readOpEntities (Fetch cId) es arch-  pure $ zipWith f a b-readOpEntities (AdjustM f cId q) es arch = do-  a <- readDynQueryEntities es q arch-  b <- readOpEntities (Fetch cId) es arch-  zipWithM f a b-readOpEntities (With _) _ _ = pure []-readOpEntities (Without _) _ _ = pure []--{-# INLINE readDynQueryEntities #-}-readDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f [a]-readDynQueryEntities es (Pure a) _ = pure $ replicate (length es) a-readDynQueryEntities es (Map f q) arch = fmap f <$> readDynQueryEntities es q arch-readDynQueryEntities es (Ap f g) arch = do-  a <- readDynQueryEntities es g arch-  b <- readDynQueryEntities es f arch-  pure $ b <*> a-readDynQueryEntities es (Op op) arch = readOpEntities op es arch--{-# INLINE runDynQuery #-}-runDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f ([a], Archetype)-runDynQuery (Pure a) arch = pure (replicate (length $ A.entities arch) a, mempty)-runDynQuery (Map f q) arch = do-  res <- runDynQuery q arch-  return $ first (fmap f) res-runDynQuery (Ap f g) arch = do-  res <- runDynQuery g arch-  res' <- runDynQuery f arch-  return $-    let (as, arch') = res-        (bs, arch'') = res'-     in (zipWith ($) bs as, arch'' <> arch')-runDynQuery (Op op) arch = runOp op arch--{-# INLINE readDynQuery #-}-readDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f [a]-readDynQuery (Pure a) arch = pure $ replicate (length $ A.entities arch) a-readDynQuery (Map f q) arch = fmap f <$> readDynQuery q arch-readDynQuery (Ap f g) arch = do-  as <- readDynQuery g arch-  bs <- readDynQuery f arch-  pure $ zipWith ($) bs as-readDynQuery (Op op) arch = readOp op arch---- | Match all entities.------ @since 0.11-readQueryDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m [a]-readQueryDyn q es =-  let qf = queryFilter q-   in if Set.null $ filterWith qf-        then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities es}-        else-          let go n = readDynQuery q $ AS.nodeArchetype n-           in concat <$> mapM go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es)---- | Match a single entity.------ @since 0.11-singleDyn :: (HasCallStack, Monad m) => DynamicQueryT m a -> Entities -> m a-singleDyn q es = do-  res <- singleMaybeDyn q es-  return $ case res of-    Just a -> a-    _ -> error "singleDyn: expected a single entity"---- | Match a single entity, or `Nothing`.------ @since 0.11-singleMaybeDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m (Maybe a)-singleMaybeDyn q es =-  let qf = queryFilter q-   in if Set.null $ filterWith qf-        then case Map.keys $ entities es of-          [eId] -> do-            res <- readDynQuery q $ A.singleton eId-            return $ case res of-              [a] -> Just a-              _ -> Nothing-          _ -> return Nothing-        else case Map.elems $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of-          [n] -> do-            res <- readDynQuery q $ AS.nodeArchetype n-            return $ case res of-              [a] -> Just a-              _ -> Nothing-          _ -> return Nothing---- | Match and update all matched entities.------ @since 0.11-{-# INLINE queryDyn #-}-queryDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m ([a], Entities)-queryDyn = mapDyn' id--{-# INLINE mapDyn' #-}-mapDyn' ::-  (Monad m) =>-  (Map ArchetypeID Node -> Map ArchetypeID Node) ->-  DynamicQueryT m a ->-  Entities ->-  m ([a], Entities)-mapDyn' f q es =-  let !qf = queryFilter q-      go = runDynQuery q-   in if Set.null $ filterWith qf-        then do-          (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es}-          return (as, es)-        else-          let go' (acc, esAcc) (aId, n) = do-                (as', arch') <- go $ nodeArchetype n-                let n' = n {nodeArchetype = arch' <> nodeArchetype n}-                    !nodes = Map.insert aId n' . AS.nodes $ archetypes esAcc-                return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})-           in foldlM go' ([], es) $ Map.toList . f . AS.find (filterWith qf) (filterWithout qf) $ archetypes es---- | Map a single matched entity.------ @since 0.11-mapSingleDyn :: (HasCallStack, Monad m) => DynamicQueryT m a -> Entities -> m (a, Entities)-mapSingleDyn q es = do-  (res, es') <- mapSingleMaybeDyn q es-  return $ case res of-    Just a -> (a, es')-    _ -> error "mapSingleDyn: expected single matching entity"---- | Map a single matched entity, or @Nothing@.------ @since 0.11-{-# INLINE mapSingleMaybeDyn #-}-mapSingleMaybeDyn :: (Monad m) => DynamicQueryT m a -> Entities -> m (Maybe a, Entities)-mapSingleMaybeDyn q es =-  let qf = queryFilter q-   in if Set.null $ filterWith qf-        then case Map.keys $ entities es of-          [eId] -> do-            res <- runDynQuery q $ A.singleton eId-            return $ case res of-              ([a], _) -> (Just a, es)-              _ -> (Nothing, es)-          _ -> pure (Nothing, es)-        else case Map.toList $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of-          [(aId, n)] -> do-            (as, arch') <- runDynQuery q $ AS.nodeArchetype n-            return $ case as of-              [a] ->-                let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es-                 in (Just a, es {archetypes = (archetypes es) {AS.nodes = nodes}})-              _ -> (Nothing, es)-          _ -> pure (Nothing, es)---- | `Query` filter.------ @since 0.11-data QueryFilter = QueryFilter-  { filterWith :: !(Set ComponentID),-    filterWithout :: !(Set ComponentID)-  }-  deriving (Show)---- | @since 0.9-instance Semigroup QueryFilter where-  QueryFilter r1 w1 <> QueryFilter r2 w2 = QueryFilter (r1 <> r2) (w1 <> w2)---- | @since 0.9-instance Monoid QueryFilter where-  mempty = QueryFilter mempty mempty+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TupleSections #-}
+
+-- |
+-- Module      : Aztecs.ECS.Query.Dynamic
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.Query.Dynamic
+  ( -- * Dynamic queries
+    DynamicQuery,
+    DynamicQueryT (..),
+
+    -- ** Operations
+    entityDyn,
+    fetchDyn,
+    fetchMaybeDyn,
+    fetchMapDyn,
+    fetchMapDynM,
+    zipFetchMapDyn,
+    zipFetchMapAccumDyn,
+    zipFetchMapDynM,
+    zipFetchMapAccumDynM,
+
+    -- ** Filters
+    withDyn,
+    withoutDyn,
+
+    -- ** Conversion
+    liftQueryDyn,
+
+    -- ** Running
+    queryDyn,
+    readQuerySingleDyn,
+    readQuerySingleMaybeDyn,
+    queryEntitiesDyn,
+    readQueryDyn,
+    querySingleDyn,
+    querySingleMaybeDyn,
+    readQueryEntitiesDyn,
+
+    -- *** Internal
+    QueryFilter (..),
+    Operation (..),
+    queryFilter,
+    runDynQuery,
+    runDynQueryEntities,
+    readDynQuery,
+    readDynQueryEntities,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.World.Archetype (Archetype)
+import qualified Aztecs.ECS.World.Archetype as A
+import Aztecs.ECS.World.Archetypes (Node (..))
+import qualified Aztecs.ECS.World.Archetypes as AS
+import Aztecs.ECS.World.Entities
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans (MonadTrans (..))
+import Control.Monad.Identity
+import Data.Bifunctor
+import Data.Foldable
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import GHC.Stack
+import Prelude hiding (reads)
+
+-- @since 0.9
+type DynamicQuery = DynamicQueryT Identity
+
+-- | Dynamic query for components by ID.
+--
+-- @since 0.11
+data DynamicQueryT f a where
+  Entity :: DynamicQueryT f EntityID
+  Pure :: a -> DynamicQueryT f a
+  Map :: (a -> b) -> DynamicQueryT f a -> DynamicQueryT f b
+  Ap :: DynamicQueryT f (a -> b) -> DynamicQueryT f a -> DynamicQueryT f b
+  Lift :: (MonadTrans g, Monad (g f), Monad f) => DynamicQueryT f a -> DynamicQueryT (g f) a
+  Op :: ComponentID -> Operation f a -> DynamicQueryT f a
+
+instance Functor (DynamicQueryT f) where
+  {-# INLINE fmap #-}
+  fmap = Map
+
+-- | @since 0.11
+instance Applicative (DynamicQueryT f) where
+  {-# INLINE pure #-}
+  pure = Pure
+
+  {-# INLINE (<*>) #-}
+  (<*>) = Ap
+
+{-# INLINE entityDyn #-}
+entityDyn :: DynamicQueryT f EntityID
+entityDyn = Entity
+
+{-# INLINE fetchDyn #-}
+fetchDyn :: (Component a) => ComponentID -> DynamicQueryT f a
+fetchDyn cId = Op cId Fetch
+
+{-# INLINE fetchMaybeDyn #-}
+fetchMaybeDyn :: (Component a) => ComponentID -> DynamicQueryT f (Maybe a)
+fetchMaybeDyn cId = Op cId FetchMaybe
+
+{-# INLINE fetchMapDyn #-}
+fetchMapDyn :: (Component a) => (a -> a) -> ComponentID -> DynamicQueryT f a
+fetchMapDyn f cId = Op cId $ FetchMap f
+
+{-# INLINE fetchMapDynM #-}
+fetchMapDynM :: (Monad f, Component a) => (a -> f a) -> ComponentID -> DynamicQueryT f a
+fetchMapDynM f cId = Op cId $ FetchMapM f
+
+{-# INLINE zipFetchMapDyn #-}
+zipFetchMapDyn ::
+  (Component a) => (b -> a -> a) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f a
+zipFetchMapDyn f cId q = snd <$> Op cId (ZipFetchMap (\b a -> ((), f b a)) q)
+
+{-# INLINE zipFetchMapAccumDyn #-}
+zipFetchMapAccumDyn ::
+  (Component a) => (b -> a -> (c, a)) -> ComponentID -> DynamicQueryT f b -> DynamicQueryT f (c, a)
+zipFetchMapAccumDyn f cId q = Op cId $ ZipFetchMap f q
+
+{-# INLINE zipFetchMapDynM #-}
+zipFetchMapDynM ::
+  (Monad f, Component a) =>
+  (b -> a -> f a) ->
+  ComponentID ->
+  DynamicQueryT f b ->
+  DynamicQueryT f a
+zipFetchMapDynM f cId q = snd <$> zipFetchMapAccumDynM (\b a -> ((),) <$> f b a) cId q
+
+{-# INLINE zipFetchMapAccumDynM #-}
+zipFetchMapAccumDynM ::
+  (Monad f, Component a) =>
+  (b -> a -> f (c, a)) ->
+  ComponentID ->
+  DynamicQueryT f b ->
+  DynamicQueryT f (c, a)
+zipFetchMapAccumDynM f cId q = Op cId $ ZipFetchMapM f q
+
+{-# INLINE withDyn #-}
+withDyn :: ComponentID -> DynamicQueryT f ()
+withDyn cId = Op cId With
+
+{-# INLINE withoutDyn #-}
+withoutDyn :: ComponentID -> DynamicQueryT f ()
+withoutDyn cId = Op cId Without
+
+{-# INLINE liftQueryDyn #-}
+liftQueryDyn :: (MonadTrans g, Monad (g f), Monad f) => DynamicQueryT f a -> DynamicQueryT (g f) a
+liftQueryDyn = Lift
+
+-- | Match all entities.
+--
+-- @since 0.11
+readQueryDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f [a]
+readQueryDyn q es =
+  let qf = queryFilter q
+   in if Set.null $ filterWith qf
+        then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities es}
+        else
+          let go n = readDynQuery q $ AS.nodeArchetype n
+           in concat <$> traverse go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es)
+
+-- | Match a single entity.
+--
+-- @since 0.11
+readQuerySingleDyn :: (HasCallStack, Applicative f) => DynamicQueryT f a -> Entities -> f a
+readQuerySingleDyn q es = do
+  res <- readQuerySingleMaybeDyn q es
+  return $ case res of
+    Just a -> a
+    _ -> error "singleDyn: expected a single entity"
+
+-- | Match a single entity, or `Nothing`.
+--
+-- @since 0.11
+readQuerySingleMaybeDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f (Maybe a)
+readQuerySingleMaybeDyn q es =
+  let qf = queryFilter q
+   in if Set.null $ filterWith qf
+        then case Map.keys $ entities es of
+          [eId] -> do
+            res <- readDynQuery q $ A.singleton eId
+            return $ case res of
+              [a] -> Just a
+              _ -> Nothing
+          _ -> pure Nothing
+        else case Map.elems $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of
+          [n] -> do
+            res <- readDynQuery q $ AS.nodeArchetype n
+            return $ case res of
+              [a] -> Just a
+              _ -> Nothing
+          _ -> pure Nothing
+
+readQueryEntitiesDyn :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Entities -> f [a]
+readQueryEntitiesDyn eIds q es =
+  let qf = queryFilter q
+   in if Set.null $ filterWith qf
+        then readDynQueryEntities eIds q A.empty {A.entities = Map.keysSet $ entities es}
+        else
+          let go n = readDynQuery q $ AS.nodeArchetype n
+           in concat <$> traverse go (AS.find (filterWith qf) (filterWithout qf) $ archetypes es)
+
+-- | Match and update all matched entities.
+--
+-- @since 0.11
+{-# INLINE queryDyn #-}
+queryDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f ([a], Entities)
+queryDyn q es =
+  let qf = queryFilter q
+   in if Set.null $ filterWith qf
+        then (,es) . fst <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es}
+        else
+          let go (aId, n) = do
+                res <- runDynQuery q $ nodeArchetype n
+                return $
+                  let (as', arch') = res
+                   in (as', aId, n {nodeArchetype = arch' <> nodeArchetype n})
+              matches = Map.toList . AS.find (filterWith qf) (filterWithout qf) $ archetypes es
+              res' = traverse go matches
+              folder (acc, esAcc) (as, aId, node) =
+                let nodes = Map.insert aId node . AS.nodes $ archetypes esAcc
+                 in (as ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})
+           in fmap (foldl' folder ([], es)) res'
+
+-- | Match and update a single entity.
+--
+-- @since 0.11
+querySingleDyn :: (HasCallStack, Applicative m) => DynamicQueryT m a -> Entities -> m (a, Entities)
+querySingleDyn q es = do
+  res <- querySingleMaybeDyn q es
+  return $ case res of
+    (Just a, es') -> (a, es')
+    _ -> error "mapSingleDyn: expected single matching entity"
+
+-- | Match and update a single entity, or @Nothing@.
+--
+-- @since 0.11
+{-# INLINE querySingleMaybeDyn #-}
+querySingleMaybeDyn :: (Applicative f) => DynamicQueryT f a -> Entities -> f (Maybe a, Entities)
+querySingleMaybeDyn q es =
+  let qf = queryFilter q
+   in if Set.null $ filterWith qf
+        then case Map.keys $ entities es of
+          [eId] -> do
+            res <- runDynQuery q $ A.singleton eId
+            return $ case res of
+              ([a], _) -> (Just a, es)
+              _ -> (Nothing, es)
+          _ -> pure (Nothing, es)
+        else case Map.toList $ AS.find (filterWith qf) (filterWithout qf) $ archetypes es of
+          [(aId, n)] -> do
+            res <- runDynQuery q $ AS.nodeArchetype n
+            return $ case res of
+              ([a], arch') ->
+                let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es
+                 in (Just a, es {archetypes = (archetypes es) {AS.nodes = nodes}})
+              _ -> (Nothing, es)
+          _ -> pure (Nothing, es)
+
+{-# INLINE queryEntitiesDyn #-}
+queryEntitiesDyn ::
+  (Monad m) =>
+  [EntityID] ->
+  DynamicQueryT m a ->
+  Entities ->
+  m ([a], Entities)
+queryEntitiesDyn eIds q es =
+  let qf = queryFilter q
+      go = runDynQueryEntities eIds q
+   in if Set.null $ filterWith qf
+        then do
+          (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es}
+          return (as, es)
+        else
+          let go' (acc, esAcc) (aId, n) = do
+                (as', arch') <- go $ nodeArchetype n
+                let n' = n {nodeArchetype = arch' <> nodeArchetype n}
+                    nodes = Map.insert aId n' . AS.nodes $ archetypes esAcc
+                return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})
+           in foldlM go' ([], es) $ Map.toList . AS.find (filterWith qf) (filterWithout qf) $ archetypes es
+
+{-# INLINE queryFilter #-}
+queryFilter :: DynamicQueryT f a -> QueryFilter
+queryFilter (Pure _) = mempty
+queryFilter (Map _ q) = queryFilter q
+queryFilter (Ap f g) = queryFilter f <> queryFilter g
+queryFilter (Lift q) = queryFilter q
+queryFilter Entity = mempty
+queryFilter (Op cId op) = opFilter cId op
+
+{-# INLINE readDynQuery #-}
+readDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f [a]
+readDynQuery (Pure a) arch = pure $ replicate (length $ A.entities arch) a
+readDynQuery (Map f q) arch = fmap f <$> readDynQuery q arch
+readDynQuery (Ap f g) arch = do
+  as <- readDynQuery g arch
+  bs <- readDynQuery f arch
+  pure $ zipWith ($) bs as
+readDynQuery (Lift q) arch = lift $ readDynQuery q arch
+readDynQuery Entity arch = pure $ Set.toList $ A.entities arch
+readDynQuery (Op cId op) arch = readOp cId op arch
+
+{-# INLINE readDynQueryEntities #-}
+readDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f [a]
+readDynQueryEntities es (Pure a) _ = pure $ replicate (length es) a
+readDynQueryEntities es (Map f q) arch = fmap f <$> readDynQueryEntities es q arch
+readDynQueryEntities es (Ap f g) arch = do
+  a <- readDynQueryEntities es g arch
+  b <- readDynQueryEntities es f arch
+  pure $ b <*> a
+readDynQueryEntities es (Lift q) arch = lift $ readDynQueryEntities es q arch
+readDynQueryEntities es Entity _ = pure es
+readDynQueryEntities es (Op cId op) arch = readOpEntities cId es op arch
+
+{-# INLINE runDynQuery #-}
+runDynQuery :: (Applicative f) => DynamicQueryT f a -> Archetype -> f ([a], Archetype)
+runDynQuery (Pure a) arch = pure (replicate (length $ A.entities arch) a, mempty)
+runDynQuery (Map f q) arch = do
+  res <- runDynQuery q arch
+  return $ first (fmap f) res
+runDynQuery (Ap f g) arch = do
+  res <- runDynQuery g arch
+  res' <- runDynQuery f arch
+  return $
+    let (as, arch') = res
+        (bs, arch'') = res'
+     in (zipWith ($) bs as, arch'' <> arch')
+runDynQuery (Lift q) arch = lift $ runDynQuery q arch
+runDynQuery Entity arch = (,arch) <$> readDynQuery Entity arch
+runDynQuery (Op cId op) arch = runOp cId op arch
+
+runDynQueryEntities :: (Applicative f) => [EntityID] -> DynamicQueryT f a -> Archetype -> f ([a], Archetype)
+runDynQueryEntities es (Pure a) _ = pure (replicate (length es) a, mempty)
+runDynQueryEntities es (Map f q) arch = first (fmap f) <$> runDynQueryEntities es q arch
+runDynQueryEntities es (Ap f g) arch = do
+  res <- runDynQueryEntities es g arch
+  res' <- runDynQueryEntities es f arch
+  return $
+    let (as, arch') = res
+        (bs, arch'') = res'
+     in (zipWith ($) bs as, arch'' <> arch')
+runDynQueryEntities es (Lift q) arch = lift $ runDynQueryEntities es q arch
+runDynQueryEntities es Entity _ = pure (es, mempty)
+runDynQueryEntities es (Op cId op) arch = runOpEntities cId es op arch
+
+data Operation f a where
+  Fetch :: (Component a) => Operation f a
+  FetchMaybe :: (Component a) => Operation f (Maybe a)
+  FetchMap :: (Component a) => (a -> a) -> Operation f a
+  FetchMapM :: (Monad f, Component a) => (a -> f a) -> Operation f a
+  ZipFetchMap :: (Component a) => (b -> a -> (c, a)) -> (DynamicQueryT f b) -> Operation f (c, a)
+  ZipFetchMapM :: (Monad f, Component a) => (b -> a -> f (c, a)) -> (DynamicQueryT f b) -> Operation f (c, a)
+  With :: Operation f ()
+  Without :: Operation f ()
+
+{-# INLINE opFilter #-}
+opFilter :: ComponentID -> Operation f a -> QueryFilter
+opFilter cId Fetch = mempty {filterWith = Set.singleton cId}
+opFilter cId FetchMaybe = mempty {filterWith = Set.singleton cId}
+opFilter cId (FetchMap _) = mempty {filterWith = Set.singleton cId}
+opFilter cId (FetchMapM _) = mempty {filterWith = Set.singleton cId}
+opFilter cId (ZipFetchMap _ q) = queryFilter q <> mempty {filterWith = Set.singleton cId}
+opFilter cId (ZipFetchMapM _ q) = queryFilter q <> mempty {filterWith = Set.singleton cId}
+opFilter cId With = mempty {filterWith = Set.singleton cId}
+opFilter cId Without = mempty {filterWithout = Set.singleton cId}
+
+{-# INLINE readOp #-}
+readOp :: (Applicative f) => ComponentID -> Operation f a -> Archetype -> f [a]
+readOp cId Fetch arch = pure $ A.lookupComponentsAsc cId arch
+readOp cId FetchMaybe arch =
+  pure $
+    case A.lookupComponentsAscMaybe cId arch of
+      Just as -> fmap Just as
+      Nothing -> replicate (length $ A.entities arch) Nothing
+readOp cId (FetchMap f) arch = do
+  bs <- readOp cId Fetch arch
+  return $ map f bs
+readOp cId (FetchMapM f) arch = do
+  bs <- readOp cId Fetch arch
+  mapM f bs
+readOp cId (ZipFetchMap f q) arch = do
+  as <- readDynQuery q arch
+  bs <- readOp cId Fetch arch
+  return $ zipWith f as bs
+readOp cId (ZipFetchMapM f q) arch = do
+  as <- readDynQuery q arch
+  bs <- readOp cId Fetch arch
+  zipWithM f as bs
+readOp _ With _ = pure []
+readOp _ Without _ = pure []
+
+{-# INLINE runOp #-}
+runOp :: (Applicative f) => ComponentID -> Operation f a -> Archetype -> f ([a], Archetype)
+runOp cId (FetchMap f) arch = pure $ A.map f cId arch
+runOp cId (FetchMapM f) arch = do
+  (as, arch') <- A.mapM f cId arch
+  return (as, arch')
+runOp cId (ZipFetchMap f q) arch = do
+  res <- runDynQuery q arch
+  return $
+    let (bs, arch') = res
+        (as, arch'') = A.zipMap bs f cId arch
+     in (as, arch'' <> arch')
+runOp cId (ZipFetchMapM f q) arch = do
+  (as, arch') <- runDynQuery q arch
+  (bs, arch'') <- A.zipMapM as f cId arch
+  return (bs, arch'' <> arch')
+runOp cId op arch = (,mempty) <$> readOp cId op arch
+
+{-# INLINE readOpEntities #-}
+readOpEntities :: (Applicative f) => ComponentID -> [EntityID] -> Operation f a -> Archetype -> f [a]
+readOpEntities cId es Fetch arch =
+  pure
+    . map snd
+    . filter (\(e, _) -> e `elem` es)
+    . Map.toList
+    $ A.lookupComponents cId arch
+readOpEntities cId es FetchMaybe arch =
+  pure
+    . map (\(e, a) -> if e `elem` es then Just a else Nothing)
+    . Map.toList
+    $ A.lookupComponents cId arch
+readOpEntities cId es (FetchMap f) arch = do
+  b <- readOpEntities cId es Fetch arch
+  pure $ map f b
+readOpEntities cId es (FetchMapM f) arch = do
+  b <- readOpEntities cId es Fetch arch
+  mapM f b
+readOpEntities cId es (ZipFetchMap f q) arch = do
+  a <- readDynQueryEntities es q arch
+  b <- readOpEntities cId es Fetch arch
+  pure $ zipWith f a b
+readOpEntities cId es (ZipFetchMapM f q) arch = do
+  a <- readDynQueryEntities es q arch
+  b <- readOpEntities cId es Fetch arch
+  zipWithM f a b
+readOpEntities _ _ With _ = pure []
+readOpEntities _ _ Without _ = pure []
+
+runOpEntities :: (Applicative f) => ComponentID -> [EntityID] -> Operation f a -> Archetype -> f ([a], Archetype)
+runOpEntities cId es (FetchMap f) arch =
+  pure $
+    let go e a =
+          if e `elem` es
+            then let a' = f a in (Just a', a')
+            else (Nothing, a)
+        (as, arch') = A.zipMap es go cId arch
+     in (mapMaybe fst as, arch')
+runOpEntities cId es (FetchMapM f) arch = do
+  (as, arch') <- runOpEntities cId es (ZipFetchMapM (\() a -> (,a) <$> f a) (pure ())) arch
+  return (map snd as, arch')
+runOpEntities cId es (ZipFetchMap f q) arch = do
+  res <- runDynQuery q arch
+  return $
+    let go (e, b) a =
+          if e `elem` es
+            then let (x, y) = f b a in (Just x, y)
+            else (Nothing, a)
+        (bs, arch') = res
+        (as, arch'') = A.zipMap (zip es bs) go cId arch
+     in (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch')
+runOpEntities cId es (ZipFetchMapM f q) arch = do
+  (bs, arch') <- runDynQuery q arch
+  let go (e, b) a =
+        if e `elem` es
+          then do
+            (x, y) <- f b a
+            return (Just x, y)
+          else return (Nothing, a)
+  (as, arch'') <- A.zipMapM (zip es bs) go cId arch
+  return (mapMaybe (\(m, b) -> fmap (,b) m) as, arch'' <> arch')
+runOpEntities cId es op arch = (,arch) <$> readOpEntities cId es op arch
+
+-- | `Query` filter.
+--
+-- @since 0.11
+data QueryFilter = QueryFilter
+  { filterWith :: !(Set ComponentID),
+    filterWithout :: !(Set ComponentID)
+  }
+  deriving (Show)
+
+-- | @since 0.9
+instance Semigroup QueryFilter where
+  QueryFilter r1 w1 <> QueryFilter r2 w2 = QueryFilter (r1 <> r2) (w1 <> w2)
+
+-- | @since 0.9
+instance Monoid QueryFilter where
+  mempty = QueryFilter mempty mempty

@@ -1,216 +1,337 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}---- |--- Module      : Aztecs.ECS.System--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)------ Systems to process entities.-module Aztecs.ECS.System-  ( -- * Systems-    System,-    SystemT (..),--    -- ** Reading-    readQuery,-    allDyn,-    readQueryEntities,--    -- ** Writing-    query,-    querySingleMaybe,-    queryDyn,-    querySingleMaybeDyn,--    -- ** Running-    runSystemT,-    concurrently,--    -- * Internal-    Job (..),-    Task (..),-  )-where--import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.Query (QueryT (..))-import Aztecs.ECS.Query.Dynamic (DynamicQueryT, queryFilter, readDynQuery, readDynQueryEntities)-import qualified Aztecs.ECS.View as V-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Concurrent (forkIO)-import Control.Concurrent.MVar-import Control.Monad.Identity-import Control.Monad.Trans-import Data.Kind-import qualified Data.Map as Map---- | System task.------ @since 0.11-newtype Task t (m :: Type -> Type) a-  = Task {runTask :: ((Entities -> Entities) -> t m Entities) -> t m a}-  deriving (Functor)---- | Job to be interpreted.------ @since 0.11-data Job t m a where-  Pure :: a -> Job t m a-  Map :: (a -> b) -> Job t m a -> Job t m b-  Ap :: Job t m (a -> b) -> Job t m a -> Job t m b-  Bind :: Job t m a -> (a -> Job t m b) -> Job t m b-  Once :: Task t m a -> Job t m a--type System = SystemT Identity---- | System to process entities.------ @since 0.11-newtype SystemT m a-  = System {unSystem :: forall t. (MonadTrans t, Monad (t m)) => Job t m a}---- | @since 0.11-instance Functor (SystemT m) where-  fmap f (System s) = System $ Map f s---- | @since 0.11-instance (Monad m) => Applicative (SystemT m) where-  pure a = System $ Pure a-  (System f) <*> (System g) = System $ Ap f g---- | @since 0.11-instance (Monad m) => Monad (SystemT m) where-  (System a) >>= f = System $ Bind a (unSystem . f)---- | @since 0.11-instance (MonadIO m) => MonadIO (SystemT m) where-  liftIO m = System $ Once . Task . const . lift $ liftIO m---- | Map all entities with a `DynamicQueryT`.------ @since 0.11-queryDyn :: (Monad m) => DynamicQueryT m a -> SystemT m [a]-queryDyn q = System $ Once . Task $ \f -> do-  w <- f id-  let qf = queryFilter q-      !v = V.view qf $ archetypes w-  (o, v') <- lift $ V.mapDyn q v-  _ <- f $ V.unview v'-  return o---- | Map a single entity with a `DynamicQueryT`.------ @since 0.11-querySingleMaybeDyn :: (Monad m) => DynamicQueryT m a -> SystemT m (Maybe a)-querySingleMaybeDyn q = System $ Once . Task $ \f -> do-  w <- f id-  let qf = queryFilter q-  case V.viewSingle qf $ archetypes w of-    Just v -> do-      (o, v') <- lift $ V.mapSingleDyn q v-      _ <- f $ V.unview v'-      return o-    Nothing -> return Nothing---- | Match and update all entities with a `QueryT`.------ @since 0.11-query :: (Monad m) => QueryT m a -> SystemT m [a]-query q = do-  dynQ <- fromQuery q-  queryDyn dynQ---- | Match and update a single entity with a `QueryT`, or @Nothing@.------ @since 0.11-querySingleMaybe :: (Monad m) => QueryT m a -> SystemT m (Maybe a)-querySingleMaybe q = do-  dynQ <- fromQuery q-  querySingleMaybeDyn dynQ---- | Match all entities with a `QueryT`.------ @since 0.11-readQuery :: (Monad m) => QueryT m a -> SystemT m [a]-readQuery q = do-  dynQ <- fromQuery q-  allDyn dynQ---- | Match entities with a `QueryT`.------ @since 0.11-readQueryEntities :: (Monad m) => [EntityID] -> QueryT m a -> SystemT m [a]-readQueryEntities es q = fromQuery q >>= queryEntitiesDyn es--allDyn :: (Monad m) => DynamicQueryT m a -> SystemT m [a]-allDyn q = System $ Once . Task $ \f -> do-  w <- f id-  let qf = queryFilter q-      !v = V.view qf $ archetypes w-  lift $-    if V.null v-      then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities w}-      else V.allDyn q v--queryEntitiesDyn :: (Monad m) => [EntityID] -> DynamicQueryT m a -> SystemT m [a]-queryEntitiesDyn es q = System $ Once . Task $ \f -> do-  w <- f id-  let qf = queryFilter q-      !v = V.view qf $ archetypes w-  lift $-    if V.null v-      then readDynQueryEntities es q $ A.empty {A.entities = Map.keysSet $ entities w}-      else V.allDyn q v---- | Convert a `QueryT` to a `System`.------ @since 0.11-fromQuery :: (Monad m) => QueryT m a -> SystemT m (DynamicQueryT m a)-fromQuery q = System $ Once . Task $ \f -> do-  w <- f id-  let (cs', dynQ) = runQuery q $ components w-  _ <- f $ const w {components = cs'}-  return dynQ--runSystemT :: (MonadTrans t, Monad (t m), Monad m) => SystemT m a -> ((Entities -> Entities) -> t m Entities) -> t m a-runSystemT (System s) = runJob s--runJob :: (MonadTrans t, Monad (t m), Monad m) => Job t m a -> ((Entities -> Entities) -> t m Entities) -> t m a-runJob (Pure a) _ = return a-runJob (Map f' s') f = f' <$> runJob s' f-runJob (Ap f' a) f = runJob f' f <*> runJob a f-runJob (Bind a f') f = runJob a f >>= \a' -> runJob (f' a') f-runJob (Once (Task t)) f = t f--concurrently :: SystemT IO a -> ((Entities -> Entities) -> IO Entities) -> IO a-concurrently (System s) f = runJobConcurrently s $ lift . f--runJobConcurrently :: Job IdentityT IO a -> ((Entities -> Entities) -> IdentityT IO Entities) -> IO a-runJobConcurrently (Pure a) _ = return a-runJobConcurrently (Map f' s') f = f' <$> runJobConcurrently s' f-runJobConcurrently (Ap f' a) f = do-  aVar <- newEmptyMVar-  fVar <- newEmptyMVar-  _ <- forkIO $ do-    f'' <- runJobConcurrently f' f-    putMVar fVar f''-  _ <- forkIO $ do-    a' <- runJobConcurrently a f-    putMVar aVar a'-  a' <- takeMVar aVar-  f'' <- takeMVar fVar-  return $ f'' a'-runJobConcurrently (Bind a f') f = runJobConcurrently a f >>= \a' -> runJobConcurrently (f' a') f-runJobConcurrently (Once (Task t)) f = runIdentityT $ t f+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- |
+-- Module      : Aztecs.ECS.System
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+--
+-- Systems to process entities.
+module Aztecs.ECS.System
+  ( -- * Systems
+    System,
+    SystemT (..),
+
+    -- ** Queries
+
+    -- *** Reading
+    readQuery,
+    readQueryT,
+    readQueryEntities,
+    readQueryEntitiesT,
+
+    -- *** Writing
+    query,
+    queryT,
+    querySingleMaybe,
+    querySingleMaybeT,
+
+    -- *** Conversion
+    fromQuery,
+    fromQueryT,
+
+    -- ** Dynamic Queries
+
+    -- *** Reading
+    readQueryDyn,
+    readQueryDynT,
+    readQueryEntitiesDyn,
+    readQueryEntitiesDynT,
+
+    -- *** Writing
+    queryDyn,
+    queryDynT,
+    querySingleMaybeDyn,
+    querySingleMaybeDynT,
+
+    -- * Internal
+    Job (..),
+    Task (..),
+
+    -- ** Running
+    runSystemT,
+    concurrently,
+  )
+where
+
+import Aztecs.ECS.Entity
+import Aztecs.ECS.Query (Query, QueryT (..))
+import Aztecs.ECS.Query.Dynamic
+  ( DynamicQuery,
+    DynamicQueryT,
+    queryFilter,
+    readDynQuery,
+    readDynQueryEntities,
+  )
+import qualified Aztecs.ECS.View as V
+import qualified Aztecs.ECS.World.Archetype as A
+import Aztecs.ECS.World.Entities (Entities (..))
+import Control.Concurrent
+import Control.Monad.Identity
+import Control.Monad.Trans
+import Data.Kind
+import qualified Data.Map as Map
+
+-- | System task.
+--
+-- @since 0.11
+newtype Task t (m :: Type -> Type) a
+  = Task {runTask :: ((Entities -> Entities) -> t m Entities) -> t m a}
+  deriving (Functor)
+
+-- | Job to be interpreted.
+--
+-- @since 0.11
+data Job t m a where
+  Pure :: a -> Job t m a
+  Map :: (a -> b) -> Job t m a -> Job t m b
+  Ap :: Job t m (a -> b) -> Job t m a -> Job t m b
+  Bind :: Job t m a -> (a -> Job t m b) -> Job t m b
+  Once :: Task t m a -> Job t m a
+
+type System = SystemT Identity
+
+-- | System to process entities.
+--
+-- @since 0.11
+newtype SystemT m a
+  = System {unSystem :: forall t. (MonadTrans t, Monad (t m)) => Job t m a}
+
+-- | @since 0.11
+instance Functor (SystemT m) where
+  fmap f (System s) = System $ Map f s
+
+-- | @since 0.11
+instance (Monad m) => Applicative (SystemT m) where
+  pure a = System $ Pure a
+  (System f) <*> (System g) = System $ Ap f g
+
+-- | @since 0.11
+instance (Monad m) => Monad (SystemT m) where
+  (System a) >>= f = System $ Bind a (unSystem . f)
+
+-- | @since 0.11
+instance (MonadIO m) => MonadIO (SystemT m) where
+  liftIO m = System $ Once . Task . const . lift $ liftIO m
+
+-- | Match all entities with a `Query`.
+--
+-- @since 0.11
+readQuery :: (Monad m) => Query a -> SystemT m [a]
+readQuery q = do
+  dynQ <- fromQuery q
+  readQueryDyn dynQ
+
+-- | Match all entities with a `QueryT`.
+--
+-- @since 0.11
+readQueryT :: (Monad m) => QueryT m a -> SystemT m [a]
+readQueryT q = do
+  dynQ <- fromQueryT q
+  readQueryDynT dynQ
+
+-- | Match and update all entities with a `QueryT`.
+--
+-- @since 0.11
+query :: (Monad m) => Query a -> SystemT m [a]
+query q = do
+  dynQ <- fromQuery q
+  queryDyn dynQ
+
+-- | Match and update all entities with a `QueryT`.
+--
+-- @since 0.11
+queryT :: (Monad m) => QueryT m a -> SystemT m [a]
+queryT q = do
+  dynQ <- fromQueryT q
+  queryDynT dynQ
+
+-- | Match and update a single entity with a `Query`, or @Nothing@.
+--
+-- @since 0.11
+querySingleMaybe :: (Monad m) => Query a -> SystemT m (Maybe a)
+querySingleMaybe q = do
+  dynQ <- fromQuery q
+  querySingleMaybeDyn dynQ
+
+-- | Match and update a single entity with a `QueryT`, or @Nothing@.
+--
+-- @since 0.11
+querySingleMaybeT :: (Monad m) => QueryT m a -> SystemT m (Maybe a)
+querySingleMaybeT q = do
+  dynQ <- fromQueryT q
+  querySingleMaybeDynT dynQ
+
+-- | Map all entities with a `DynamicQuery`.
+--
+-- @since 0.11
+queryDyn :: (Monad m) => DynamicQuery a -> SystemT m [a]
+queryDyn q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+      !v = V.view qf $ archetypes w
+  let (o, v') = runIdentity $ V.mapDyn q v
+  _ <- f $ V.unview v'
+  return o
+
+-- | Map all entities with a `DynamicQueryT`.
+--
+-- @since 0.11
+queryDynT :: (Monad m) => DynamicQueryT m a -> SystemT m [a]
+queryDynT q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+      !v = V.view qf $ archetypes w
+  (o, v') <- lift $ V.mapDyn q v
+  _ <- f $ V.unview v'
+  return o
+
+-- | Map a single entity with a `DynamicQuery`.
+--
+-- @since 0.11
+querySingleMaybeDyn :: (Monad m) => DynamicQuery a -> SystemT m (Maybe a)
+querySingleMaybeDyn q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+  case V.viewSingle qf $ archetypes w of
+    Just v -> do
+      let (o, v') = runIdentity $ V.mapSingleDyn q v
+      _ <- f $ V.unview v'
+      return o
+    Nothing -> return Nothing
+
+-- | Map a single entity with a `DynamicQueryT`.
+--
+-- @since 0.11
+querySingleMaybeDynT :: (Monad m) => DynamicQueryT m a -> SystemT m (Maybe a)
+querySingleMaybeDynT q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+  case V.viewSingle qf $ archetypes w of
+    Just v -> do
+      (o, v') <- lift $ V.mapSingleDyn q v
+      _ <- f $ V.unview v'
+      return o
+    Nothing -> return Nothing
+
+readQueryDyn :: (Monad m) => DynamicQuery a -> SystemT m [a]
+readQueryDyn q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+      !v = V.view qf $ archetypes w
+  return $
+    runIdentity $
+      if V.null v
+        then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities w}
+        else V.allDyn q v
+
+readQueryDynT :: (Monad m) => DynamicQueryT m a -> SystemT m [a]
+readQueryDynT q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+      !v = V.view qf $ archetypes w
+  lift $
+    if V.null v
+      then readDynQuery q $ A.empty {A.entities = Map.keysSet $ entities w}
+      else V.allDyn q v
+
+-- | Match entities with a `QueryT`.
+--
+-- @since 0.11
+readQueryEntities :: (Monad m) => [EntityID] -> Query a -> SystemT m [a]
+readQueryEntities es q = fromQuery q >>= readQueryEntitiesDyn es
+
+-- | Match entities with a `QueryT`.
+--
+-- @since 0.11
+readQueryEntitiesT :: (Monad m) => [EntityID] -> QueryT m a -> SystemT m [a]
+readQueryEntitiesT es q = fromQueryT q >>= readQueryEntitiesDynT es
+
+readQueryEntitiesDyn :: (Monad m) => [EntityID] -> DynamicQuery a -> SystemT m [a]
+readQueryEntitiesDyn es q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+      !v = V.view qf $ archetypes w
+  return . runIdentity $
+    if V.null v
+      then readDynQueryEntities es q $ A.empty {A.entities = Map.keysSet $ entities w}
+      else V.allDyn q v
+
+readQueryEntitiesDynT :: (Monad m) => [EntityID] -> DynamicQueryT m a -> SystemT m [a]
+readQueryEntitiesDynT es q = System $ Once . Task $ \f -> do
+  w <- f id
+  let qf = queryFilter q
+      !v = V.view qf $ archetypes w
+  lift $
+    if V.null v
+      then readDynQueryEntities es q $ A.empty {A.entities = Map.keysSet $ entities w}
+      else V.allDyn q v
+
+-- | Convert a `Query` to a `SystemT`.
+--
+-- @since 0.11
+fromQuery :: Query a -> SystemT m (DynamicQuery a)
+fromQuery q = System $ Once . Task $ \f -> do
+  w <- f id
+  let (cs', dynQ) = runQuery q $ components w
+  _ <- f $ const w {components = cs'}
+  return dynQ
+
+-- | Convert a `QueryT` to a `SystemT`.
+--
+-- @since 0.11
+fromQueryT :: (Monad m) => QueryT m a -> SystemT m (DynamicQueryT m a)
+fromQueryT q = System $ Once . Task $ \f -> do
+  w <- f id
+  let (cs', dynQ) = runQuery q $ components w
+  _ <- f $ const w {components = cs'}
+  return dynQ
+
+runSystemT ::
+  (MonadTrans t, Monad (t m), Monad m) =>
+  SystemT m a ->
+  ((Entities -> Entities) -> t m Entities) ->
+  t m a
+runSystemT (System s) = runJob s
+
+runJob ::
+  (MonadTrans t, Monad (t m), Monad m) =>
+  Job t m a ->
+  ((Entities -> Entities) -> t m Entities) ->
+  t m a
+runJob (Pure a) _ = return a
+runJob (Map f' s') f = f' <$> runJob s' f
+runJob (Ap f' a) f = runJob f' f <*> runJob a f
+runJob (Bind a f') f = runJob a f >>= \a' -> runJob (f' a') f
+runJob (Once (Task t)) f = t f
+
+concurrently :: SystemT IO a -> ((Entities -> Entities) -> IO Entities) -> IO a
+concurrently (System s) f = runJobConcurrently s $ lift . f
+
+runJobConcurrently :: Job IdentityT IO a -> ((Entities -> Entities) -> IdentityT IO Entities) -> IO a
+runJobConcurrently (Pure a) _ = return a
+runJobConcurrently (Map f' s') f = f' <$> runJobConcurrently s' f
+runJobConcurrently (Ap f' a) f = do
+  aVar <- newEmptyMVar
+  fVar <- newEmptyMVar
+  _ <- forkIO $ do
+    f'' <- runJobConcurrently f' f
+    putMVar fVar f''
+  _ <- forkIO $ do
+    a' <- runJobConcurrently a f
+    putMVar aVar a'
+  a' <- takeMVar aVar
+  f'' <- takeMVar fVar
+  return $ f'' a'
+runJobConcurrently (Bind a f') f = runJobConcurrently a f >>= \a' -> runJobConcurrently (f' a') f
+runJobConcurrently (Once (Task t)) f = runIdentityT $ t f

@@ -1,127 +1,127 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module      : Aztecs.ECS.View--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.View-  ( View (..),-    view,-    viewSingle,-    null,-    unview,-    allDyn,-    singleDyn,-    mapDyn,-    mapSingleDyn,-  )-where--import Aztecs.ECS.Query.Dynamic (DynamicQueryT (..), QueryFilter (filterWith, filterWithout), readDynQuery, runDynQuery)-import Aztecs.ECS.World.Archetypes-import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Entities (Entities)-import qualified Aztecs.ECS.World.Entities as E-import Data.Foldable (foldl', foldlM)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Prelude hiding (null)---- | View into a `World`, containing a subset of archetypes.------ @since 0.9-newtype View = View-  { -- | Archetypes contained in this view.-    ---    -- @since 0.9-    viewArchetypes :: Map ArchetypeID Node-  }-  deriving (Show, Semigroup, Monoid)---- | View into all archetypes containing the provided component IDs.------ @since 0.9-view :: QueryFilter -> Archetypes -> View-view qf as = View $ AS.find (filterWith qf) (filterWithout qf) as---- | View into a single archetype containing the provided component IDs.------ @since 0.9-viewSingle :: QueryFilter -> Archetypes -> Maybe View-viewSingle qf as = case Map.toList $ AS.find (filterWith qf) (filterWithout qf) as of-  [a] -> Just . View $ uncurry Map.singleton a-  _ -> Nothing---- | @True@ if the `View` is empty.------ @since 0.9-null :: View -> Bool-null = Map.null . viewArchetypes---- | "Un-view" a `View` back into a `World`.------ @since 0.9-unview :: View -> Entities -> Entities-unview v es =-  es-    { E.archetypes =-        foldl'-          (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)})-          (E.archetypes es)-          (Map.toList $ viewArchetypes v)-    }---- | Query all matching entities in a `View`.------ @since 0.9-allDyn :: (Monad m) => DynamicQueryT m a -> View -> m [a]-allDyn q v =-  foldlM-    ( \acc n -> do-        as <- readDynQuery q $ nodeArchetype n-        return $ as ++ acc-    )-    []-    (viewArchetypes v)---- | Query all matching entities in a `View`.------ @since 0.9-singleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a)-singleDyn q v = do-  as <- allDyn q v-  return $ case as of-    [a] -> Just a-    _ -> Nothing---- | Map all matching entities in a `View`.------ @since 0.9-mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m ([a], View)-mapDyn q v = do-  (as, arches) <--    foldlM-      ( \(acc, archAcc) (aId, n) -> do-          (as', arch') <- runDynQuery q $ nodeArchetype n-          return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)-      )-      ([], Map.empty)-      (Map.toList $ viewArchetypes v)-  return (as, View arches)---- | Map a single matching entity in a `View`.------ @since 0.9-mapSingleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a, View)-mapSingleDyn q v = do-  (as, arches) <- mapDyn q v-  return $ case as of-    [a] -> (Just a, arches)-    _ -> (Nothing, arches)+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+-- Module      : Aztecs.ECS.View
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.View
+  ( View (..),
+    view,
+    viewSingle,
+    null,
+    unview,
+    allDyn,
+    singleDyn,
+    mapDyn,
+    mapSingleDyn,
+  )
+where
+
+import Aztecs.ECS.Query.Dynamic
+import Aztecs.ECS.World.Archetypes
+import qualified Aztecs.ECS.World.Archetypes as AS
+import Aztecs.ECS.World.Entities (Entities)
+import qualified Aztecs.ECS.World.Entities as E
+import Data.Foldable (foldl', foldlM)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Prelude hiding (null)
+
+-- | View into a `World`, containing a subset of archetypes.
+--
+-- @since 0.9
+newtype View = View
+  { -- | Archetypes contained in this view.
+    --
+    -- @since 0.9
+    viewArchetypes :: Map ArchetypeID Node
+  }
+  deriving (Show, Semigroup, Monoid)
+
+-- | View into all archetypes containing the provided component IDs.
+--
+-- @since 0.9
+view :: QueryFilter -> Archetypes -> View
+view qf as = View $ AS.find (filterWith qf) (filterWithout qf) as
+
+-- | View into a single archetype containing the provided component IDs.
+--
+-- @since 0.9
+viewSingle :: QueryFilter -> Archetypes -> Maybe View
+viewSingle qf as = case Map.toList $ AS.find (filterWith qf) (filterWithout qf) as of
+  [a] -> Just . View $ uncurry Map.singleton a
+  _ -> Nothing
+
+-- | @True@ if the `View` is empty.
+--
+-- @since 0.9
+null :: View -> Bool
+null = Map.null . viewArchetypes
+
+-- | "Un-view" a `View` back into a `World`.
+--
+-- @since 0.9
+unview :: View -> Entities -> Entities
+unview v es =
+  es
+    { E.archetypes =
+        foldl'
+          (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)})
+          (E.archetypes es)
+          (Map.toList $ viewArchetypes v)
+    }
+
+-- | Query all matching entities in a `View`.
+--
+-- @since 0.9
+allDyn :: (Monad m) => DynamicQueryT m a -> View -> m [a]
+allDyn q v =
+  foldlM
+    ( \acc n -> do
+        as <- readDynQuery q $ nodeArchetype n
+        return $ as ++ acc
+    )
+    []
+    (viewArchetypes v)
+
+-- | Query all matching entities in a `View`.
+--
+-- @since 0.9
+singleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a)
+singleDyn q v = do
+  as <- allDyn q v
+  return $ case as of
+    [a] -> Just a
+    _ -> Nothing
+
+-- | Map all matching entities in a `View`.
+--
+-- @since 0.9
+mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m ([a], View)
+mapDyn q v = do
+  (as, arches) <-
+    foldlM
+      ( \(acc, archAcc) (aId, n) -> do
+          (as', arch') <- runDynQuery q $ nodeArchetype n
+          return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)
+      )
+      ([], Map.empty)
+      (Map.toList $ viewArchetypes v)
+  return (as, View arches)
+
+-- | Map a single matching entity in a `View`.
+--
+-- @since 0.9
+mapSingleDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Maybe a, View)
+mapSingleDyn q v = do
+  (as, arches) <- mapDyn q v
+  return $ case as of
+    [a] -> (Just a, arches)
+    _ -> (Nothing, arches)

@@ -1,105 +1,105 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.World--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World-  ( World (..),-    empty,-    spawn,-    spawnEmpty,-    insert,-    lookup,-    remove,-    removeWithId,-    despawn,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Bundle-import Aztecs.ECS.World.Entities (Entities)-import qualified Aztecs.ECS.World.Entities as E-import Control.DeepSeq-import Data.Dynamic-import Data.IntMap (IntMap)-import GHC.Generics-import Prelude hiding (lookup)---- | World of entities and their components.------ @since 0.9-data World = World-  { -- | Entities and their components.-    ---    -- @since 0.9-    entities :: !Entities,-    -- | Next unique entity identifier.-    ---    -- @since 0.9-    nextEntityId :: !EntityID-  }-  deriving (Show, Generic, NFData)---- | Empty `World`.------ @since 0.9-empty :: World-empty =-  World-    { entities = E.empty,-      nextEntityId = EntityID 0-    }---- | Spawn a `Bundle` into the `World`.------ @since 0.9-spawn :: Bundle -> World -> (EntityID, World)-spawn b w =-  let e = nextEntityId w-   in (e, w {entities = E.spawn e b $ entities w, nextEntityId = EntityID $ unEntityId e + 1})---- | Spawn an empty entity.------ @since 0.9-spawnEmpty :: World -> (EntityID, World)-spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID $ unEntityId e + 1})---- | Insert a `Bundle` into an entity.------ @since 0.9-insert :: EntityID -> Bundle -> World -> World-insert e c w = w {entities = E.insert e c (entities w)}---- | Lookup a component in an entity.------ @since 0.9-lookup :: forall a. (Component a) => EntityID -> World -> Maybe a-lookup e w = E.lookup e $ entities w---- | Remove a component from an entity.------ @since 0.9-remove :: forall a. (Component a) => EntityID -> World -> (Maybe a, World)-remove e w = let (a, es) = E.remove e (entities w) in (a, w {entities = es})---- | Remove a component from an entity with its `ComponentID`.------ @since 0.9-removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> World -> (Maybe a, World)-removeWithId e cId w = let (a, es) = E.removeWithId e cId (entities w) in (a, w {entities = es})---- | Despawn an entity, returning its components.-despawn :: EntityID -> World -> (IntMap Dynamic, World)-despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es})+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.World
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World
+  ( World (..),
+    empty,
+    spawn,
+    spawnEmpty,
+    insert,
+    lookup,
+    remove,
+    removeWithId,
+    despawn,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.World.Bundle
+import Aztecs.ECS.World.Entities (Entities)
+import qualified Aztecs.ECS.World.Entities as E
+import Control.DeepSeq
+import Data.Dynamic
+import Data.IntMap (IntMap)
+import GHC.Generics
+import Prelude hiding (lookup)
+
+-- | World of entities and their components.
+--
+-- @since 0.9
+data World = World
+  { -- | Entities and their components.
+    --
+    -- @since 0.9
+    entities :: !Entities,
+    -- | Next unique entity identifier.
+    --
+    -- @since 0.9
+    nextEntityId :: !EntityID
+  }
+  deriving (Show, Generic, NFData)
+
+-- | Empty `World`.
+--
+-- @since 0.9
+empty :: World
+empty =
+  World
+    { entities = E.empty,
+      nextEntityId = EntityID 0
+    }
+
+-- | Spawn a `Bundle` into the `World`.
+--
+-- @since 0.9
+spawn :: Bundle -> World -> (EntityID, World)
+spawn b w =
+  let e = nextEntityId w
+   in (e, w {entities = E.spawn e b $ entities w, nextEntityId = EntityID $ unEntityId e + 1})
+
+-- | Spawn an empty entity.
+--
+-- @since 0.9
+spawnEmpty :: World -> (EntityID, World)
+spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID $ unEntityId e + 1})
+
+-- | Insert a `Bundle` into an entity.
+--
+-- @since 0.9
+insert :: EntityID -> Bundle -> World -> World
+insert e c w = w {entities = E.insert e c (entities w)}
+
+-- | Lookup a component in an entity.
+--
+-- @since 0.9
+lookup :: forall a. (Component a) => EntityID -> World -> Maybe a
+lookup e w = E.lookup e $ entities w
+
+-- | Remove a component from an entity.
+--
+-- @since 0.9
+remove :: forall a. (Component a) => EntityID -> World -> (Maybe a, World)
+remove e w = let (a, es) = E.remove e (entities w) in (a, w {entities = es})
+
+-- | Remove a component from an entity with its `ComponentID`.
+--
+-- @since 0.9
+removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> World -> (Maybe a, World)
+removeWithId e cId w = let (a, es) = E.removeWithId e cId (entities w) in (a, w {entities = es})
+
+-- | Despawn an entity, returning its components.
+despawn :: EntityID -> World -> (IntMap Dynamic, World)
+despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es})

@@ -1,301 +1,299 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.World.Archetype--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Archetype-  ( Archetype (..),-    empty,-    singleton,-    lookupComponent,-    lookupComponents,-    lookupComponentsAsc,-    lookupComponentsAscMaybe,-    lookupStorage,-    member,-    remove,-    removeStorages,-    insertComponent,-    insertComponents,-    insertAscList,-    map,-    mapM,-    zipWith,-    zipWithM,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import qualified Aztecs.ECS.World.Storage as S-import Aztecs.ECS.World.Storage.Dynamic-import qualified Aztecs.ECS.World.Storage.Dynamic as S-import Control.DeepSeq-import Control.Monad.Writer-  ( MonadTrans (..),-    MonadWriter (..),-    WriterT (..),-    runWriter,-  )-import Data.Dynamic-import Data.Foldable-import Data.IntMap (IntMap)-import qualified Data.IntMap.Strict as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics-import Prelude hiding (map, mapM, zipWith)---- | Archetype of entities and components.--- An archetype is guranteed to contain one of each stored component per entity.------ @since 0.9-data Archetype = Archetype-  { -- | Component storages.-    ---    -- @since 0.9-    storages :: !(IntMap DynamicStorage),-    -- | Entities stored in this archetype.-    ---    -- @since 0.9-    entities :: !(Set EntityID)-  }-  deriving (Show, Generic, NFData)--instance Semigroup Archetype where-  a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b}--instance Monoid Archetype where-  mempty = empty---- | Empty archetype.------ @since 0.9-empty :: Archetype-empty = Archetype {storages = IntMap.empty, entities = Set.empty}---- | Archetype with a single entity.------ @since 0.9-singleton :: EntityID -> Archetype-singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e}---- | Lookup a component `Storage` by its `ComponentID`.------ @since 0.9-{-# INLINE lookupStorage #-}-lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a)-lookupStorage cId w = do-  !dynS <- IntMap.lookup (unComponentId cId) $ storages w-  fromDynamic $ storageDyn dynS---- | Lookup a component by its `EntityID` and `ComponentID`.------ @since 0.9-{-# INLINE lookupComponent #-}-lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a-lookupComponent e cId w = lookupComponents cId w Map.!? e---- | Lookup all components by their `ComponentID`.------ @since 0.9-{-# INLINE lookupComponents #-}-lookupComponents :: (Component a) => ComponentID -> Archetype -> Map EntityID a-lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of-  Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) as-  Nothing -> Map.empty---- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.------ @since 0.9-{-# INLINE lookupComponentsAsc #-}-lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> [a]-lookupComponentsAsc cId = fromMaybe [] . lookupComponentsAscMaybe cId---- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.------ @since 0.9-{-# INLINE lookupComponentsAscMaybe #-}-lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe [a]-lookupComponentsAscMaybe cId arch = S.toAscList <$> lookupStorage @a cId arch---- | Insert a component into the archetype.--- This assumes the archetype contains one of each stored component per entity.------ @since 0.9-insertComponent ::-  forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype-insertComponent e cId c arch =-  let !storage =-        S.fromAscList @a @(StorageT a) . Map.elems . Map.insert e c $ lookupComponents cId arch-   in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}---- | @True@ if this archetype contains an entity with the provided `ComponentID`.------ @since 0.9-member :: ComponentID -> Archetype -> Bool-member cId = IntMap.member (unComponentId cId) . storages---- | Map a list of components with a function and a component storage.------ @since 0.11-{-# INLINE map #-}-map ::-  forall a. (Component a) => (a -> a) -> ComponentID -> Archetype -> ([a], Archetype)-map f cId arch =-  let go maybeDyn = case maybeDyn of-        Just dyn -> case fromDynamic $ storageDyn dyn of-          Just s -> do-            let !(as, s') = S.map @a @(StorageT a) f s-            tell as-            return $ Just $ dyn {storageDyn = toDyn s'}-          Nothing -> return maybeDyn-        Nothing -> return Nothing-      !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch-   in (cs, arch {storages = storages'})---- | Map a list of components with a monadic function.------ @since 0.11-{-# INLINE mapM #-}-mapM ::-  forall m a.-  (Monad m, Component a) =>-  (a -> m a) ->-  ComponentID ->-  Archetype ->-  m ([a], Archetype)-mapM f cId arch = do-  let go maybeDyn = case maybeDyn of-        Just dyn -> case fromDynamic $ storageDyn dyn of-          Just s -> do-            (as, s') <- lift $ S.mapM @a @(StorageT a) f s-            tell as-            return $ Just $ dyn {storageDyn = toDyn s'}-          Nothing -> return maybeDyn-        Nothing -> return Nothing-  (storages', cs) <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch-  return (cs, arch {storages = storages'})---- | Zip a list of components with a function.------ @since 0.9-{-# INLINE zipWith #-}-zipWith ::-  forall a b c.-  (Component c) =>-  [a] ->-  (a -> c -> (b, c)) ->-  ComponentID ->-  Archetype ->-  ([(b, c)], Archetype)-zipWith as f cId arch =-  let go maybeDyn = case maybeDyn of-        Just dyn -> case fromDynamic $ storageDyn dyn of-          Just s -> do-            let !(acs, s') = S.zipWith @c @(StorageT c) f as s-            tell acs-            return $ Just $ dyn {storageDyn = toDyn s'}-          Nothing -> return maybeDyn-        Nothing -> return Nothing-      !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch-   in (cs, arch {storages = storages'})---- | Zip a list of components with a monadic function .------ @since 0.9-zipWithM ::-  forall m a b c.-  (Applicative m, Component c) =>-  [a] ->-  (a -> c -> m (b, c)) ->-  ComponentID ->-  Archetype ->-  m ([(b, c)], Archetype)-zipWithM as f cId arch = do-  let go maybeDyn = case maybeDyn of-        Just dyn -> case fromDynamic $ storageDyn dyn of-          Just s ->-            WriterT $-              fmap-                (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs))-                (S.zipWithM @c @(StorageT c) f as s)-          Nothing -> pure maybeDyn-        Nothing -> pure Nothing-  res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch-  return (snd res, arch {storages = fst res})---- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`.------ @since 0.9-{-# INLINE insertAscList #-}-insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype-insertAscList cId as arch =-  let !storage = dynStorage @a $ S.fromAscList @a @(StorageT a) as-   in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch}---- | Remove an entity from an archetype, returning its components.------ @since 0.9-remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype)-remove e arch =-  let go (dynAcc, archAcc) (cId, dynS) =-        let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS-            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs-            dynS' = S.fromAscListDyn (Map.elems cs') dynS-            !dynAcc' = case dynA of-              Just d -> IntMap.insert cId d dynAcc-              Nothing -> dynAcc-         in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})-      arch' = arch {entities = Set.delete e $ entities arch}-   in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'---- | Remove an entity from an archetype, returning its component storages.------ @since 0.9-removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype)-removeStorages e arch =-  let go (dynAcc, archAcc) (cId, dynS) =-        let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS-            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs-            dynS' = S.fromAscListDyn (Map.elems cs') dynS-            !dynAcc' = case dynA of-              Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc-              Nothing -> dynAcc-         in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})-      arch' = arch {entities = Set.delete e $ entities arch}-   in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'---- | Insert a map of component storages and their `EntityID` into the archetype.------ @since 0.9-insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype-insertComponents e cs arch =-  let f archAcc (itemCId, dyn) =-        let storages' = IntMap.adjust go itemCId (storages archAcc)-            es = Set.toList $ entities archAcc-            go s =-              let ecs = Map.elems . Map.insert e dyn . Map.fromAscList . zip es $ toAscListDyn s-               in fromAscListDyn ecs s-         in archAcc {storages = storages', entities = Set.insert e $ entities archAcc}-   in foldl' f arch (IntMap.toList cs)+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Archetype
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Archetype
+  ( Archetype (..),
+    empty,
+    singleton,
+    lookupComponent,
+    lookupComponents,
+    lookupComponentsAsc,
+    lookupComponentsAscMaybe,
+    lookupStorage,
+    member,
+    remove,
+    removeStorages,
+    insertComponent,
+    insertComponents,
+    insertAscList,
+    map,
+    mapM,
+    zipMap,
+    zipMapM,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import qualified Aztecs.ECS.World.Storage as S
+import Aztecs.ECS.World.Storage.Dynamic
+import qualified Aztecs.ECS.World.Storage.Dynamic as S
+import Control.DeepSeq
+import Control.Monad.Writer
+  ( MonadTrans (..),
+    MonadWriter (..),
+    WriterT (..),
+    runWriter,
+  )
+import Data.Dynamic
+import Data.Foldable
+import Data.IntMap (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import GHC.Generics
+import Prelude hiding (map, mapM, zipWith)
+
+-- | Archetype of entities and components.
+-- An archetype is guranteed to contain one of each stored component per entity.
+--
+-- @since 0.9
+data Archetype = Archetype
+  { -- | Component storages.
+    --
+    -- @since 0.9
+    storages :: !(IntMap DynamicStorage),
+    -- | Entities stored in this archetype.
+    --
+    -- @since 0.9
+    entities :: !(Set EntityID)
+  }
+  deriving (Show, Generic)
+
+instance Semigroup Archetype where
+  a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b}
+
+instance Monoid Archetype where
+  mempty = empty
+
+instance NFData Archetype where
+  rnf = rnf . entities
+
+-- | Empty archetype.
+--
+-- @since 0.9
+empty :: Archetype
+empty = Archetype {storages = IntMap.empty, entities = Set.empty}
+
+-- | Archetype with a single entity.
+--
+-- @since 0.9
+singleton :: EntityID -> Archetype
+singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e}
+
+-- | Lookup a component `Storage` by its `ComponentID`.
+--
+-- @since 0.9
+{-# INLINE lookupStorage #-}
+lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a)
+lookupStorage cId w = do
+  dynS <- IntMap.lookup (unComponentId cId) $ storages w
+  fromDynamic $ storageDyn dynS
+
+-- | Lookup a component by its `EntityID` and `ComponentID`.
+--
+-- @since 0.9
+{-# INLINE lookupComponent #-}
+lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a
+lookupComponent e cId w = lookupComponents cId w Map.!? e
+
+-- | Lookup all components by their `ComponentID`.
+--
+-- @since 0.9
+{-# INLINE lookupComponents #-}
+lookupComponents :: (Component a) => ComponentID -> Archetype -> Map EntityID a
+lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of
+  Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) as
+  Nothing -> Map.empty
+
+-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.
+--
+-- @since 0.9
+{-# INLINE lookupComponentsAsc #-}
+lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> [a]
+lookupComponentsAsc cId = fromMaybe [] . lookupComponentsAscMaybe cId
+
+-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.
+--
+-- @since 0.9
+{-# INLINE lookupComponentsAscMaybe #-}
+lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe [a]
+lookupComponentsAscMaybe cId arch = S.toAscList <$> lookupStorage @a cId arch
+
+-- | Insert a component into the archetype.
+-- This assumes the archetype contains one of each stored component per entity.
+--
+-- @since 0.9
+insertComponent ::
+  forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype
+insertComponent e cId c arch =
+  let !storage =
+        S.fromAscList @a @(StorageT a) . Map.elems . Map.insert e c $ lookupComponents cId arch
+   in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}
+
+-- | @True@ if this archetype contains an entity with the provided `ComponentID`.
+--
+-- @since 0.9
+{-# INLINE member #-}
+member :: ComponentID -> Archetype -> Bool
+member cId = IntMap.member (unComponentId cId) . storages
+
+-- | Map a list of components with a function and a component storage.
+--
+-- @since 0.11
+{-# INLINE map #-}
+map ::
+  forall a. (Component a) => (a -> a) -> ComponentID -> Archetype -> ([a], Archetype)
+map f cId arch =
+  let go maybeDyn = case maybeDyn of
+        Just dyn -> case fromDynamic $ storageDyn dyn of
+          Just s -> do
+            let !(as, s') = S.map @a @(StorageT a) f s
+            tell as
+            return $ Just $ dyn {storageDyn = toDyn s'}
+          Nothing -> return maybeDyn
+        Nothing -> return Nothing
+      !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch
+   in (cs, arch {storages = storages'})
+
+-- | Map a list of components with a monadic function.
+--
+-- @since 0.11
+{-# INLINE mapM #-}
+mapM ::
+  forall m a.
+  (Monad m, Component a) =>
+  (a -> m a) ->
+  ComponentID ->
+  Archetype ->
+  m ([a], Archetype)
+mapM f cId arch = do
+  let go maybeDyn = case maybeDyn of
+        Just dyn -> case fromDynamic $ storageDyn dyn of
+          Just s -> do
+            (as, s') <- lift $ S.mapM @a @(StorageT a) f s
+            tell as
+            return $ Just $ dyn {storageDyn = toDyn s'}
+          Nothing -> return maybeDyn
+        Nothing -> return Nothing
+  (storages', cs) <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch
+  return (cs, arch {storages = storages'})
+
+-- | Zip a list of components with a function.
+--
+-- @since 0.9
+{-# INLINE zipMap #-}
+zipMap ::
+  forall a b c.
+  (Component c) =>
+  [a] ->
+  (a -> c -> (b, c)) ->
+  ComponentID ->
+  Archetype ->
+  ([(b, c)], Archetype)
+zipMap as f cId arch =
+  let go maybeDyn = case maybeDyn of
+        Just dyn -> case fromDynamic $ storageDyn dyn of
+          Just s -> do
+            let (acs, s') = S.zipWith @c @(StorageT c) f as s
+            tell acs
+            return $ Just $ dyn {storageDyn = toDyn s'}
+          Nothing -> return maybeDyn
+        Nothing -> return Nothing
+      (storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch
+   in (cs, arch {storages = storages'})
+
+-- | Zip a list of components with a monadic function .
+--
+-- @since 0.9
+zipMapM ::
+  forall m a b c.
+  (Applicative m, Component c) =>
+  [a] ->
+  (a -> c -> m (b, c)) ->
+  ComponentID ->
+  Archetype ->
+  m ([(b, c)], Archetype)
+zipMapM as f cId arch = do
+  let go maybeDyn = case maybeDyn of
+        Just dyn -> case fromDynamic $ storageDyn dyn of
+          Just s ->
+            WriterT $
+              fmap
+                (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs))
+                (S.zipWithM @c @(StorageT c) f as s)
+          Nothing -> pure maybeDyn
+        Nothing -> pure Nothing
+  res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch
+  return (snd res, arch {storages = fst res})
+
+-- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`.
+--
+-- @since 0.9
+{-# INLINE insertAscList #-}
+insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype
+insertAscList cId as arch =
+  let !storage = dynStorage @a $ S.fromAscList @a @(StorageT a) as
+   in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch}
+
+-- | Remove an entity from an archetype, returning its components.
+--
+-- @since 0.9
+remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype)
+remove e arch =
+  let go (dynAcc, archAcc) (cId, dynS) =
+        let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS
+            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs
+            dynS' = S.fromAscListDyn (Map.elems cs') dynS
+            !dynAcc' = case dynA of
+              Just d -> IntMap.insert cId d dynAcc
+              Nothing -> dynAcc
+         in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})
+      arch' = arch {entities = Set.delete e $ entities arch}
+   in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'
+
+-- | Remove an entity from an archetype, returning its component storages.
+--
+-- @since 0.9
+removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype)
+removeStorages e arch =
+  let go (dynAcc, archAcc) (cId, dynS) =
+        let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS
+            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs
+            dynS' = S.fromAscListDyn (Map.elems cs') dynS
+            !dynAcc' = case dynA of
+              Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc
+              Nothing -> dynAcc
+         in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})
+      arch' = arch {entities = Set.delete e $ entities arch}
+   in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'
+
+-- | Insert a map of component storages and their `EntityID` into the archetype.
+--
+-- @since 0.9
+insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype
+insertComponents e cs arch =
+  let f archAcc (itemCId, dyn) =
+        let storages' = IntMap.adjust go itemCId (storages archAcc)
+            es = Set.toList $ entities archAcc
+            go s =
+              let ecs = Map.elems . Map.insert e dyn . Map.fromAscList . zip es $ toAscListDyn s
+               in fromAscListDyn ecs s
+         in archAcc {storages = storages', entities = Set.insert e $ entities archAcc}
+   in foldl' f arch (IntMap.toList cs)

@@ -1,245 +1,245 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.World.Archetypes--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Archetypes-  ( ArchetypeID (..),-    Node (..),-    Archetypes (..),-    empty,-    insertArchetype,-    lookupArchetypeId,-    findArchetypeIds,-    lookup,-    find,-    adjustArchetype,-    insert,-    remove,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Archetype (Archetype (..))-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Bundle.Dynamic-import Aztecs.ECS.World.Storage.Dynamic-import Control.DeepSeq (NFData (..))-import Data.Dynamic-import Data.Foldable (foldl')-import qualified Data.IntMap.Strict as IntMap-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics-import Prelude hiding (all, lookup, map)---- | `Archetype` ID.------ @since 0.9-newtype ArchetypeID = ArchetypeID-  { -- | Unique integer identifier.-    ---    -- @since 0.9-    unArchetypeId :: Int-  }-  deriving newtype (Eq, Ord, Show, NFData)---- | Node in `Archetypes`.------ @since 0.9-data Node = Node-  { -- | Unique set of `ComponentID`s of this `Node`.-    ---    -- @since 0.9-    nodeComponentIds :: !(Set ComponentID),-    -- | `Archetype` of this `Node`.-    ---    -- @since 0.9-    nodeArchetype :: !Archetype-  }-  deriving (Show, Generic, NFData)---- | `Archetype` map.-data Archetypes = Archetypes-  { -- | Archetype nodes in the map.-    ---    -- @since 0.9-    nodes :: !(Map ArchetypeID Node),-    -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.-    ---    -- @since 0.9-    archetypeIds :: !(Map (Set ComponentID) ArchetypeID),-    -- | Next unique `ArchetypeID`.-    ---    -- @since 0.9-    nextArchetypeId :: !ArchetypeID,-    -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.-    ---    -- @since 0.9-    componentIds :: !(Map ComponentID (Set ArchetypeID))-  }-  deriving (Show, Generic, NFData)---- | Empty `Archetypes`.------ @since 0.9-empty :: Archetypes-empty =-  Archetypes-    { nodes = mempty,-      archetypeIds = mempty,-      nextArchetypeId = ArchetypeID 0,-      componentIds = mempty-    }---- | Insert an archetype by its set of `ComponentID`s.------ @since 0.9-insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)-insertArchetype cIds n arches =-  let aId = nextArchetypeId arches-   in ( aId,-        arches-          { nodes = Map.insert aId n (nodes arches),-            archetypeIds = Map.insert cIds aId (archetypeIds arches),-            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1),-            componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches)-          }-      )---- | Adjust an `Archetype` by its `ArchetypeID`.------ @since 0.9-adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes-adjustArchetype aId f arches =-  arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}---- | Find `ArchetypeID`s containing a set of `ComponentID`s.------ @since 0.11-findArchetypeIds :: Set ComponentID -> Set ComponentID -> Archetypes -> Set ArchetypeID-findArchetypeIds w wo arches =-  let !withIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems w)-      !withoutIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems wo)-      !withoutSet = foldl' Set.union Set.empty withoutIds-   in case withIds of-        (aId : aIds') -> foldl' Set.intersection aId aIds' `Set.difference` withoutSet-        [] -> Set.empty---- | Lookup `Archetype`s containing a set of `ComponentID`s.------ @since 0.9-find :: Set ComponentID -> Set ComponentID -> Archetypes -> Map ArchetypeID Node-find w wo arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds w wo arches)---- | Lookup an `ArchetypeID` by its set of `ComponentID`s.------ @since 0.9-lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID-lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches)---- | Lookup an `Archetype` by its `ArchetypeID`.------ @since 0.9-lookup :: ArchetypeID -> Archetypes -> Maybe Node-lookup aId arches = Map.lookup aId (nodes arches)---- | Insert a component into an entity with its `ComponentID`.------ @since 0.9-insert ::-  EntityID ->-  ArchetypeID ->-  Set ComponentID ->-  DynamicBundle ->-  Archetypes ->-  (Maybe ArchetypeID, Archetypes)-insert e aId cIds b arches = case lookup aId arches of-  Just node ->-    if Set.isSubsetOf cIds $ nodeComponentIds node-      then-        let go n = n {nodeArchetype = runDynamicBundle b e $ nodeArchetype n}-         in (Nothing, arches {nodes = Map.adjust go aId $ nodes arches})-      else-        let cIds' = cIds <> nodeComponentIds node-         in case lookupArchetypeId cIds' arches of-              Just nextAId ->-                let !(cs, arch) = A.remove e $ nodeArchetype node-                    node' = node {nodeArchetype = arch}-                    !nodes' = Map.insert aId node' $ nodes arches-                    adjustNode nextNode =-                      let nextArch = nodeArchetype nextNode-                          nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch}-                          !nextArch'' = A.insertComponents e cs nextArch'-                       in nextNode {nodeArchetype = runDynamicBundle b e nextArch''}-                 in (Just nextAId, arches {nodes = Map.adjust adjustNode nextAId nodes'})-              Nothing ->-                let !(s, arch) = A.removeStorages e $ nodeArchetype node-                    nodes' = Map.insert aId node {nodeArchetype = arch} $ nodes arches-                    !nextArch = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e}-                    !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch}-                    !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'}-                 in (Just nextAId, arches')-  Nothing -> (Nothing, arches)---- | Remove a component from an entity with its `ComponentID`.------ @since 0.9-remove ::-  (Component a) =>-  EntityID ->-  ArchetypeID ->-  ComponentID ->-  Archetypes ->-  (Maybe (a, ArchetypeID), Archetypes)-remove e aId cId arches = case lookup aId arches of-  Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of-    Just nextAId ->-      let !(cs, arch') = A.remove e (nodeArchetype node)-          !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}-          (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs-          go' archAcc (itemCId, dyn) =-            let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s-             in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)}-          go nextNode =-            nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')}-       in ( (,nextAId) <$> (a >>= fromDynamic),-            arches' {nodes = Map.adjust go nextAId (nodes arches')}-          )-    Nothing ->-      let !(cs, arch') = A.removeStorages e (nodeArchetype node)-          (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs-          !n =-            Node-              { nodeComponentIds = Set.insert cId (nodeComponentIds node),-                nodeArchetype = Archetype {storages = cs', entities = Set.singleton e}-              }-          !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches-          node' = node {nodeArchetype = arch'}-          removeDyn s =-            let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') $ toAscListDyn s-             in (res, fromAscListDyn $ Map.elems dyns)-       in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)),-            arches' {nodes = Map.insert aId node' (nodes arches')}-          )-  Nothing -> (Nothing, arches)+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Archetypes
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Archetypes
+  ( ArchetypeID (..),
+    Node (..),
+    Archetypes (..),
+    empty,
+    insertArchetype,
+    lookupArchetypeId,
+    findArchetypeIds,
+    lookup,
+    find,
+    adjustArchetype,
+    insert,
+    remove,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.World.Archetype (Archetype (..))
+import qualified Aztecs.ECS.World.Archetype as A
+import Aztecs.ECS.World.Bundle.Dynamic
+import Aztecs.ECS.World.Storage.Dynamic
+import Control.DeepSeq (NFData (..))
+import Data.Dynamic
+import Data.Foldable (foldl')
+import qualified Data.IntMap.Strict as IntMap
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import GHC.Generics
+import Prelude hiding (all, lookup, map)
+
+-- | `Archetype` ID.
+--
+-- @since 0.9
+newtype ArchetypeID = ArchetypeID
+  { -- | Unique integer identifier.
+    --
+    -- @since 0.9
+    unArchetypeId :: Int
+  }
+  deriving newtype (Eq, Ord, Show, NFData)
+
+-- | Node in `Archetypes`.
+--
+-- @since 0.9
+data Node = Node
+  { -- | Unique set of `ComponentID`s of this `Node`.
+    --
+    -- @since 0.9
+    nodeComponentIds :: !(Set ComponentID),
+    -- | `Archetype` of this `Node`.
+    --
+    -- @since 0.9
+    nodeArchetype :: !Archetype
+  }
+  deriving (Show, Generic, NFData)
+
+-- | `Archetype` map.
+data Archetypes = Archetypes
+  { -- | Archetype nodes in the map.
+    --
+    -- @since 0.9
+    nodes :: !(Map ArchetypeID Node),
+    -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.
+    --
+    -- @since 0.9
+    archetypeIds :: !(Map (Set ComponentID) ArchetypeID),
+    -- | Next unique `ArchetypeID`.
+    --
+    -- @since 0.9
+    nextArchetypeId :: !ArchetypeID,
+    -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.
+    --
+    -- @since 0.9
+    componentIds :: !(Map ComponentID (Set ArchetypeID))
+  }
+  deriving (Show, Generic, NFData)
+
+-- | Empty `Archetypes`.
+--
+-- @since 0.9
+empty :: Archetypes
+empty =
+  Archetypes
+    { nodes = mempty,
+      archetypeIds = mempty,
+      nextArchetypeId = ArchetypeID 0,
+      componentIds = mempty
+    }
+
+-- | Insert an archetype by its set of `ComponentID`s.
+--
+-- @since 0.9
+insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)
+insertArchetype cIds n arches =
+  let aId = nextArchetypeId arches
+   in ( aId,
+        arches
+          { nodes = Map.insert aId n (nodes arches),
+            archetypeIds = Map.insert cIds aId (archetypeIds arches),
+            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1),
+            componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches)
+          }
+      )
+
+-- | Adjust an `Archetype` by its `ArchetypeID`.
+--
+-- @since 0.9
+adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes
+adjustArchetype aId f arches =
+  arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}
+
+-- | Find `ArchetypeID`s containing a set of `ComponentID`s.
+--
+-- @since 0.11
+findArchetypeIds :: Set ComponentID -> Set ComponentID -> Archetypes -> Set ArchetypeID
+findArchetypeIds w wo arches =
+  let !withIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems w)
+      !withoutIds = mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems wo)
+      !withoutSet = foldl' Set.union Set.empty withoutIds
+   in case withIds of
+        (aId : aIds') -> foldl' Set.intersection aId aIds' `Set.difference` withoutSet
+        [] -> Set.empty
+
+-- | Lookup `Archetype`s containing a set of `ComponentID`s.
+--
+-- @since 0.9
+find :: Set ComponentID -> Set ComponentID -> Archetypes -> Map ArchetypeID Node
+find w wo arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds w wo arches)
+
+-- | Lookup an `ArchetypeID` by its set of `ComponentID`s.
+--
+-- @since 0.9
+lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID
+lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches)
+
+-- | Lookup an `Archetype` by its `ArchetypeID`.
+--
+-- @since 0.9
+lookup :: ArchetypeID -> Archetypes -> Maybe Node
+lookup aId arches = Map.lookup aId (nodes arches)
+
+-- | Insert a component into an entity with its `ComponentID`.
+--
+-- @since 0.9
+insert ::
+  EntityID ->
+  ArchetypeID ->
+  Set ComponentID ->
+  DynamicBundle ->
+  Archetypes ->
+  (Maybe ArchetypeID, Archetypes)
+insert e aId cIds b arches = case lookup aId arches of
+  Just node ->
+    if Set.isSubsetOf cIds $ nodeComponentIds node
+      then
+        let go n = n {nodeArchetype = runDynamicBundle b e $ nodeArchetype n}
+         in (Nothing, arches {nodes = Map.adjust go aId $ nodes arches})
+      else
+        let cIds' = cIds <> nodeComponentIds node
+         in case lookupArchetypeId cIds' arches of
+              Just nextAId ->
+                let !(cs, arch) = A.remove e $ nodeArchetype node
+                    node' = node {nodeArchetype = arch}
+                    !nodes' = Map.insert aId node' $ nodes arches
+                    adjustNode nextNode =
+                      let nextArch = nodeArchetype nextNode
+                          nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch}
+                          !nextArch'' = A.insertComponents e cs nextArch'
+                       in nextNode {nodeArchetype = runDynamicBundle b e nextArch''}
+                 in (Just nextAId, arches {nodes = Map.adjust adjustNode nextAId nodes'})
+              Nothing ->
+                let !(s, arch) = A.removeStorages e $ nodeArchetype node
+                    nodes' = Map.insert aId node {nodeArchetype = arch} $ nodes arches
+                    !nextArch = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e}
+                    !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch}
+                    !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'}
+                 in (Just nextAId, arches')
+  Nothing -> (Nothing, arches)
+
+-- | Remove a component from an entity with its `ComponentID`.
+--
+-- @since 0.9
+remove ::
+  (Component a) =>
+  EntityID ->
+  ArchetypeID ->
+  ComponentID ->
+  Archetypes ->
+  (Maybe (a, ArchetypeID), Archetypes)
+remove e aId cId arches = case lookup aId arches of
+  Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of
+    Just nextAId ->
+      let !(cs, arch') = A.remove e (nodeArchetype node)
+          !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}
+          (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs
+          go' archAcc (itemCId, dyn) =
+            let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s
+             in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)}
+          go nextNode =
+            nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')}
+       in ( (,nextAId) <$> (a >>= fromDynamic),
+            arches' {nodes = Map.adjust go nextAId (nodes arches')}
+          )
+    Nothing ->
+      let !(cs, arch') = A.removeStorages e (nodeArchetype node)
+          (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs
+          !n =
+            Node
+              { nodeComponentIds = Set.insert cId (nodeComponentIds node),
+                nodeArchetype = Archetype {storages = cs', entities = Set.singleton e}
+              }
+          !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches
+          node' = node {nodeArchetype = arch'}
+          removeDyn s =
+            let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') $ toAscListDyn s
+             in (res, fromAscListDyn $ Map.elems dyns)
+       in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)),
+            arches' {nodes = Map.insert aId node' (nodes arches')}
+          )
+  Nothing -> (Nothing, arches)

@@ -1,69 +1,69 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.World.Bundle--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Bundle-  ( Bundle (..),-    bundle,-    fromDynBundle,-    runBundle,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Archetype-import Aztecs.ECS.World.Bundle.Dynamic-import Aztecs.ECS.World.Components-import qualified Aztecs.ECS.World.Components as CS-import Data.Set (Set)-import qualified Data.Set as Set---- | Bundle of components.------ @since 0.9-newtype Bundle = Bundle-  { -- | Unwrap the bundle.-    ---    -- @since 0.9-    unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)-  }---- | @since 0.9-instance Monoid Bundle where-  mempty = Bundle (Set.empty,,mempty)---- | @since 0.9-instance Semigroup Bundle where-  Bundle b1 <> Bundle b2 = Bundle $ \cs ->-    let (cIds1, cs', d1) = b1 cs-        (cIds2, cs'', d2) = b2 cs'-     in (cIds1 <> cIds2, cs'', d1 <> d2)---- | @since 0.11-bundle :: forall a. (Component a) => a -> Bundle-bundle a = Bundle $ \cs ->-  let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', dynBundle cId a)--fromDynBundle :: DynamicBundle -> Bundle-fromDynBundle d = Bundle (Set.empty,,d)---- | Insert a bundle of components into an archetype.------ @since 0.9-runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype)-runBundle b cs eId arch =-  let !(_, cs', d) = unBundle b cs-      !arch' = runDynamicBundle d eId arch-   in (cs', arch')+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Bundle
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Bundle
+  ( Bundle (..),
+    bundle,
+    fromDynBundle,
+    runBundle,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.World.Archetype
+import Aztecs.ECS.World.Bundle.Dynamic
+import Aztecs.ECS.World.Components
+import qualified Aztecs.ECS.World.Components as CS
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-- | Bundle of components.
+--
+-- @since 0.9
+newtype Bundle = Bundle
+  { -- | Unwrap the bundle.
+    --
+    -- @since 0.9
+    unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)
+  }
+
+-- | @since 0.9
+instance Monoid Bundle where
+  mempty = Bundle (Set.empty,,mempty)
+
+-- | @since 0.9
+instance Semigroup Bundle where
+  Bundle b1 <> Bundle b2 = Bundle $ \cs ->
+    let (cIds1, cs', d1) = b1 cs
+        (cIds2, cs'', d2) = b2 cs'
+     in (cIds1 <> cIds2, cs'', d1 <> d2)
+
+-- | @since 0.11
+bundle :: forall a. (Component a) => a -> Bundle
+bundle a = Bundle $ \cs ->
+  let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', dynBundle cId a)
+
+fromDynBundle :: DynamicBundle -> Bundle
+fromDynBundle d = Bundle (Set.empty,,d)
+
+-- | Insert a bundle of components into an archetype.
+--
+-- @since 0.9
+runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype)
+runBundle b cs eId arch =
+  let !(_, cs', d) = unBundle b cs
+      !arch' = runDynamicBundle d eId arch
+   in (cs', arch')

@@ -1,30 +1,30 @@--- |--- Module      : Aztecs.ECS.World.Bundle.Dynamic--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), dynBundle) where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import Aztecs.ECS.World.Archetype---- | Dynamic bundle of components.------ @since 0.9-newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}---- | @since 0.9-instance Semigroup DynamicBundle where-  DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch)---- | @since 0.9-instance Monoid DynamicBundle where-  mempty = DynamicBundle $ \_ arch -> arch---- | @since 0.11-dynBundle :: (Component a) => ComponentID -> a -> DynamicBundle-dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch+-- |
+-- Module      : Aztecs.ECS.World.Bundle.Dynamic
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle (..), dynBundle) where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import Aztecs.ECS.World.Archetype
+
+-- | Dynamic bundle of components.
+--
+-- @since 0.9
+newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}
+
+-- | @since 0.9
+instance Semigroup DynamicBundle where
+  DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch)
+
+-- | @since 0.9
+instance Monoid DynamicBundle where
+  mempty = DynamicBundle $ \_ arch -> arch
+
+-- | @since 0.11
+dynBundle :: (Component a) => ComponentID -> a -> DynamicBundle
+dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch

@@ -1,84 +1,84 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      : Aztecs.ECS.World.Components--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Components-  ( ComponentID (..),-    Components (..),-    empty,-    lookup,-    insert,-    insert',-  )-where--import Aztecs.ECS.Component-import Control.DeepSeq-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Typeable-import GHC.Generics-import Prelude hiding (lookup)---- | Component ID map.------ @since 0.9-data Components = Components-  { -- | Map of component types to identifiers.-    ---    -- @since 0.9-    componentIds :: !(Map TypeRep ComponentID),-    -- | Next unique component identifier.-    ---    -- @since 0.9-    nextComponentId :: !ComponentID-  }-  deriving (Show, Generic, NFData)---- | Empty `Components`.------ @since 0.9-empty :: Components-empty =-  Components-    { componentIds = mempty,-      nextComponentId = ComponentID 0-    }---- | Lookup a component ID by type.------ @since 0.9-lookup :: forall a. (Typeable a) => Components -> Maybe ComponentID-lookup cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs)---- | Insert a component ID by type, if it does not already exist.------ @since 0.9-insert :: forall a. (Component a) => Components -> (ComponentID, Components)-insert cs = case lookup @a cs of-  Just cId -> (cId, cs)-  Nothing -> insert' @a cs---- | Insert a component ID by type.------ @since 0.9-insert' :: forall c. (Component c) => Components -> (ComponentID, Components)-insert' cs =-  let !cId = nextComponentId cs-   in ( cId,-        cs-          { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs),-            nextComponentId = ComponentID (unComponentId cId + 1)-          }-      )+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Components
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Components
+  ( ComponentID (..),
+    Components (..),
+    empty,
+    lookup,
+    insert,
+    insert',
+  )
+where
+
+import Aztecs.ECS.Component
+import Control.DeepSeq
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Typeable
+import GHC.Generics
+import Prelude hiding (lookup)
+
+-- | Component ID map.
+--
+-- @since 0.9
+data Components = Components
+  { -- | Map of component types to identifiers.
+    --
+    -- @since 0.9
+    componentIds :: !(Map TypeRep ComponentID),
+    -- | Next unique component identifier.
+    --
+    -- @since 0.9
+    nextComponentId :: !ComponentID
+  }
+  deriving (Show, Generic, NFData)
+
+-- | Empty `Components`.
+--
+-- @since 0.9
+empty :: Components
+empty =
+  Components
+    { componentIds = mempty,
+      nextComponentId = ComponentID 0
+    }
+
+-- | Lookup a component ID by type.
+--
+-- @since 0.9
+lookup :: forall a. (Typeable a) => Components -> Maybe ComponentID
+lookup cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs)
+
+-- | Insert a component ID by type, if it does not already exist.
+--
+-- @since 0.9
+insert :: forall a. (Component a) => Components -> (ComponentID, Components)
+insert cs = case lookup @a cs of
+  Just cId -> (cId, cs)
+  Nothing -> insert' @a cs
+
+-- | Insert a component ID by type.
+--
+-- @since 0.9
+insert' :: forall c. (Component c) => Components -> (ComponentID, Components)
+insert' cs =
+  let !cId = nextComponentId cs
+   in ( cId,
+        cs
+          { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs),
+            nextComponentId = ComponentID (unComponentId cId + 1)
+          }
+      )

@@ -1,206 +1,206 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.World.Entities--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Entities-  ( Entities (..),-    empty,-    spawn,-    spawnWithArchetypeId,-    insert,-    insertDyn,-    lookup,-    remove,-    removeWithId,-    despawn,-  )-where--import Aztecs.ECS.Component-import Aztecs.ECS.Entity-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..))-import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Bundle-import Aztecs.ECS.World.Bundle.Dynamic-import Aztecs.ECS.World.Components (Components (..))-import qualified Aztecs.ECS.World.Components as CS-import Control.DeepSeq-import Data.Dynamic-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics-import Prelude hiding (lookup)---- | World of entities and their components.------ @since 0.9-data Entities = Entities-  { -- | Archetypes.-    ---    -- @since 0.9-    archetypes :: !Archetypes,-    -- | Components.-    ---    -- @since 0.9-    components :: !Components,-    -- | Entities and their archetype identifiers.-    ---    -- @since 0.9-    entities :: !(Map EntityID ArchetypeID)-  }-  deriving (Show, Generic, NFData)---- | Empty `World`.------ @since 0.9-empty :: Entities-empty =-  Entities-    { archetypes = AS.empty,-      components = CS.empty,-      entities = mempty-    }---- | Spawn a `Bundle`.------ @since 0.9-spawn :: EntityID -> Bundle -> Entities -> Entities-spawn eId b w =-  let (cIds, components', dynB) = unBundle b (components w)-   in case AS.lookupArchetypeId cIds (archetypes w) of-        Just aId -> fromMaybe w $ do-          node <- AS.lookup aId $ archetypes w-          let arch' =-                runDynamicBundle-                  dynB-                  eId-                  ( (nodeArchetype node)-                      { A.entities = Set.insert eId . A.entities $ nodeArchetype node-                      }-                  )-          return-            w-              { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},-                components = components',-                entities = Map.insert eId aId (entities w)-              }-        Nothing ->-          let arch' = runDynamicBundle dynB eId $ A.singleton eId-              node' = Node {nodeComponentIds = cIds, nodeArchetype = arch'}-              (aId, arches) = AS.insertArchetype cIds node' $ archetypes w-           in w-                { archetypes = arches,-                  entities = Map.insert eId aId (entities w),-                  components = components'-                }---- | Spawn a `DynamicBundle` with a specified `ArchetypeID`.------ @since 0.9-spawnWithArchetypeId ::-  EntityID ->-  ArchetypeID ->-  DynamicBundle ->-  Entities ->-  Entities-spawnWithArchetypeId e aId b w =-  let f n = n {nodeArchetype = runDynamicBundle b e ((nodeArchetype n) {A.entities = Set.insert e . A.entities $ nodeArchetype n})}-   in w-        { archetypes = (archetypes w) {AS.nodes = Map.adjust f aId (AS.nodes $ archetypes w)},-          entities = Map.insert e aId (entities w)-        }---- | Insert a component into an entity.------ @since 0.9-insert :: EntityID -> Bundle -> Entities -> Entities-insert e b w =-  let !(cIds, components', dynB) = unBundle b (components w)-   in insertDyn e cIds dynB w {components = components'}---- | Insert a component into an entity with its `ComponentID`.------ @since 0.9-insertDyn :: EntityID -> Set ComponentID -> DynamicBundle -> Entities -> Entities-insertDyn e cIds b w = case Map.lookup e $ entities w of-  Just aId ->-    let (maybeNextAId, arches) = AS.insert e aId cIds b $ archetypes w-        es = case maybeNextAId of-          Just nextAId -> Map.insert e nextAId $ entities w-          Nothing -> entities w-     in w {archetypes = arches, entities = es}-  Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of-    Just aId -> spawnWithArchetypeId e aId b w-    Nothing ->-      let arch = runDynamicBundle b e $ A.singleton e-          node = Node {nodeComponentIds = cIds, nodeArchetype = arch}-          (aId, arches) = AS.insertArchetype cIds node $ archetypes w-       in w {archetypes = arches, entities = Map.insert e aId (entities w)}---- | Lookup a component in an entity.------ @since 0.9-lookup :: forall a. (Component a) => EntityID -> Entities -> Maybe a-lookup e w = do-  !cId <- CS.lookup @a $ components w-  !aId <- Map.lookup e $ entities w-  !node <- AS.lookup aId $ archetypes w-  A.lookupComponent e cId $ nodeArchetype node---- | Insert a component into an entity.------ @since 0.9-remove :: forall a. (Component a) => EntityID -> Entities -> (Maybe a, Entities)-remove e w =-  let !(cId, components') = CS.insert @a (components w)-   in removeWithId @a e cId w {components = components'}---- | Remove a component from an entity with its `ComponentID`.------ @since 0.9-removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> Entities -> (Maybe a, Entities)-removeWithId e cId w = case Map.lookup e (entities w) of-  Just aId ->-    let (res, as) = AS.remove @a e aId cId $ archetypes w-        (maybeA, es) = case res of-          Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w))-          Nothing -> (Nothing, entities w)-     in (maybeA, w {archetypes = as, entities = es})-  Nothing -> (Nothing, w)---- | Despawn an entity, returning its components.------ @since 0.9-despawn :: EntityID -> Entities -> (IntMap Dynamic, Entities)-despawn e w =-  let res = do-        !aId <- Map.lookup e $ entities w-        !node <- AS.lookup aId $ archetypes w-        return (aId, node)-   in case res of-        Just (aId, node) ->-          let !(dynAcc, arch') = A.remove e (nodeArchetype node)-           in ( dynAcc,-                w-                  { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},-                    entities = Map.delete e (entities w)-                  }-              )-        Nothing -> (IntMap.empty, w)+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Entities
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Entities
+  ( Entities (..),
+    empty,
+    spawn,
+    spawnWithArchetypeId,
+    insert,
+    insertDyn,
+    lookup,
+    remove,
+    removeWithId,
+    despawn,
+  )
+where
+
+import Aztecs.ECS.Component
+import Aztecs.ECS.Entity
+import qualified Aztecs.ECS.World.Archetype as A
+import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..))
+import qualified Aztecs.ECS.World.Archetypes as AS
+import Aztecs.ECS.World.Bundle
+import Aztecs.ECS.World.Bundle.Dynamic
+import Aztecs.ECS.World.Components (Components (..))
+import qualified Aztecs.ECS.World.Components as CS
+import Control.DeepSeq
+import Data.Dynamic
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import GHC.Generics
+import Prelude hiding (lookup)
+
+-- | World of entities and their components.
+--
+-- @since 0.9
+data Entities = Entities
+  { -- | Archetypes.
+    --
+    -- @since 0.9
+    archetypes :: !Archetypes,
+    -- | Components.
+    --
+    -- @since 0.9
+    components :: !Components,
+    -- | Entities and their archetype identifiers.
+    --
+    -- @since 0.9
+    entities :: !(Map EntityID ArchetypeID)
+  }
+  deriving (Show, Generic, NFData)
+
+-- | Empty `World`.
+--
+-- @since 0.9
+empty :: Entities
+empty =
+  Entities
+    { archetypes = AS.empty,
+      components = CS.empty,
+      entities = mempty
+    }
+
+-- | Spawn a `Bundle`.
+--
+-- @since 0.9
+spawn :: EntityID -> Bundle -> Entities -> Entities
+spawn eId b w =
+  let (cIds, components', dynB) = unBundle b (components w)
+   in case AS.lookupArchetypeId cIds (archetypes w) of
+        Just aId -> fromMaybe w $ do
+          node <- AS.lookup aId $ archetypes w
+          let arch' =
+                runDynamicBundle
+                  dynB
+                  eId
+                  ( (nodeArchetype node)
+                      { A.entities = Set.insert eId . A.entities $ nodeArchetype node
+                      }
+                  )
+          return
+            w
+              { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},
+                components = components',
+                entities = Map.insert eId aId (entities w)
+              }
+        Nothing ->
+          let arch' = runDynamicBundle dynB eId $ A.singleton eId
+              node' = Node {nodeComponentIds = cIds, nodeArchetype = arch'}
+              (aId, arches) = AS.insertArchetype cIds node' $ archetypes w
+           in w
+                { archetypes = arches,
+                  entities = Map.insert eId aId (entities w),
+                  components = components'
+                }
+
+-- | Spawn a `DynamicBundle` with a specified `ArchetypeID`.
+--
+-- @since 0.9
+spawnWithArchetypeId ::
+  EntityID ->
+  ArchetypeID ->
+  DynamicBundle ->
+  Entities ->
+  Entities
+spawnWithArchetypeId e aId b w =
+  let f n = n {nodeArchetype = runDynamicBundle b e ((nodeArchetype n) {A.entities = Set.insert e . A.entities $ nodeArchetype n})}
+   in w
+        { archetypes = (archetypes w) {AS.nodes = Map.adjust f aId (AS.nodes $ archetypes w)},
+          entities = Map.insert e aId (entities w)
+        }
+
+-- | Insert a component into an entity.
+--
+-- @since 0.9
+insert :: EntityID -> Bundle -> Entities -> Entities
+insert e b w =
+  let !(cIds, components', dynB) = unBundle b (components w)
+   in insertDyn e cIds dynB w {components = components'}
+
+-- | Insert a component into an entity with its `ComponentID`.
+--
+-- @since 0.9
+insertDyn :: EntityID -> Set ComponentID -> DynamicBundle -> Entities -> Entities
+insertDyn e cIds b w = case Map.lookup e $ entities w of
+  Just aId ->
+    let (maybeNextAId, arches) = AS.insert e aId cIds b $ archetypes w
+        es = case maybeNextAId of
+          Just nextAId -> Map.insert e nextAId $ entities w
+          Nothing -> entities w
+     in w {archetypes = arches, entities = es}
+  Nothing -> case AS.lookupArchetypeId cIds $ archetypes w of
+    Just aId -> spawnWithArchetypeId e aId b w
+    Nothing ->
+      let arch = runDynamicBundle b e $ A.singleton e
+          node = Node {nodeComponentIds = cIds, nodeArchetype = arch}
+          (aId, arches) = AS.insertArchetype cIds node $ archetypes w
+       in w {archetypes = arches, entities = Map.insert e aId (entities w)}
+
+-- | Lookup a component in an entity.
+--
+-- @since 0.9
+lookup :: forall a. (Component a) => EntityID -> Entities -> Maybe a
+lookup e w = do
+  !cId <- CS.lookup @a $ components w
+  !aId <- Map.lookup e $ entities w
+  !node <- AS.lookup aId $ archetypes w
+  A.lookupComponent e cId $ nodeArchetype node
+
+-- | Insert a component into an entity.
+--
+-- @since 0.9
+remove :: forall a. (Component a) => EntityID -> Entities -> (Maybe a, Entities)
+remove e w =
+  let !(cId, components') = CS.insert @a (components w)
+   in removeWithId @a e cId w {components = components'}
+
+-- | Remove a component from an entity with its `ComponentID`.
+--
+-- @since 0.9
+removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> Entities -> (Maybe a, Entities)
+removeWithId e cId w = case Map.lookup e (entities w) of
+  Just aId ->
+    let (res, as) = AS.remove @a e aId cId $ archetypes w
+        (maybeA, es) = case res of
+          Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w))
+          Nothing -> (Nothing, entities w)
+     in (maybeA, w {archetypes = as, entities = es})
+  Nothing -> (Nothing, w)
+
+-- | Despawn an entity, returning its components.
+--
+-- @since 0.9
+despawn :: EntityID -> Entities -> (IntMap Dynamic, Entities)
+despawn e w =
+  let res = do
+        !aId <- Map.lookup e $ entities w
+        !node <- AS.lookup aId $ archetypes w
+        return (aId, node)
+   in case res of
+        Just (aId, node) ->
+          let !(dynAcc, arch') = A.remove e (nodeArchetype node)
+           in ( dynAcc,
+                w
+                  { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},
+                    entities = Map.delete e (entities w)
+                  }
+              )
+        Nothing -> (IntMap.empty, w)

@@ -1,76 +1,75 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- |--- Module      : Aztecs.ECS.World.Storage--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Storage (Storage (..)) where--import Control.DeepSeq-import qualified Control.Monad-import qualified Control.Monad as M-import Data.Data-import Prelude hiding (zipWith)-import qualified Prelude---- | Component storage, containing zero or many components of the same type.------ @since 0.9-class (Typeable s, NFData s, Typeable a) => Storage a s where-  -- | Storage with a single component.-  ---  -- @since 0.9-  singleton :: a -> s--  -- | List of all components in the storage in ascending order.-  ---  -- @since 0.9-  toAscList :: s -> [a]--  -- | Convert a sorted list of components (in ascending order) into a storage.-  ---  -- @since 0.9-  fromAscList :: [a] -> s--  -- | Map a function over all components in the storage.-  ---  ---  -- @since 0.11-  map :: (a -> a) -> s -> ([a], s)--  -- | Map a monadic function over all components in the storage.-  ---  -- @since 0.11-  mapM :: (Monad m) => (a -> m a) -> s -> m ([a], s)--  -- | Map a function with some input over all components in the storage.-  ---  -- @since 0.11-  zipWith :: (b -> a -> (c, a)) -> [b] -> s -> ([(c, a)], s)--  -- | Map an applicative functor with some input over all components in the storage.-  ---  -- @since 0.11-  zipWithM :: (Applicative m) => (b -> a -> m (c, a)) -> [b] -> s -> m ([(c, a)], s)---- | @since 0.11-instance (Typeable a, NFData a) => Storage a [a] where-  {-# INLINE singleton #-}-  singleton a = [a]-  {-# INLINE toAscList #-}-  toAscList = id-  {-# INLINE fromAscList #-}-  fromAscList = id-  {-# INLINE map #-}-  map f as = let as' = fmap f as in (as', as')-  {-# INLINE mapM #-}-  mapM f as = (\as' -> (as', as')) <$> M.mapM f as-  {-# INLINE zipWith #-}-  zipWith f is as = let as' = Prelude.zipWith f is as in (as', fmap snd as')-  {-# INLINE zipWithM #-}-  zipWithM f is as = (\as' -> (as', fmap snd as')) <$> Control.Monad.zipWithM f is as+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Storage
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Storage (Storage (..)) where
+
+import qualified Control.Monad
+import qualified Control.Monad as M
+import Data.Data
+import Prelude hiding (zipWith)
+import qualified Prelude
+
+-- | Component storage, containing zero or many components of the same type.
+--
+-- @since 0.9
+class (Typeable s, Typeable a) => Storage a s where
+  -- | Storage with a single component.
+  --
+  -- @since 0.9
+  singleton :: a -> s
+
+  -- | List of all components in the storage in ascending order.
+  --
+  -- @since 0.9
+  toAscList :: s -> [a]
+
+  -- | Convert a sorted list of components (in ascending order) into a storage.
+  --
+  -- @since 0.9
+  fromAscList :: [a] -> s
+
+  -- | Map a function over all components in the storage.
+  --
+  --
+  -- @since 0.11
+  map :: (a -> a) -> s -> ([a], s)
+
+  -- | Map a monadic function over all components in the storage.
+  --
+  -- @since 0.11
+  mapM :: (Monad m) => (a -> m a) -> s -> m ([a], s)
+
+  -- | Map a function with some input over all components in the storage.
+  --
+  -- @since 0.11
+  zipWith :: (b -> a -> (c, a)) -> [b] -> s -> ([(c, a)], s)
+
+  -- | Map an applicative functor with some input over all components in the storage.
+  --
+  -- @since 0.11
+  zipWithM :: (Applicative m) => (b -> a -> m (c, a)) -> [b] -> s -> m ([(c, a)], s)
+
+-- | @since 0.11
+instance (Typeable a) => Storage a [a] where
+  {-# INLINE singleton #-}
+  singleton a = [a]
+  {-# INLINE toAscList #-}
+  toAscList = id
+  {-# INLINE fromAscList #-}
+  fromAscList = id
+  {-# INLINE map #-}
+  map f as = let as' = fmap f as in (as', as')
+  {-# INLINE mapM #-}
+  mapM f as = (\as' -> (as', as')) <$> M.mapM f as
+  {-# INLINE zipWith #-}
+  zipWith f is as = let as' = Prelude.zipWith f is as in (as', fmap snd as')
+  {-# INLINE zipWithM #-}
+  zipWithM f is as = (\as' -> (as', fmap snd as')) <$> Control.Monad.zipWithM f is as

@@ -1,97 +1,87 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      : Aztecs.ECS.World.Storage.Dynamic--- Copyright   : (c) Matt Hunzinger, 2025--- License     : BSD-style (see the LICENSE file in the distribution)------ Maintainer  : matt@hunzinger.me--- Stability   : provisional--- Portability : non-portable (GHC extensions)-module Aztecs.ECS.World.Storage.Dynamic-  ( DynamicStorage (..),-    dynStorage,-    singletonDyn,-    fromAscListDyn,-    toAscListDyn,-  )-where--import qualified Aztecs.ECS.World.Storage as S-import Control.DeepSeq-import Data.Dynamic-import Data.Maybe---- | Dynamic storage of components.------ @since 0.9-data DynamicStorage = DynamicStorage-  { -- | Dynamic storage.-    ---    -- @since 0.9-    storageDyn :: !Dynamic,-    -- | Singleton storage.-    ---    -- @since 0.9-    singletonDyn' :: !(Dynamic -> Dynamic),-    -- | Convert this storage to an ascending list.-    ---    -- @since 0.9-    toAscListDyn' :: !(Dynamic -> [Dynamic]),-    -- | Convert from an ascending list.-    ---    -- @since 0.9-    fromAscListDyn' :: !([Dynamic] -> Dynamic),-    -- | Reduce this storage to normal form.-    ---    -- @since 0.9-    storageRnf :: !(Dynamic -> ())-  }---- | @since 0.9-instance Show DynamicStorage where-  show s = "DynamicStorage " ++ show (storageDyn s)---- | @since 0.9-instance NFData DynamicStorage where-  rnf s = storageRnf s (storageDyn s)---- | Create a dynamic storage from a storage.------ @since 0.9-{-# INLINE dynStorage #-}-dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage-dynStorage s =-  DynamicStorage-    { storageDyn = toDyn s,-      singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic,-      toAscListDyn' = \d -> map toDyn (S.toAscList @a @s (fromMaybe (error "TODO") $ fromDynamic d)),-      fromAscListDyn' = toDyn . S.fromAscList @a @s . map (fromMaybe (error "TODO") . fromDynamic),-      storageRnf = maybe () rnf . fromDynamic @s-    }---- | Singleton dynamic storage.------ @since 0.9-singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage-singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn}---- | Convert from an ascending list.------ @since 0.9-fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage-fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns}---- | Convert this storage to an ascending list.------ @since 0.9-toAscListDyn :: DynamicStorage -> [Dynamic]-toAscListDyn = toAscListDyn' <*> storageDyn+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Aztecs.ECS.World.Storage.Dynamic
+-- Copyright   : (c) Matt Hunzinger, 2025
+-- License     : BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  : matt@hunzinger.me
+-- Stability   : provisional
+-- Portability : non-portable (GHC extensions)
+module Aztecs.ECS.World.Storage.Dynamic
+  ( DynamicStorage (..),
+    dynStorage,
+    singletonDyn,
+    fromAscListDyn,
+    toAscListDyn,
+  )
+where
+
+import qualified Aztecs.ECS.World.Storage as S
+import Data.Dynamic
+import Data.Maybe
+
+-- | Dynamic storage of components.
+--
+-- @since 0.9
+data DynamicStorage = DynamicStorage
+  { -- | Dynamic storage.
+    --
+    -- @since 0.9
+    storageDyn :: !Dynamic,
+    -- | Singleton storage.
+    --
+    -- @since 0.9
+    singletonDyn' :: !(Dynamic -> Dynamic),
+    -- | Convert this storage to an ascending list.
+    --
+    -- @since 0.9
+    toAscListDyn' :: !(Dynamic -> [Dynamic]),
+    -- | Convert from an ascending list.
+    --
+    -- @since 0.9
+    fromAscListDyn' :: !([Dynamic] -> Dynamic)
+  }
+
+-- | @since 0.9
+instance Show DynamicStorage where
+  show s = "DynamicStorage " ++ show (storageDyn s)
+
+-- | Create a dynamic storage from a storage.
+--
+-- @since 0.9
+{-# INLINE dynStorage #-}
+dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage
+dynStorage s =
+  DynamicStorage
+    { storageDyn = toDyn s,
+      singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic,
+      toAscListDyn' = \d -> map toDyn (S.toAscList @a @s (fromMaybe (error "TODO") $ fromDynamic d)),
+      fromAscListDyn' = toDyn . S.fromAscList @a @s . map (fromMaybe (error "TODO") . fromDynamic)
+    }
+
+-- | Singleton dynamic storage.
+--
+-- @since 0.9
+singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage
+singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn}
+
+-- | Convert from an ascending list.
+--
+-- @since 0.9
+fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage
+fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns}
+
+-- | Convert this storage to an ascending list.
+--
+-- @since 0.9
+toAscListDyn :: DynamicStorage -> [Dynamic]
+toAscListDyn = toAscListDyn' <*> storageDyn

@@ -1,189 +1,127 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Main (main) where--import Aztecs.ECS-import Aztecs.ECS.Component (ComponentID (ComponentID))-import qualified Aztecs.ECS.Query as Q-import qualified Aztecs.ECS.Query.Dynamic as Q-import qualified Aztecs.ECS.World as W-import Control.DeepSeq-import Data.Functor.Identity (Identity (runIdentity))-import Data.Word-import GHC.Generics-import Test.Hspec-import Test.QuickCheck--newtype X = X Int deriving (Eq, Show, Arbitrary, Generic, NFData)--instance Component X--newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic, NFData)--instance Component Y--newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic, NFData)--instance Component Z--main :: IO ()-main = hspec $ do-  describe "Aztecs.ECS.Query.querySingle" $ do-    it "queries a single entity" prop_querySingle-  describe "Aztecs.ECS.Query.queryMapSingle" $ do-    it "maps a single entity" $ property prop_queryMapSingle-  describe "Aztecs.ECS.Query.query" $ do-    it "queries an empty world" prop_queryEmpty-    it "queries dynamic components" $ property prop_queryDyn-    it "queries a typed component" $ property prop_queryTypedComponent-    it "queries 2 typed components" $ property prop_queryTwoTypedComponents-    it "queries 3 typed components" $ property prop_queryThreeTypedComponents--{-TODO-describe "Aztecs.ECS.System.mapSingle" $ do-  it "maps a single entity" $ property prop_systemMapSingle-describe "Aztecs.ECS.Hierarchy.update" $ do-  it "adds Parent components to children" $ property prop_addParents-  it "removes Parent components from removed children" $ property prop_removeParents--}--prop_queryEmpty :: Expectation-prop_queryEmpty =-  let res = fst . runIdentity . Q.query (fetch @_ @X) $ W.entities W.empty in res `shouldMatchList` []---- | Query all components from a list of `ComponentID`s.-queryComponentIds ::-  forall f a.-  (Monad f, Component a) =>-  [ComponentID] ->-  QueryT f (EntityID, [a])-queryComponentIds =-  let go cId qAcc = do-        x' <- Q.fromDyn $ Q.fetchDyn @a cId-        (e, xs) <- qAcc-        return (e, x' : xs)-   in foldr go ((,) <$> Q.entity <*> pure [])--prop_queryDyn :: [[X]] -> Expectation-prop_queryDyn xs =-  let s xs' (acc, wAcc) =-        let s' x (bAcc, cAcc, idAcc) =-              ( fromDynBundle (dynBundle (ComponentID idAcc) x) <> bAcc,-                (x, ComponentID idAcc) : cAcc,-                idAcc + 1-              )-            (b, cs, _) = foldr s' (mempty, [], 0) xs'-            (e, wAcc') = W.spawn b wAcc-         in ((e, cs) : acc, wAcc')-      (es, w) = foldr s ([], W.empty) xs-      go (e, cs) = do-        let q = queryComponentIds $ map snd cs-            (res, _) = runIdentity . Q.query q $ W.entities w-        return $ res `shouldContain` [(e, map fst cs)]-   in mapM_ go es--prop_queryTypedComponent :: [X] -> Expectation-prop_queryTypedComponent xs = do-  let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs-      (res, _) = runIdentity . Q.query Q.fetch $ W.entities w-  res `shouldMatchList` xs--prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation-prop_queryTwoTypedComponents xys = do-  let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys-      (res, _) = runIdentity . Q.query ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w-  res `shouldMatchList` xys--prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation-prop_queryThreeTypedComponents xyzs = do-  let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs-      q = do-        x <- Q.fetch-        y <- Q.fetch-        z <- Q.fetch-        pure (x, y, z)-      (res, _) = runIdentity . Q.query q $ W.entities w-  res `shouldMatchList` xyzs--prop_querySingle :: Expectation-prop_querySingle =-  let (_, w) = W.spawn (bundle $ X 1) W.empty-      (res, _) = runIdentity . Q.readSingle Q.fetch $ W.entities w-   in res `shouldBe` X 1--prop_queryMapSingle :: Word8 -> Expectation-prop_queryMapSingle n =-  let (_, w) = W.spawn (bundle $ X 0) W.empty-      q = Q.zipFetchMap (\_ (X x) -> X $ x + 1) (pure ())-      w' = foldr (\_ es -> snd . runIdentity $ Q.querySingle q es) (W.entities w) [1 .. n]-      (res, _) = runIdentity $ Q.readSingle Q.fetch w'-   in res `shouldBe` X (fromIntegral n)--{-TODO-prop_systemMapSingle :: Word8 -> Expectation-prop_systemMapSingle n =-  let (_, w) = W.spawn (bundle $ X 0) W.empty-      q = Q.adjust (\_ (X x) -> X $ x + 1)-      s =  S.mapSingle q-      go _ wAcc = let (_, _, wAcc') = runIdentity $ runSchedule s wAcc () in wAcc'-      w' = foldr go w [1 .. n]-      (res, _) = Q.single () Q.fetch (W.entities w')-   in res `shouldBe` X (fromIntegral n)--prop_addParents :: Expectation-prop_addParents = do-  let (_, w) = W.spawnEmpty W.empty-      (e, w') = W.spawn (bundle . Children $ Set.singleton e) w-  (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()-  let (res, _) = Q.all () Q.fetch $ W.entities w''-  res `shouldMatchList` [Parent e]--prop_removeParents :: Expectation-prop_removeParents = do-  let (_, w) = W.spawnEmpty W.empty-      (e, w') = W.spawn (bundle . Children $ Set.singleton e) w-  (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()-  let w''' = W.insert e (Children Set.empty) w''-  (_, _, w'''') <- runSchedule (system Hierarchy.update) w''' ()-  let (res, _) = Q.all () (Q.fetch @_ @Parent) $ W.entities w''''-  res `shouldMatchList` []--}--{--prop_scheduleQueryEntity :: [X] -> Expectation-prop_scheduleQueryEntity xs = do-  let go x (eAcc, wAcc) = let (e, wAcc') = W.spawn (bundle x) wAcc in (e : eAcc, wAcc')-      (es, w) = foldr go ([], W.empty) xs-  (res, _, _) <- runSchedule (reader $ S.all Q.entity) w ()-  res `shouldMatchList` es--prop_scheduleUpdate :: Expectation-prop_scheduleUpdate = do-  let (_, w) = W.spawn (bundle $ X 1) W.empty-  (_, _, w') <- runSchedule update w ()-  (x, _, _) <- runSchedule update w' ()-  x `shouldBe` True--update :: Schedule IO () Bool-update = proc () -> do-  rec lastShouldQuit <- delay False -< shouldQuit-      x <--        system $-          S.mapSingle-            ( proc () -> do-                X x <- Q.fetch -< ()-                Q.set -< X $ x + 1-                returnA -< x-            )-          -<-            ()-      let shouldQuit = (lastShouldQuit || x > 1)-  returnA -< shouldQuit--}+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Main (main) where
+
+import Aztecs.ECS
+import Aztecs.ECS.Component (ComponentID (ComponentID))
+import qualified Aztecs.ECS.Query as Q
+import qualified Aztecs.ECS.Query.Dynamic as Q
+import qualified Aztecs.ECS.World as W
+import Control.DeepSeq
+import Data.Functor.Identity (Identity (runIdentity))
+import Data.Word
+import GHC.Generics
+import Test.Hspec
+import Test.QuickCheck
+
+newtype X = X Int deriving (Eq, Show, Arbitrary, Generic, NFData)
+
+instance Component X
+
+newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic, NFData)
+
+instance Component Y
+
+newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic, NFData)
+
+instance Component Z
+
+main :: IO ()
+main = hspec $ do
+  describe "Aztecs.ECS.Query.querySingle" $ do
+    it "queries a single entity" prop_querySingle
+  describe "Aztecs.ECS.Query.queryMapSingle" $ do
+    it "maps a single entity" $ property prop_queryMapSingle
+  describe "Aztecs.ECS.Query.query" $ do
+    it "queries an empty world" prop_queryEmpty
+    it "queries dynamic components" $ property prop_queryDyn
+    it "queries a typed component" $ property prop_queryTypedComponent
+    it "queries 2 typed components" $ property prop_queryTwoTypedComponents
+    it "queries 3 typed components" $ property prop_queryThreeTypedComponents
+
+{-TODO
+describe "Aztecs.ECS.System.mapSingle" $ do
+  it "maps a single entity" $ property prop_systemMapSingle
+describe "Aztecs.ECS.Hierarchy.update" $ do
+  it "adds Parent components to children" $ property prop_addParents
+  it "removes Parent components from removed children" $ property prop_removeParents
+-}
+
+prop_queryEmpty :: Expectation
+prop_queryEmpty =
+  let res = fst . runIdentity . Q.query (fetch @_ @X) $ W.entities W.empty in res `shouldMatchList` []
+
+-- | Query all components from a list of `ComponentID`s.
+queryComponentIds ::
+  forall f a.
+  (Monad f, Component a) =>
+  [ComponentID] ->
+  QueryT f (EntityID, [a])
+queryComponentIds =
+  let go cId qAcc = do
+        x' <- Q.fromDyn $ Q.fetchDyn @a cId
+        (e, xs) <- qAcc
+        return (e, x' : xs)
+   in foldr go ((,) <$> Q.entity <*> pure [])
+
+prop_queryDyn :: [[X]] -> Expectation
+prop_queryDyn xs =
+  let s xs' (acc, wAcc) =
+        let s' x (bAcc, cAcc, idAcc) =
+              ( fromDynBundle (dynBundle (ComponentID idAcc) x) <> bAcc,
+                (x, ComponentID idAcc) : cAcc,
+                idAcc + 1
+              )
+            (b, cs, _) = foldr s' (mempty, [], 0) xs'
+            (e, wAcc') = W.spawn b wAcc
+         in ((e, cs) : acc, wAcc')
+      (es, w) = foldr s ([], W.empty) xs
+      go (e, cs) = do
+        let q = queryComponentIds $ map snd cs
+            (res, _) = runIdentity . Q.query q $ W.entities w
+        return $ res `shouldContain` [(e, map fst cs)]
+   in mapM_ go es
+
+prop_queryTypedComponent :: [X] -> Expectation
+prop_queryTypedComponent xs = do
+  let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs
+      (res, _) = runIdentity . Q.query Q.fetch $ W.entities w
+  res `shouldMatchList` xs
+
+prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation
+prop_queryTwoTypedComponents xys = do
+  let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys
+      (res, _) = runIdentity . Q.query ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w
+  res `shouldMatchList` xys
+
+prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation
+prop_queryThreeTypedComponents xyzs = do
+  let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs
+      q = do
+        x <- Q.fetch
+        y <- Q.fetch
+        z <- Q.fetch
+        pure (x, y, z)
+      (res, _) = runIdentity . Q.query q $ W.entities w
+  res `shouldMatchList` xyzs
+
+prop_querySingle :: Expectation
+prop_querySingle =
+  let (_, w) = W.spawn (bundle $ X 1) W.empty
+      (res, _) = runIdentity . Q.readQuerySingle Q.fetch $ W.entities w
+   in res `shouldBe` X 1
+
+prop_queryMapSingle :: Word8 -> Expectation
+prop_queryMapSingle n =
+  let (_, w) = W.spawn (bundle $ X 0) W.empty
+      q = Q.zipFetchMap (\_ (X x) -> X $ x + 1) (pure ())
+      w' = foldr (\_ es -> snd . runIdentity $ Q.querySingle q es) (W.entities w) [1 .. n]
+      (res, _) = runIdentity $ Q.readQuerySingle Q.fetch w'
+   in res `shouldBe` X (fromIntegral n)