packages feed

aztecs 0.14.0 → 0.15.0

raw patch · 57 files changed

+3689/−2421 lines, 57 filesdep +stmdep +vectordep −primitivedep −sparse-setdep ~basedep ~mtl

Dependencies added: stm, vector

Dependencies removed: primitive, sparse-set

Dependency ranges changed: base, mtl

Files

aztecs.cabal view
@@ -1,119 +1,105 @@-cabal-version: 2.4-name:          aztecs-version:       0.14.0-license:       BSD-3-Clause-license-file:  LICENSE-maintainer:    matt@hunzinger.me-author:        Matt Hunzinger-homepage:      https://github.com/aztecs-hs/aztecs-synopsis:-    A modular game engine and Entity-Component-System (ECS) for Haskell.--description:-    A modular game engine and Entity-Component-System (ECS) for Haskell.-    An ECS is a modern approach to organizing your application state as a database,-    providing patterns for data-oriented design and parallel processing.-    Aztecs provides side-effect free components and systems,-    as well as backends for rendering and input (such as `aztecs-sdl`),-    allowing you to structure your game as simple function of `Input -> World -> World`.--category:      Game Engine--source-repository head-    type:     git-    location: https://github.com/aztecs-hs/aztecs.git--library-    exposed-modules:-        Aztecs-        Aztecs.ECS-        Aztecs.ECS.Access-        Aztecs.ECS.Access.Internal-        Aztecs.ECS.Bundle-        Aztecs.ECS.Bundle.Class-        Aztecs.ECS.Class-        Aztecs.ECS.Commands-        Aztecs.ECS.Component-        Aztecs.ECS.Executor-        Aztecs.ECS.HSet-        Aztecs.ECS.Query-        Aztecs.ECS.Query.Class-        Aztecs.ECS.Query.Internal-        Aztecs.ECS.R-        Aztecs.ECS.Schedule-        Aztecs.ECS.Schedule.Internal-        Aztecs.ECS.Scheduler-        Aztecs.ECS.Scheduler.Internal-        Aztecs.ECS.System-        Aztecs.ECS.W-        Aztecs.Entity-        Aztecs.Internal-        Aztecs.Storage-        Aztecs.World-        Aztecs.World.Entities--    hs-source-dirs:   src-    default-language: Haskell2010-    build-depends:-        base >=4.2 && <5,-        containers >=0.6,-        deepseq >=1,-        mtl >=2,-        primitive >=0.6,-        sparse-set >=0.2--executable ecs-    main-is:          examples/ECS.hs-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base,-        aztecs--executable scheduler-    main-is:          examples/Scheduler.hs-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base,-        aztecs,-        mtl--executable hooks-    main-is:          examples/Hooks.hs-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base,-        aztecs,-        mtl--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 -O2 -fspecialise-aggressively -fexpose-all-unfoldings--    build-depends:-        base >=4.2 && <5,-        aztecs,-        criterion >=1,-        deepseq >=1,-        primitive >=0.6,-        sparse-set >=0.2+cabal-version: 2.4
+name:          aztecs
+version:       0.15.0
+license:       BSD-3-Clause
+license-file:  LICENSE
+maintainer:    matt@hunzinger.me
+author:        Matt Hunzinger
+homepage:      https://github.com/aztecs-hs/aztecs
+synopsis:
+    A modular game engine and Entity-Component-System (ECS) for Haskell.
+
+description:
+    A modular game engine and Entity-Component-System (ECS) for Haskell.
+    An ECS is a modern approach to organizing your application state as a database,
+    providing patterns for data-oriented design and parallel processing.
+    Aztecs provides side-effect free components and systems,
+    as well as backends for rendering and input (such as `aztecs-sdl`),
+    allowing you to structure your game as simple function of `Input -> World -> World`.
+
+category:      Game Engine
+
+source-repository head
+    type:     git
+    location: https://github.com/aztecs-hs/aztecs.git
+
+library
+    exposed-modules:
+        Aztecs
+        Aztecs.ECS
+        Aztecs.ECS.Access
+        Aztecs.ECS.Access.Class
+        Aztecs.ECS.Component
+        Aztecs.ECS.Entity
+        Aztecs.ECS.Query
+        Aztecs.ECS.Query.Class
+        Aztecs.ECS.Query.Dynamic
+        Aztecs.ECS.Query.Dynamic.Class
+        Aztecs.ECS.Query.Dynamic.Reader
+        Aztecs.ECS.Query.Dynamic.Reader.Class
+        Aztecs.ECS.Query.Reader
+        Aztecs.ECS.Query.Reader.Class
+        Aztecs.ECS.System
+        Aztecs.ECS.System.Class
+        Aztecs.ECS.System.Dynamic.Class
+        Aztecs.ECS.System.Dynamic.Reader.Class
+        Aztecs.ECS.System.Reader.Class
+        Aztecs.ECS.View
+        Aztecs.ECS.World
+        Aztecs.ECS.World.Archetype
+        Aztecs.ECS.World.Archetypes
+        Aztecs.ECS.World.Bundle
+        Aztecs.ECS.World.Bundle.Class
+        Aztecs.ECS.World.Bundle.Dynamic
+        Aztecs.ECS.World.Bundle.Dynamic.Class
+        Aztecs.ECS.World.Components
+        Aztecs.ECS.World.Entities
+        Aztecs.ECS.World.Storage
+        Aztecs.ECS.World.Storage.Dynamic
+        Aztecs.Hierarchy
+
+    hs-source-dirs:   src
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base >=4.2 && <5,
+        containers >=0.6,
+        mtl >=2,
+        stm >=2,
+        vector >=0.12
+
+executable ecs
+    main-is:          examples/ECS.hs
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base,
+        aztecs
+
+test-suite aztecs-test
+    type:             exitcode-stdio-1.0
+    main-is:          Main.hs
+    hs-source-dirs:   test
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base >=4.2 && <5,
+        aztecs,
+        containers >=0.6,
+        deepseq >=1,
+        hspec >=2,
+        QuickCheck >=2,
+        vector >=0.12
+
+benchmark aztecs-bench
+    type:             exitcode-stdio-1.0
+    main-is:          Bench.hs
+    hs-source-dirs:   bench
+    default-language: Haskell2010
+    ghc-options:      -Wall
+    build-depends:
+        base >=4.2 && <5,
+        aztecs,
+        criterion >=1,
+        deepseq >=1,
+        vector >=0.12
bench/Bench.hs view
@@ -1,47 +1,34 @@-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
-import Aztecs
-import qualified Aztecs.World as W
-import Control.DeepSeq
-import Control.Monad.IO.Class
-import Criterion.Main
-import GHC.Generics (Generic)
-
-newtype Position = Position Int deriving (Generic, NFData, Show)
-
-instance (Monad m) => Component m Position where
-  type ComponentStorage m Position = SparseStorage m
-
-newtype Velocity = Velocity Int deriving (Generic, NFData, Show)
-
-instance (Monad m) => Component m Velocity where
-  type ComponentStorage m Velocity = SparseStorage m
-
-data MoveSystem = MoveSystem
-
-instance (PrimMonad m, MonadIO m) => System m MoveSystem where
-  type SystemIn m MoveSystem = Query (W m Position, R Velocity)
-  runSystem _ = mapM_ go
-    where
-      go (posRef, R (Velocity v)) =
-        modifyW posRef $ \(Position p) -> Position (p + v)
-
-setup :: IO (W.World IO '[Position, Velocity])
-setup = do
-  w <- W.empty @_ @'[Position, Velocity]
-  snd <$> runAztecsT (mapM setupEntity [0 :: Int .. 10000]) w
-  where
-    setupEntity _ = spawn (bundle (Position 0) <> bundle (Velocity 1))
-
-main :: IO ()
-main = do
-  !w <- setup
-  defaultMain [bench "iter" . whnfIO $ runAztecsT_ (system MoveSystem) 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 Data.Vector (Vector)+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++query :: Query Position+query = Q.fetch & Q.adjust (\(Velocity v) (Position p) -> Position $ p + v)++run :: Query Position -> World -> Vector Position+run q = fst . runIdentity . Q.map 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 query) w]
examples/ECS.hs view
@@ -1,45 +1,32 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
 module Main where
 
-import Aztecs
-import qualified Aztecs.World as W
+import Aztecs.ECS
+import qualified Aztecs.ECS.Access as A
+import qualified Aztecs.ECS.Query as Q
+import qualified Aztecs.ECS.System as S
 import Control.Monad.IO.Class
-
-newtype Position = Position Int
-  deriving (Show, Eq)
+import Data.Function ((&))
 
-instance (Monad m) => Component m Position where
-  type ComponentStorage m Position = SparseStorage m
+newtype Position = Position Int deriving (Show)
 
-newtype Velocity = Velocity Int
-  deriving (Show, Eq)
+instance Component Position
 
-instance (Monad m) => Component m Velocity where
-  type ComponentStorage m Velocity = SparseStorage m
+newtype Velocity = Velocity Int deriving (Show)
 
-data MoveSystem = MoveSystem
+instance Component Velocity
 
-instance (PrimMonad m, MonadIO m) => System m MoveSystem where
-  type SystemIn m MoveSystem = Query (W m Position, R Velocity)
+move :: QueryT IO Position
+move = Q.fetch & Q.adjust (\(Velocity v) (Position p) -> Position $ p + v)
 
-  runSystem _ = mapM_ go
-    where
-      go (posRef, R (Velocity v)) = do
-        modifyW posRef $ \(Position p) -> Position (p + v)
+run :: AccessT IO ()
+run = do
+  positions <- S.map move
+  liftIO $ print positions
 
-        p <- readW posRef
-        liftIO $ putStrLn $ "Moved to: " ++ show p
+app :: AccessT IO ()
+app = do
+  A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)
+  run
 
 main :: IO ()
-main = do
-  world <- W.empty @_ @'[Position, Velocity]
-  runAztecsT_ go world
-  where
-    go = do
-      _ <- spawn (bundle (Position 0) <> bundle (Velocity 1))
-      system MoveSystem
+main = runAccessT_ app
− examples/Hooks.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Main where
-
-import Aztecs
-import qualified Aztecs.World as W
-import Control.Monad.IO.Class
-
-newtype Position = Position Int
-  deriving (Show, Eq)
-
-instance (MonadIO m, Show (Entity m)) => Component m Position where
-  type ComponentStorage m Position = SparseStorage m
-
-  componentHooks _ =
-    Hooks
-      { onInsert = \entity ->
-          liftIO . putStrLn $ "Position component inserted for " ++ show entity,
-        onRemove = \entity ->
-          liftIO . putStrLn $ "Position component removed for " ++ show entity
-      }
-
-newtype Velocity = Velocity Int
-  deriving (Show, Eq)
-
-instance (MonadIO m, Show (Entity m)) => Component m Velocity where
-  type ComponentStorage m Velocity = SparseStorage m
-
-  componentHooks _ =
-    Hooks
-      { onInsert = \entity ->
-          liftIO $ putStrLn $ "Velocity component inserted for " ++ show entity,
-        onRemove = \entity ->
-          liftIO $ putStrLn $ "Velocity component removed for " ++ show entity
-      }
-
-data MoveSystem = MoveSystem
-
-instance (PrimMonad m, MonadIO m) => System m MoveSystem where
-  type SystemIn m MoveSystem = Query (W m Position, R Velocity)
-
-  runSystem _ = mapM_ go
-    where
-      go (posRef, R (Velocity v)) = do
-        modifyW posRef $ \(Position p) -> Position (p + v)
-        p <- readW posRef
-        liftIO $ putStrLn $ "Moved to: " ++ show p
-
-main :: IO ()
-main = do
-  world <- W.empty @_ @'[Position, Velocity]
-  (entity1, world') <- runAztecsT go world
-  runAztecsT_ (remove entity1) world'
-  where
-    go = do
-      e <- spawn (bundle (Position 0) <> bundle (Velocity 5))
-      system MoveSystem
-      return e
− examples/Scheduler.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Main where
-
-import Aztecs
-import qualified Aztecs.World as W
-import Control.Monad.IO.Class
-
-newtype Position = Position Int
-  deriving (Show, Eq)
-
-instance (Monad m) => Component m Position where
-  type ComponentStorage m Position = SparseStorage m
-
-newtype Velocity = Velocity Int
-  deriving (Show, Eq)
-
-instance (Monad m) => Component m Velocity where
-  type ComponentStorage m Velocity = SparseStorage m
-
-newtype Health = Health Int
-  deriving (Show, Eq)
-
-instance (Monad m) => Component m Health where
-  type ComponentStorage m Health = SparseStorage m
-
-newtype Damage = Damage Int
-  deriving (Show, Eq)
-
-instance (Monad m) => Component m Damage where
-  type ComponentStorage m Damage = SparseStorage m
-
-data MoveSystem = MoveSystem
-  deriving (Show)
-
-data PhysicsSystem = PhysicsSystem
-  deriving (Show)
-
-data CombatSystem = CombatSystem
-  deriving (Show)
-
-data RenderSystem = RenderSystem
-  deriving (Show)
-
-instance (PrimMonad m, MonadIO m) => System m MoveSystem where
-  type SystemIn m MoveSystem = Query (W m Position, R Velocity)
-  runSystem MoveSystem q = do
-    liftIO $ putStrLn "Running MoveSystem..."
-    mapM_ go q
-    where
-      go (posRef, R (Velocity v)) = do
-        modifyW posRef $ \(Position p) -> Position (p + v)
-        p <- readW posRef
-        liftIO $ putStrLn $ "  Moved to position: " ++ show p
-
-instance (PrimMonad m, MonadIO m) => System m PhysicsSystem where
-  type SystemIn m PhysicsSystem = Query (R Position, W m Velocity)
-  runSystem PhysicsSystem q = do
-    liftIO $ putStrLn "Running PhysicsSystem..."
-    mapM_ go q
-    where
-      go (R (Position p), velRef) = do
-        modifyW velRef $ \(Velocity v) -> Velocity (max 0 (v - 1))
-        v <- readW velRef
-        liftIO $ putStrLn $ "  Applied physics at position " ++ show p ++ ", new velocity: " ++ show v
-
-instance (PrimMonad m, MonadIO m) => System m CombatSystem where
-  type SystemIn m CombatSystem = Query (W m Health, R Damage)
-
-  runSystem CombatSystem q = do
-    liftIO $ putStrLn "Running CombatSystem..."
-    mapM_ go q
-    where
-      go (healthRef, R (Damage d)) = do
-        modifyW healthRef $ \(Health h) -> Health (max 0 (h - d))
-        h <- readW healthRef
-        liftIO $ putStrLn $ "  Applied damage, remaining health: " ++ show h
-
-instance (PrimMonad m, MonadIO m) => System m RenderSystem where
-  type SystemIn m RenderSystem = Query (R Position, R Health)
-
-  runSystem RenderSystem q = do
-    liftIO $ putStrLn "Running RenderSystem..."
-    mapM_ go q
-    where
-      go (R (Position p), R (Health h)) = do
-        liftIO $ putStrLn $ "  Rendering entity at position " ++ show p ++ " with health " ++ show h
-
-app ::
-  HSet
-    '[ Run '[] MoveSystem,
-       Run '[After MoveSystem] PhysicsSystem,
-       Run '[After PhysicsSystem] CombatSystem,
-       Run '[After CombatSystem] RenderSystem
-     ]
-app =
-  HCons (Run MoveSystem) $
-    HCons (Run PhysicsSystem) $
-      HCons (Run CombatSystem) $
-        HCons (Run RenderSystem) $
-          HEmpty
-
-appSmall ::
-  HSet
-    '[ Run '[After PhysicsSystem] MoveSystem,
-       Run '[] PhysicsSystem,
-       Run '[] RenderSystem
-     ]
-appSmall =
-  HCons (Run MoveSystem) $
-    HCons (Run PhysicsSystem) $
-      HCons (Run RenderSystem) $
-        HEmpty
-
-runSchedulerExample :: IO ()
-runSchedulerExample = do
-  world <- W.empty @_ @'[Position, Velocity, Health, Damage]
-  runAztecsT_ go world
-  where
-    go :: AztecsT '[Position, Velocity, Health, Damage] IO ()
-    go = do
-      _ <- spawn (bundle (Position 0) <> bundle (Velocity 5) <> bundle (Health 100))
-      _ <- spawn (bundle (Position 10) <> bundle (Velocity 3) <> bundle (Health 75) <> bundle (Damage 10))
-      _ <- spawn (bundle (Position (-5)) <> bundle (Velocity 2) <> bundle (Health 50))
-      runSchedule app
-      return ()
-
-runSchedulerExampleSmall :: IO ()
-runSchedulerExampleSmall = do
-  world <- W.empty @_ @'[Position, Velocity, Health, Damage]
-  runAztecsT_ go world
-  where
-    go :: AztecsT '[Position, Velocity, Health, Damage] IO ()
-    go = do
-      _ <- spawn (bundle (Position 0) <> bundle (Velocity 5) <> bundle (Health 100))
-      _ <- spawn (bundle (Position 10) <> bundle (Velocity 3) <> bundle (Health 75) <> bundle (Damage 10))
-      _ <- spawn (bundle (Position (-5)) <> bundle (Velocity 2) <> bundle (Health 50))
-      runSchedule appSmall
-      return ()
-
-main :: IO ()
-main = do
-  runSchedulerExample
-  runSchedulerExampleSmall
src/Aztecs.hs view
@@ -1,26 +1,7 @@-module Aztecs
-  ( module Aztecs.ECS.Component,
-    module Aztecs.ECS,
-    module Aztecs.Internal,
-    module Aztecs.ECS.R,
-    module Aztecs.ECS.W,
-    module Aztecs.Storage,
-    module Aztecs.ECS.HSet,
-    module Aztecs.ECS.Query.Class,
-    module Aztecs.ECS.Schedule,
-    module Aztecs.ECS.Scheduler,
-    module Aztecs.World,
-  )
-where
-
-import Aztecs.ECS
-import Aztecs.ECS.Component
-import Aztecs.ECS.HSet
-import Aztecs.ECS.Query.Class
-import Aztecs.ECS.R
-import Aztecs.ECS.Schedule
-import Aztecs.ECS.Scheduler
-import Aztecs.ECS.W
-import Aztecs.Internal
-import Aztecs.Storage
-import Aztecs.World (SparseStorage)
+-- | Aztecs is a type-safe and friendly ECS for games and more.+--+-- An ECS is a modern approach to organizing your application state as a database,+-- providing patterns for data-oriented design and parallel processing.+module Aztecs (module Aztecs.ECS) where++import Aztecs.ECS
src/Aztecs/ECS.hs view
@@ -1,37 +1,100 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS
-  ( module Aztecs.ECS.Bundle,
-    module Aztecs.ECS.Bundle.Class,
-    module Aztecs.ECS.Class,
-    module Aztecs.ECS.Commands,
-    module Aztecs.ECS.Component,
-    module Aztecs.ECS.Query.Class,
-    module Aztecs.ECS.Schedule,
-    module Aztecs.ECS.Scheduler,
-    PrimMonad (..),
-    Query (..),
-    runQuery,
-    System (..),
-    system,
-  )
-where
-
-import Aztecs.ECS.Bundle
-import Aztecs.ECS.Bundle.Class
-import Aztecs.ECS.Class
-import Aztecs.ECS.Commands
-import Aztecs.ECS.Component
-import Aztecs.ECS.Query
-import Aztecs.ECS.Query.Class
-import Aztecs.ECS.Schedule
-import Aztecs.ECS.Scheduler
-import Aztecs.ECS.System
-import Control.Monad.Primitive
+-- | Aztecs is a type-safe and friendly ECS for games and more.+--+-- An ECS is a modern approach to organizing your application state as a database,+-- providing patterns for data-oriented design and parallel processing.+--+-- The ECS architecture is composed of three main concepts:+--+-- === Entities+-- An entity is an object comprised of zero or more components.+-- In Aztecs, entities are represented by their `EntityID`, a unique identifier.+--+-- === Components+-- A `Component` holds the data for a particular aspect of an entity.+-- For example, a zombie entity might have a @Health@ and a @Transform@ component.+--+-- > newtype Position = Position Int deriving (Show)+-- > instance Component Position+-- >+-- > newtype Velocity = Velocity Int deriving (Show)+-- > instance Component Velocity+--+-- === Systems+-- A `System` is a pipeline that processes entities and their components.+-- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.+--+-- Systems can access game state in two ways:+--+-- ==== Access+-- An `Access` can be queued for full access to the `World`, after a system is complete.+-- `Access` allows for spawning, inserting, and removing components.+--+-- > setup :: System  () ()+-- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)+--+-- ==== Queries+-- A `Query` can read and write matching components.+--+-- > move :: System  () ()+-- > move =+-- >  S.map+-- >    ( proc () -> do+-- >        Velocity v <- Q.fetch -< ()+-- >        Position p <- Q.fetch -< ()+-- >        Q.set -< Position $ p + v+-- >    )+-- >    >>> S.run print+--+-- Finally, systems can be run on a `World` to produce a result.+--+-- > main :: IO ()+-- > main = runSystem_ $ setup >>> S.forever move+module Aztecs.ECS+  ( Access,+    AccessT,+    MonadAccess,+    runAccessT,+    runAccessT_,+    Bundle,+    MonoidBundle (..),+    DynamicBundle,+    MonoidDynamicBundle (..),+    Component (..),+    EntityID,+    Query,+    QueryT,+    QueryReader,+    QueryReaderF,+    QueryF,+    DynamicQueryReaderF,+    DynamicQueryF,+    QueryFilter,+    with,+    without,+    System,+    SystemT,+    MonadReaderSystem,+    MonadSystem,+    World,+  )+where++import Aztecs.ECS.Access+import Aztecs.ECS.Component (Component (..))+import Aztecs.ECS.Entity (EntityID)+import Aztecs.ECS.Query+  ( DynamicQueryF,+    DynamicQueryReaderF,+    Query,+    QueryF,+    QueryFilter,+    QueryReaderF,+    QueryT,+    with,+    without,+  )+import Aztecs.ECS.Query.Reader (QueryReader)+import Aztecs.ECS.System+import Aztecs.ECS.World (World)+import Aztecs.ECS.World.Bundle (Bundle, MonoidBundle (..))+import Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle, MonoidDynamicBundle (..))
src/Aztecs/ECS/Access.hs view
@@ -1,3 +1,175 @@-module Aztecs.ECS.Access (Access (..)) where
-
-import Aztecs.ECS.Access.Internal
+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.Access+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Access+  ( Access,+    AccessT (..),+    MonadAccess (..),+    runAccessT,+    runAccessT_,+    system,+  )+where++import Aztecs.ECS.Access.Class+import Aztecs.ECS.Query (QueryT (..))+import qualified Aztecs.ECS.Query as Q+import Aztecs.ECS.Query.Dynamic (DynamicQueryT)+import qualified Aztecs.ECS.Query.Dynamic as Q+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader)+import qualified Aztecs.ECS.Query.Dynamic.Reader as Q+import Aztecs.ECS.Query.Reader+import Aztecs.ECS.System+import Aztecs.ECS.World (World (..))+import qualified Aztecs.ECS.World as W+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node (..))+import Aztecs.ECS.World.Bundle+import qualified Aztecs.ECS.World.Entities as E+import Control.Concurrent.STM+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State.Strict+import qualified Data.Foldable as F++-- | @since 0.9+type Access = AccessT Identity++-- | Access into the `World`.+--+-- @since 0.9+newtype AccessT m a = AccessT {unAccessT :: StateT World m a}+  deriving (Functor, Applicative, MonadFix, MonadIO)++-- | @since 0.9+instance (Monad m) => Monad (AccessT m) where+  a >>= f = AccessT $ do+    !w <- get+    (a', w') <- lift $ runAccessT a w+    put w'+    unAccessT $ f a'++-- | Run an `Access` on a `World`, returning the output and updated `World`.+--+-- @since 0.9+runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World)+runAccessT a = runStateT $ unAccessT a++-- | Run an `Access` on an empty `World`.+--+-- @since 0.9+runAccessT_ :: (Functor m) => AccessT m a -> m a+runAccessT_ a = fmap fst . runAccessT a $ W.empty++-- | @since 0.9+instance (Monad m) => MonadAccess Bundle (AccessT m) where+  spawn b = AccessT $ do+    !w <- get+    let !(e, w') = W.spawn b w+    put w'+    return e+  insert e c = AccessT $ do+    !w <- get+    let !w' = W.insert e c w+    put w'+  lookup e = AccessT $ do+    !w <- get+    return $ W.lookup e w+  remove e = AccessT $ do+    !w <- get+    let !(a, w') = W.remove e w+    put w'+    return a+  despawn e = AccessT $ do+    !w <- get+    let !(_, w') = W.despawn e w+    put w'++-- | @since 0.9+instance (Monad m) => MonadReaderSystem QueryReader (AccessT m) where+  all q = AccessT $ do+    w <- get+    let (cIds, cs, dynQ) = runQueryReader q . E.components $ entities w+    put w {entities = (entities w) {E.components = cs}}+    unAccessT $ allDyn cIds dynQ+  filter q f = AccessT $ do+    w <- get+    let (cIds, cs, dynQ) = runQueryReader q . E.components $ entities w+        (dynF, cs') = runQueryFilter f cs+    put w {entities = (entities w) {E.components = cs'}}+    let f' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+    unAccessT $ filterDyn cIds dynQ f'++-- | @since 0.9+instance (Monad m) => MonadSystem (QueryT m) (AccessT m) where+  map q = AccessT $ do+    !w <- get+    let (rws, cs, dynQ) = runQuery q . E.components $ entities w+    put w {entities = (entities w) {E.components = cs}}+    unAccessT $ mapDyn (Q.reads rws <> Q.writes rws) dynQ+  mapSingleMaybe q = AccessT $ do+    !w <- get+    let (rws, cs, dynQ) = runQuery q . E.components $ entities w+    put w {entities = (entities w) {E.components = cs}}+    unAccessT $ mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ+  filterMap q f = AccessT $ do+    !w <- get+    let (rws, cs, dynQ) = runQuery q . E.components $ entities w+        (dynF, cs') = runQueryFilter f cs+    put w {entities = (entities w) {E.components = cs'}}+    let f' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+    unAccessT $ filterMapDyn (Q.reads rws <> Q.writes rws) f' dynQ++-- | @since 0.9+instance (Monad m) => MonadDynamicReaderSystem DynamicQueryReader (AccessT m) where+  allDyn cIds q = AccessT $ do+    !w <- get+    return . Q.allDyn cIds q $ entities w+  filterDyn cIds q f = AccessT $ do+    !w <- get+    return . Q.filterDyn cIds f q $ entities w++-- | @since 0.9+instance (Monad m) => MonadDynamicSystem (DynamicQueryT m) (AccessT m) where+  mapDyn cIds q = AccessT $ do+    !w <- get+    (as, es) <- lift . Q.mapDyn cIds q $ entities w+    put w {entities = es}+    return as+  mapSingleMaybeDyn cIds q = AccessT $ do+    !w <- get+    (res, es) <- lift . Q.mapSingleMaybeDyn cIds q $ entities w+    put w {entities = es}+    return res+  filterMapDyn cIds f q = AccessT $ do+    !w <- get+    (as, es) <- lift . Q.filterMapDyn cIds f q $ entities w+    put w {entities = es}+    return as++-- | Run a `System`.+--+-- @since 0.9+system :: System a -> AccessT IO a+system s = AccessT $ do+  !w <- get+  esVar <- lift . newTVarIO $ entities w+  a <- lift . atomically $ runReaderT (runSystemT s) esVar+  es <- lift $ readTVarIO esVar+  put w {entities = es}+  return a
+ src/Aztecs/ECS/Access/Class.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FunctionalDependencies #-}++-- |+-- Module      : Aztecs.ECS.Access.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Access.Class (MonadAccess (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity+import Aztecs.ECS.World.Bundle.Class++-- | Monadic access to a `World`.+--+-- @since 0.9+class (MonoidBundle b, Monad m) => MonadAccess b m | m -> b where+  -- | Spawn an entity with a component.+  --+  -- @since 0.9+  spawn :: b -> m EntityID++  -- | Spawn an entity with a component.+  --+  -- @since 0.9+  spawn_ :: b -> m ()+  spawn_ c = do+    _ <- spawn c+    return ()++  -- | Insert a component into an entity.+  --+  -- @since 0.9+  insert :: EntityID -> b -> m ()++  -- | Lookup a component on an entity.+  --+  -- @since 0.9+  lookup :: (Component a) => EntityID -> m (Maybe a)++  -- | Remove a component from an entity.+  --+  -- @since 0.9+  remove :: (Component a) => EntityID -> m (Maybe a)++  -- | Despawn an entity.+  --+  -- @since 0.9+  despawn :: EntityID -> m ()
− src/Aztecs/ECS/Access/Internal.hs 
@@ -1,278 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.Access.Internal where
-
-import Aztecs.ECS.Class
-import Aztecs.ECS.Query
-import Aztecs.ECS.Query.Class
-import Aztecs.ECS.Query.Internal
-import Data.Kind
-import GHC.Generics
-
-type family ValidAccessInput (accesses :: [Type]) :: Constraint where
-  ValidAccessInput accesses =
-    (ValidAccess accesses, HasDuplicateWrites (WriteComponents accesses) ~ 'False)
-
-type family HasDuplicateWrites (components :: [Type]) :: Bool where
-  HasDuplicateWrites '[] = 'False
-  HasDuplicateWrites (c ': rest) = Or (Contains c rest) (HasDuplicateWrites rest)
-
-class (Functor m) => Access m a where
-  type AccessType a :: [Type]
-  access :: m a
-  default access ::
-    ( Generic a,
-      GenericAccess m (Rep a),
-      ValidAccessInput (GenericAccessType (Rep a)),
-      AccessType a ~ GenericAccessType (Rep a)
-    ) =>
-    m a
-  access = deriveAccess
-  {-# INLINE access #-}
-
-class GenericAccess m f where
-  type GenericAccessType f :: [Type]
-  genericAccess :: (ValidAccessInput (GenericAccessType f)) => m (f p)
-
-instance (Applicative m) => GenericAccess m U1 where
-  type GenericAccessType U1 = '[]
-  genericAccess = pure U1
-  {-# INLINE genericAccess #-}
-
-instance (Access m c) => GenericAccess m (K1 i c) where
-  type GenericAccessType (K1 i c) = AccessType c
-  genericAccess = K1 <$> access
-  {-# INLINE genericAccess #-}
-
-instance (Functor m, GenericAccess m f) => GenericAccess m (M1 i c f) where
-  type GenericAccessType (M1 i c f) = GenericAccessType f
-  genericAccess = M1 <$> genericAccess
-  {-# INLINE genericAccess #-}
-
-instance
-  ( Applicative m,
-    GenericAccess m f,
-    GenericAccess m g,
-    ValidAccessInput (GenericAccessType f),
-    ValidAccessInput (GenericAccessType g)
-  ) =>
-  GenericAccess m (f :*: g)
-  where
-  type GenericAccessType (f :*: g) = GenericAccessType f ++ GenericAccessType g
-  genericAccess = (:*:) <$> genericAccess <*> genericAccess
-  {-# INLINE genericAccess #-}
-
-instance (ECS m, Applicative m, Queryable m a) => Access m (Query a) where
-  type AccessType (Query a) = QueryableAccess a
-  access = queryable
-  {-# INLINE access #-}
-
-instance (Applicative m) => Access m () where
-  type AccessType () = '[]
-  access = pure ()
-  {-# INLINE access #-}
-
-deriveAccess ::
-  forall a m cs.
-  ( Functor m,
-    Generic a,
-    GenericAccess m (Rep a),
-    ValidAccessInput (GenericAccessType (Rep a))
-  ) =>
-  m a
-deriveAccess = to <$> genericAccess
-{-# INLINE deriveAccess #-}
-
-type family DeriveAccessType (rep :: Type -> Type) :: [Type] where
-  DeriveAccessType rep = GenericAccessType rep
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType a ++ AccessType b)
-  ) =>
-  Access m (a, b)
-  where
-  type AccessType (a, b) = AccessType a ++ AccessType b
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    Access m c,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType c),
-    ValidAccessInput (AccessType b ++ AccessType c),
-    ValidAccessInput (AccessType a ++ (AccessType b ++ AccessType c))
-  ) =>
-  Access m (a, b, c)
-  where
-  type AccessType (a, b, c) = AccessType a ++ (AccessType b ++ AccessType c)
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    Access m c,
-    Access m d,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType c),
-    ValidAccessInput (AccessType d),
-    ValidAccessInput (AccessType a ++ AccessType b),
-    ValidAccessInput (AccessType c ++ AccessType d),
-    ValidAccessInput
-      ( (AccessType a ++ AccessType b)
-          ++ (AccessType c ++ AccessType d)
-      )
-  ) =>
-  Access m (a, b, c, d)
-  where
-  type
-    AccessType (a, b, c, d) =
-      ((AccessType a ++ AccessType b) ++ (AccessType c ++ AccessType d))
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    Access m c,
-    Access m d,
-    Access m e,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType c),
-    ValidAccessInput (AccessType d),
-    ValidAccessInput (AccessType e),
-    ValidAccessInput (AccessType a ++ AccessType b),
-    ValidAccessInput (AccessType c ++ (AccessType d ++ AccessType e)),
-    ValidAccessInput (AccessType d ++ AccessType e),
-    ValidAccessInput
-      ( (AccessType a ++ AccessType b)
-          ++ (AccessType c ++ (AccessType d ++ AccessType e))
-      )
-  ) =>
-  Access m (a, b, c, d, e)
-  where
-  type
-    AccessType (a, b, c, d, e) =
-      ( (AccessType a ++ AccessType b)
-          ++ (AccessType c ++ (AccessType d ++ AccessType e))
-      )
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    Access m c,
-    Access m d,
-    Access m e,
-    Access m f,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType c),
-    ValidAccessInput (AccessType d),
-    ValidAccessInput (AccessType e),
-    ValidAccessInput (AccessType f),
-    ValidAccessInput (AccessType e ++ AccessType f),
-    ValidAccessInput (AccessType d ++ (AccessType e ++ AccessType f)),
-    ValidAccessInput (AccessType a ++ (AccessType b ++ AccessType c)),
-    ValidAccessInput (AccessType b ++ AccessType c),
-    ValidAccessInput
-      ( (AccessType a ++ (AccessType b ++ AccessType c))
-          ++ (AccessType d ++ (AccessType e ++ AccessType f))
-      )
-  ) =>
-  Access m (a, b, c, d, e, f)
-  where
-  type
-    AccessType (a, b, c, d, e, f) =
-      ( (AccessType a ++ (AccessType b ++ AccessType c))
-          ++ (AccessType d ++ (AccessType e ++ AccessType f))
-      )
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    Access m c,
-    Access m d,
-    Access m e,
-    Access m f,
-    Access m g,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType c),
-    ValidAccessInput (AccessType d),
-    ValidAccessInput (AccessType e),
-    ValidAccessInput (AccessType f),
-    ValidAccessInput (AccessType g),
-    ValidAccessInput (AccessType b ++ AccessType c),
-    ValidAccessInput (AccessType d ++ AccessType e),
-    ValidAccessInput (AccessType f ++ AccessType g),
-    ValidAccessInput (AccessType a ++ (AccessType b ++ AccessType c)),
-    ValidAccessInput ((AccessType d ++ AccessType e) ++ (AccessType f ++ AccessType g)),
-    ValidAccessInput
-      ( (AccessType a ++ (AccessType b ++ AccessType c))
-          ++ ((AccessType d ++ AccessType e) ++ (AccessType f ++ AccessType g))
-      )
-  ) =>
-  Access m (a, b, c, d, e, f, g)
-  where
-  type
-    AccessType (a, b, c, d, e, f, g) =
-      ( (AccessType a ++ (AccessType b ++ AccessType c))
-          ++ ((AccessType d ++ AccessType e) ++ (AccessType f ++ AccessType g))
-      )
-
-instance
-  ( Applicative m,
-    Access m a,
-    Access m b,
-    Access m c,
-    Access m d,
-    Access m e,
-    Access m f,
-    Access m g,
-    Access m h,
-    ValidAccessInput (AccessType a),
-    ValidAccessInput (AccessType b),
-    ValidAccessInput (AccessType c),
-    ValidAccessInput (AccessType d),
-    ValidAccessInput (AccessType e),
-    ValidAccessInput (AccessType f),
-    ValidAccessInput (AccessType g),
-    ValidAccessInput (AccessType h),
-    ValidAccessInput (AccessType a ++ AccessType b),
-    ValidAccessInput (AccessType c ++ AccessType d),
-    ValidAccessInput (AccessType e ++ AccessType f),
-    ValidAccessInput (AccessType g ++ AccessType h),
-    ValidAccessInput ((AccessType a ++ AccessType b) ++ (AccessType c ++ AccessType d)),
-    ValidAccessInput ((AccessType e ++ AccessType f) ++ (AccessType g ++ AccessType h)),
-    ValidAccessInput
-      ( ((AccessType a ++ AccessType b) ++ (AccessType c ++ AccessType d))
-          ++ ((AccessType e ++ AccessType f) ++ (AccessType g ++ AccessType h))
-      )
-  ) =>
-  Access m (a, b, c, d, e, f, g, h)
-  where
-  type
-    AccessType (a, b, c, d, e, f, g, h) =
-      ( ((AccessType a ++ AccessType b) ++ (AccessType c ++ AccessType d))
-          ++ ((AccessType e ++ AccessType f) ++ (AccessType g ++ AccessType h))
-      )
− src/Aztecs/ECS/Bundle.hs 
@@ -1,12 +0,0 @@-module Aztecs.ECS.Bundle (Bundle (..)) where
-
--- | Bundle of components that can be stored in an entity.
-newtype Bundle e m = Bundle {runBundle :: e -> m ()}
-
-instance (Monad m) => Semigroup (Bundle e m) where
-  Bundle f <> Bundle g = Bundle $ \entity -> f entity >> g entity
-  {-# INLINE (<>) #-}
-
-instance (Monad m) => Monoid (Bundle e m) where
-  mempty = Bundle $ \_ -> return ()
-  {-# INLINE mempty #-}
− src/Aztecs/ECS/Bundle/Class.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}
-
-module Aztecs.ECS.Bundle.Class (Bundleable (..)) where
-
-import Aztecs.ECS.Bundle
-import Aztecs.ECS.Class
-
-class Bundleable c m where
-  bundle :: c -> Bundle (Entity m) m
− src/Aztecs/ECS/Class.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE TypeFamilies #-}
-
-module Aztecs.ECS.Class (ECS (..)) where
-
-import Aztecs.ECS.Bundle
-import Data.Kind
-
--- | Entity Component System (ECS) implementation.
-class ECS m where
-  -- | Entity identifier.
-  type Entity m :: Type
-
-  -- | Task monad for running systems.
-  type Task m :: Type -> Type
-
-  -- | Spawn a new entity with a `Bundle` of components.
-  spawn :: Bundle (Entity m) m -> m (Entity m)
-
-  -- | Insert a `Bundle` of components into an existing entity
-  -- (otherwise this will do nothing).
-  insert :: Entity m -> Bundle (Entity m) m -> m ()
-
-  -- | Remove an entity and its components.
-  remove :: Entity m -> m ()
-
-  -- | Run a `Task`.
-  task :: (Task m) a -> m a
− src/Aztecs/ECS/Commands.hs 
@@ -1,61 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.Commands where
-
-import Aztecs.ECS.Query.Class
-import Control.Monad.IO.Class
-import Control.Monad.Primitive
-import Control.Monad.Trans
-
-newtype Commands t m a = Commands {unCommands :: m (a, t m ())}
-  deriving (Functor)
-
-instance (Monad (t m), Monad m) => Applicative (Commands t m) where
-  pure x = Commands $ pure (x, pure ())
-  {-# INLINE pure #-}
-  Commands mf <*> Commands mx = Commands $ do
-    (f, w1) <- mf
-    (x, w2) <- mx
-    return (f x, w1 >> w2)
-  {-# INLINE (<*>) #-}
-
-instance (Monad (t m), Monad m) => Monad (Commands t m) where
-  Commands mx >>= f = Commands $ do
-    (x, w1) <- mx
-    (y, w2) <- unCommands (f x)
-    return (y, w1 >> w2)
-  {-# INLINE (>>=) #-}
-
-instance (MonadTrans t) => MonadTrans (Commands t) where
-  lift m = Commands $ do
-    x <- m
-    return (x, lift $ pure ())
-  {-# INLINE lift #-}
-
-instance (MonadTrans t, Monad (t m), MonadIO m) => MonadIO (Commands t m) where
-  liftIO io = Commands $ do
-    x <- liftIO io
-    return (x, lift $ pure ())
-  {-# INLINE liftIO #-}
-
-instance (MonadTrans t, Monad (t m), PrimMonad m) => PrimMonad (Commands t m) where
-  type PrimState (Commands t m) = PrimState m
-  primitive f = Commands $ do
-    x <- primitive f
-    return (x, lift $ pure ())
-  {-# INLINE primitive #-}
-
-runCommands :: (MonadTrans t, Monad (t m), Monad m) => Commands t m a -> t m a
-runCommands (Commands m) = do
-  (result, action) <- lift m
-  action
-  return result
-{-# INLINE runCommands #-}
-
-queue :: (Applicative m) => t m () -> Commands t m ()
-queue action = Commands $ pure ((), action)
-{-# INLINE queue #-}
src/Aztecs/ECS/Component.hs view
@@ -1,37 +1,41 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Aztecs.ECS.Component where
-
-import Aztecs.ECS.Class
-import Data.Kind
-
--- | Component lifecycle hooks.
-data Hooks m = Hooks
-  { -- | Hook called when a component is inserted.
-    onInsert :: Entity m -> m (),
-    -- | Hook called when a component is removed.
-    onRemove :: Entity m -> m ()
-  }
-
-instance (Monad m) => Semigroup (Hooks m) where
-  h1 <> h2 =
-    Hooks
-      { onInsert = \e -> onInsert h1 e >> onInsert h2 e,
-        onRemove = \e -> onRemove h1 e >> onRemove h2 e
-      }
-
-instance (Monad m) => Monoid (Hooks m) where
-  mempty =
-    Hooks
-      { onInsert = \_ -> return (),
-        onRemove = \_ -> return ()
-      }
-
-class (Monad m) => Component m a where
-  type ComponentStorage (m :: Type -> Type) a :: Type -> Type
-
-  -- | Component lifecycle `Hooks`.
-  componentHooks :: proxy a -> Hooks m
-  componentHooks _ = mempty
+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.Component+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Component where++import Aztecs.ECS.World.Storage+import Data.Typeable+import Data.Vector (Vector)+import GHC.Generics++-- | Unique component identifier.+--+-- @since 0.9+newtype ComponentID = ComponentID+  { -- | Unique integer identifier.+    --+    -- @since 0.9+    unComponentId :: Int+  }+  deriving (Eq, Ord, Show, Generic)++-- | Component that can be stored in the `World`.+--+-- @since 0.9+class (Typeable a, Storage a (StorageT a)) => Component a where+  -- | `Storage` of this component.+  --+  -- @since 0.9+  type StorageT a++  type StorageT a = Vector a
+ src/Aztecs/ECS/Entity.hs view
@@ -0,0 +1,25 @@+{-# 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 GHC.Generics++-- | Unique entity identifier.+--+-- @since 0.9+newtype EntityID = EntityID+  { -- | Unique integer identifier.+    --+    -- @since 0.9+    unEntityId :: Int+  }+  deriving (Eq, Ord, Show, Generic)
− src/Aztecs/ECS/Executor.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.Executor where
-
-import Aztecs.ECS.Access.Internal
-import Aztecs.ECS.HSet
-import Aztecs.ECS.System
-
-newtype ExecutorT m a = ExecutorT {runSystems :: ([m ()] -> m ()) -> m a}
-  deriving (Functor)
-
-instance (Applicative m) => Applicative (ExecutorT m) where
-  pure x = ExecutorT $ \_ -> pure x
-  {-# INLINE pure #-}
-  ExecutorT f <*> ExecutorT g = ExecutorT $ \run -> f run <*> g run
-  {-# INLINE (<*>) #-}
-
-instance (Monad m) => Monad (ExecutorT m) where
-  ExecutorT f >>= g = ExecutorT $ \run -> f run >>= \x -> runSystems (g x) run
-  {-# INLINE (>>=) #-}
-
-class Execute' m s where
-  execute' :: s -> [m ()]
-
-instance Execute' m (HSet '[]) where
-  execute' _ = []
-  {-# INLINE execute' #-}
-
-instance
-  {-# OVERLAPS #-}
-  ( Monad m,
-    System m sys,
-    Access m (SystemIn m sys),
-    ValidAccessInput (AccessType (SystemIn m sys))
-  ) =>
-  Execute' m (HSet '[sys])
-  where
-  execute' (HCons system HEmpty) = [access >>= runSystem system]
-  {-# INLINE execute' #-}
-
-instance
-  {-# OVERLAPPABLE #-}
-  ( Monad m,
-    System m sys,
-    Access m (SystemIn m sys),
-    ValidAccessInput (AccessType (SystemIn m sys)),
-    Execute' m (HSet systems)
-  ) =>
-  Execute' m (HSet (sys ': systems))
-  where
-  execute' (HCons s rest) = (access >>= runSystem s) : execute' rest
-  {-# INLINE execute' #-}
-
-class Execute m s where
-  execute :: s -> ExecutorT m ()
-
-instance (Applicative m) => Execute m (HSet '[]) where
-  execute _ = pure ()
-  {-# INLINE execute #-}
-
-instance
-  {-# OVERLAPPING #-}
-  (Monad m, Execute' m systems, Execute m (HSet schedule)) =>
-  Execute m (HSet (systems ': schedule))
-  where
-  execute (HCons system rest) = do
-    ExecutorT $ \run -> run $ execute' system
-    execute rest
-  {-# INLINE execute #-}
− src/Aztecs/ECS/HSet.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.HSet
-  ( HSet (..),
-    Lookup (..),
-    AdjustM (..),
-    Subset (..),
-  )
-where
-
-import Data.Kind
-import Prelude hiding (lookup)
-
-data HSet ts where
-  HEmpty :: HSet '[]
-  HCons :: t -> HSet ts -> HSet (t ': ts)
-
-instance (ShowHSet ts) => Show (HSet ts) where
-  show = showHSet
-  {-# INLINE show #-}
-
-class ShowHSet ts where
-  showHSet :: HSet ts -> String
-
-instance ShowHSet '[] where
-  showHSet _ = "HEmpty"
-  {-# INLINE showHSet #-}
-
-instance (Show t, ShowHSet ts) => ShowHSet (t ': ts) where
-  showHSet (HCons x xs) = "HCons " ++ show x ++ " (" ++ showHSet xs ++ ")"
-  {-# INLINE showHSet #-}
-
-type family Elem (t :: k) (ts :: [k]) :: Bool where
-  Elem t '[] = 'False
-  Elem t (t ': xs) = 'True
-  Elem t (_ ': xs) = Elem t xs
-
-class Lookup (t :: Type) (ts :: [Type]) where
-  lookup :: HSet ts -> t
-
-instance {-# OVERLAPPING #-} Lookup t (t ': ts) where
-  lookup (HCons x _) = x
-  {-# INLINE lookup #-}
-
-instance {-# OVERLAPPABLE #-} (Lookup t ts) => Lookup t (u ': ts) where
-  lookup (HCons _ xs) = lookup xs
-  {-# INLINE lookup #-}
-
-class AdjustM m t ts where
-  adjustM :: (t -> m t) -> HSet ts -> m (HSet ts)
-
-instance {-# OVERLAPPING #-} (Applicative m) => AdjustM m t (t ': ts) where
-  adjustM f (HCons x xs) = HCons <$> f x <*> pure xs
-  {-# INLINE adjustM #-}
-
-instance {-# OVERLAPPABLE #-} (Functor m, AdjustM m t ts) => AdjustM m t (u ': ts) where
-  adjustM f (HCons y xs) = HCons y <$> adjustM f xs
-  {-# INLINE adjustM #-}
-
-class Subset (subset :: [Type]) (superset :: [Type]) where
-  subset :: HSet superset -> HSet subset
-
-instance Subset '[] superset where
-  subset _ = HEmpty
-  {-# INLINE subset #-}
-
-instance (Lookup t superset, Subset ts superset) => Subset (t ': ts) superset where
-  subset hset = HCons (lookup hset) (subset @ts hset)
-  {-# INLINE subset #-}
src/Aztecs/ECS/Query.hs view
@@ -1,19 +1,306 @@-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-
-module Aztecs.ECS.Query where
-
-import Data.Maybe
-
-newtype Query a = Query {unQuery :: [Maybe a]}
-  deriving (Functor, Foldable)
-
-instance Applicative Query where
-  pure x = Query [Just x]
-  {-# INLINE pure #-}
-  Query f <*> Query x = Query $ zipWith (<*>) f x
-  {-# INLINE (<*>) #-}
-
-runQuery :: Query a -> [a]
-runQuery (Query q) = catMaybes q
-{-# INLINE runQuery #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.Query+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+--+-- Query for matching entities.+--+-- === Do notation:+-- > move :: (ArrowQuery arr) => arr () Position+-- > move = proc () -> do+-- >   Velocity v <- Q.fetch -< ()+-- >   Position p <- Q.fetch -< ()+-- >   Q.set -< Position $ p + v+--+-- === Arrow combinators:+-- > move :: (ArrowQuery arr) => arr () Position+-- > move = Q.fetch &&& Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set+--+-- === Applicative combinators:+-- > move :: (ArrowQuery arr) => arr () Position+-- > move = (,) <$> Q.fetch <*> Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set+module Aztecs.ECS.Query+  ( -- * Queries+    Query,+    QueryT (..),+    QueryReaderF (..),+    QueryF (..),+    DynamicQueryReaderF (..),+    DynamicQueryF (..),++    -- ** Running+    all,+    all',+    single,+    single',+    singleMaybe,+    singleMaybe',+    map,+    mapSingle,+    mapSingleMaybe,++    -- ** Conversion+    fromReader,+    toReader,++    -- * Filters+    QueryFilter (..),+    with,+    without,++    -- * Reads and writes+    ReadsWrites (..),+    disjoint,+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Class+import Aztecs.ECS.Query.Dynamic+import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReader (..), with, without)+import qualified Aztecs.ECS.Query.Reader as QR+import Aztecs.ECS.Query.Reader.Class+import Aztecs.ECS.World.Components (Components)+import qualified Aztecs.ECS.World.Components as CS+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Category+import Control.Monad.Identity+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector)+import GHC.Stack+import Prelude hiding (all, id, map, reads, (.))++-- | @since 0.10+type Query = QueryT Identity++-- | Query for matching entities.+--+-- @since 0.10+newtype QueryT m a = Query+  { -- | Run a query, producing a `DynamicQueryT`.+    --+    -- @since 0.10+    runQuery :: Components -> (ReadsWrites, Components, DynamicQueryT m a)+  }+  deriving (Functor)++-- | @since 0.10+instance (Monad m) => Applicative (QueryT m) where+  pure a = Query (mempty,,pure a)+  {-# INLINE pure #-}++  (Query f) <*> (Query g) = Query $ \cs ->+    let !(cIdsG, cs', aQS) = g cs+        !(cIdsF, cs'', bQS) = f cs'+     in (cIdsG <> cIdsF, cs'', bQS <*> aQS)+  {-# INLINE (<*>) #-}++-- | @since 0.10+instance (Monad m) => QueryReaderF (QueryT m) where+  fetch = fromReader fetch+  {-# INLINE fetch #-}++  fetchMaybe = fromReader fetchMaybe+  {-# INLINE fetchMaybe #-}++-- | @since 0.10+instance (Monad m) => DynamicQueryReaderF (QueryT m) where+  entity = fromReader entity+  {-# INLINE entity #-}++  fetchDyn = fromReader . fetchDyn+  {-# INLINE fetchDyn #-}++  fetchMaybeDyn = fromReader . fetchMaybeDyn+  {-# INLINE fetchMaybeDyn #-}++-- | @since 0.10+instance (Monad m) => DynamicQueryF m (QueryT m) where+  adjustDyn f cId q = Query $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', adjustDyn f cId dynQ)+  {-# INLINE adjustDyn #-}++  adjustDyn_ f cId q = Query $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', adjustDyn_ f cId dynQ)+  {-# INLINE adjustDyn_ #-}++  adjustDynM f cId q = Query $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', adjustDynM f cId dynQ)+  {-# INLINE adjustDynM #-}++  setDyn cId q = Query $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', setDyn cId dynQ)+  {-# INLINE setDyn #-}++-- | @since 0.9+instance (Monad m) => QueryF m (QueryT m) where+  adjust :: forall a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m a+  adjust f q = Query $ \cs ->+    let !(cId, cs') = CS.insert @a cs+        !(rws, cs'', dynQ) = runQuery q cs'+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', adjustDyn f cId dynQ)+  {-# INLINE adjust #-}++  adjust_ :: forall a b. (Component a) => (b -> a -> a) -> QueryT m b -> QueryT m ()+  adjust_ f q = Query $ \cs ->+    let !(cId, cs') = CS.insert @a cs+        !(rws, cs'', dynQ) = runQuery q cs'+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', adjustDyn_ f cId dynQ)+  {-# INLINE adjust_ #-}++  adjustM :: forall a b. (Component a, Monad m) => (b -> a -> m a) -> QueryT m b -> QueryT m a+  adjustM f q = Query $ \cs ->+    let !(cId, cs') = CS.insert @a cs+        !(rws, cs'', dynQ) = runQuery q cs'+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', adjustDynM f cId dynQ)+  {-# INLINE adjustM #-}++  set :: forall a. (Component a) => QueryT m a -> QueryT m a+  set q = Query $ \cs ->+    let !(cId, cs') = CS.insert @a cs+        !(rws, cs'', dynQ) = runQuery q cs'+     in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', setDyn cId dynQ)+  {-# INLINE set #-}++-- | Convert a `QueryReader` to a `Query`.+--+-- @since 0.9+fromReader :: (Monad m) => QueryReader a -> QueryT m a+fromReader (QueryReader f) = Query $ \cs ->+  let !(cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ)+{-# INLINE fromReader #-}++-- | Convert a `Query` to a `QueryReader`.+--+-- @since 0.10+toReader :: Query a -> QueryReader a+toReader (Query f) = QueryReader $ \cs ->+  let !(rws, cs', dynQ) = f cs in (reads rws, cs', toDynReader dynQ)+{-# INLINE toReader #-}++-- | Reads and writes of a `Query`.+--+-- @since 0.9+data ReadsWrites = ReadsWrites+  { -- | Component IDs being read.+    --+    -- @since 0.9+    reads :: !(Set ComponentID),+    -- | Component IDs being written.+    --+    -- @since 0.9+    writes :: !(Set ComponentID)+  }+  deriving (Show)++-- | @since 0.9+instance Semigroup ReadsWrites where+  ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2)++-- | @since 0.9+instance Monoid ReadsWrites where+  mempty = ReadsWrites mempty mempty++-- | `True` if the reads and writes of two `Query`s overlap.+--+-- @since 0.9+disjoint :: ReadsWrites -> ReadsWrites -> Bool+disjoint a b =+  Set.disjoint (reads a) (writes b)+    || Set.disjoint (reads b) (writes a)+    || Set.disjoint (writes b) (writes a)++-- | Match all entities.+--+-- @since 0.9+all :: Query a -> Entities -> (Vector a, Entities)+all = QR.all . toReader+{-# INLINE all #-}++-- | Match all entities.+--+-- @since 0.9+all' :: Query a -> Entities -> (Vector a, Components)+all' = QR.all' . toReader+{-# INLINE all' #-}++-- | Match a single entity.+--+-- @since 0.9+single :: (HasCallStack) => Query a -> Entities -> (a, Entities)+single = QR.single . toReader+{-# INLINE single #-}++-- | Match a single entity.+--+-- @since 0.9+single' :: (HasCallStack) => Query a -> Entities -> (a, Components)+single' = QR.single' . toReader+{-# INLINE single' #-}++-- | Match a single entity, or `Nothing`.+--+-- @since 0.9+singleMaybe :: Query a -> Entities -> (Maybe a, Entities)+singleMaybe = QR.singleMaybe . toReader+{-# INLINE singleMaybe #-}++-- | Match a single entity, or `Nothing`.+--+-- @since 0.9+singleMaybe' :: Query a -> Entities -> (Maybe a, Components)+singleMaybe' = QR.singleMaybe' . toReader+{-# INLINE singleMaybe' #-}++-- | Map all matched entities.+--+-- @since 0.9+map :: (Monad m) => QueryT m o -> Entities -> m (Vector o, Entities)+map q es = do+  let !(rws, cs', dynQ) = runQuery q $ components es+      !cIds = reads rws <> writes rws+  (as, es') <- mapDyn cIds dynQ es+  return (as, es' {components = cs'})+{-# INLINE map #-}++-- | Map a single matched entity.+--+-- @since 0.9+mapSingle :: (HasCallStack, Monad m) => QueryT m a -> Entities -> m (a, Entities)+mapSingle q es = do+  let !(rws, cs', dynQ) = runQuery q $ components es+      !cIds = reads rws <> writes rws+  (as, es') <- mapSingleDyn cIds dynQ es+  return (as, es' {components = cs'})+{-# INLINE mapSingle #-}++-- | Map a single matched entity, or `Nothing`.+--+-- @since 0.9+mapSingleMaybe :: (Monad m) => QueryT m a -> Entities -> m (Maybe a, Entities)+mapSingleMaybe q es = do+  let !(rws, cs', dynQ) = runQuery q $ components es+      !cIds = reads rws <> writes rws+  (as, es') <- mapSingleMaybeDyn cIds dynQ es+  return (as, es' {components = cs'})+{-# INLINE mapSingleMaybe #-}
src/Aztecs/ECS/Query/Class.hs view
@@ -1,3 +1,41 @@-module Aztecs.ECS.Query.Class (Queryable (..), With (..), Without (..)) where
-
-import Aztecs.ECS.Query.Internal
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Aztecs.ECS.Query.Reader.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Class (QueryF (..)) where++import Aztecs.ECS.Component+import Control.Monad++-- | Query functor.+--+-- @since 0.10+class (Applicative g, Functor f) => QueryF g f | f -> g where+  -- | Adjust a `Component` by its type.+  --+  -- @since 0.10+  adjust :: (Component a) => (b -> a -> a) -> f b -> f a++  -- | Adjust a `Component` by its type, ignoring any output.+  --+  -- @since 0.10+  adjust_ :: (Component a) => (b -> a -> a) -> f b -> f ()+  adjust_ f = void . adjust f++  -- | Adjust a `Component` by its type with some `Monad` @m@.+  --+  -- @since 0.10+  adjustM :: (Component a) => (b -> a -> g a) -> f b -> f a++  -- | Set a `Component` by its type.+  --+  -- @since 0.10+  set :: (Component a) => f a -> f a
+ src/Aztecs/ECS/Query/Dynamic.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.Query.Dynamic+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Dynamic+  ( -- * Dynamic queries+    DynamicQuery,+    DynamicQueryT (..),+    DynamicQueryReaderF (..),+    DynamicQueryF (..),++    -- ** Conversion+    fromDynReader,+    toDynReader,++    -- ** Running+    mapDyn,+    filterMapDyn,+    mapSingleDyn,+    mapSingleMaybeDyn,++    -- * Dynamic query filters+    DynamicQueryFilter (..),+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Dynamic.Class+import Aztecs.ECS.Query.Dynamic.Reader+import Aztecs.ECS.World.Archetype (Archetype)+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node (..))+import qualified Aztecs.ECS.World.Archetypes as AS+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Monad.Identity+import Data.Foldable+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Stack++type DynamicQuery = DynamicQueryT Identity++-- | Dynamic query for components by ID.+--+-- @since 0.10+newtype DynamicQueryT f a+  = DynamicQuery+  { -- | Run a dynamic query.+    --+    -- @since 0.10+    runDynQuery :: Archetype -> f (Vector a, Archetype)+  }+  deriving (Functor)++-- | @since 0.10+instance (Applicative f) => Applicative (DynamicQueryT f) where+  pure a = DynamicQuery $ \arch -> pure (V.replicate (length $ A.entities arch) a, arch)+  {-# INLINE pure #-}++  f <*> g = DynamicQuery $ \arch -> do+    x <- runDynQuery g arch+    y <- runDynQuery f arch+    return $+      let (as, arch') = x+          (bs, arch'') = y+       in (V.zipWith ($) bs as, arch' <> arch'')+  {-# INLINE (<*>) #-}++-- | @since 0.10+instance DynamicQueryReaderF DynamicQuery where+  entity = fromDynReader entity+  {-# INLINE entity #-}++  fetchDyn = fromDynReader . fetchDyn+  {-# INLINE fetchDyn #-}++  fetchMaybeDyn = fromDynReader . fetchMaybeDyn+  {-# INLINE fetchMaybeDyn #-}++-- | @since 0.10+instance (Monad f) => DynamicQueryF f (DynamicQueryT f) where+  adjustDyn f cId q =+    DynamicQuery (fmap (\(bs, arch') -> A.zipWith bs f cId arch') . runDynQuery q)+  {-# INLINE adjustDyn #-}++  adjustDyn_ f cId q = DynamicQuery $ \arch ->+    fmap (\(bs, arch') -> (V.map (const ()) bs, A.zipWith_ bs f cId arch')) (runDynQuery q arch)+  {-# INLINE adjustDyn_ #-}++  adjustDynM f cId q = DynamicQuery $ \arch -> do+    (bs, arch') <- runDynQuery q arch+    A.zipWithM bs f cId arch'+  {-# INLINE adjustDynM #-}++  setDyn cId q =+    DynamicQuery (fmap (\(bs, arch') -> (bs, A.insertAscVector cId bs arch')) . runDynQuery q)+  {-# INLINE setDyn #-}++-- | Convert a `DynamicQueryReaderT` to a `DynamicQueryT`.+--+-- @since 0.10+fromDynReader :: (Monad m) => DynamicQueryReader a -> DynamicQueryT m a+fromDynReader q = DynamicQuery $ \arch -> do+  let !os = runDynQueryReader q arch+  return (os, arch)+{-# INLINE fromDynReader #-}++-- | Convert a `DynamicQueryT` to a `DynamicQueryReaderT`.+--+-- @since 0.10+toDynReader :: DynamicQuery a -> DynamicQueryReader a+toDynReader q = DynamicQueryReader $ \arch -> fst $ runIdentity $ runDynQuery q arch+{-# INLINE toDynReader #-}++-- | Map all matched entities.+--+-- @since 0.10+mapDyn :: (Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (Vector a, Entities)+mapDyn cIds q es =+  let go = runDynQuery q+   in if Set.null cIds+        then do+          (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es}+          return (as, es)+        else+          let go' (acc, esAcc) (aId, n) = do+                (as', arch') <- go $ nodeArchetype n+                let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc+                return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})+           in foldlM go' (V.empty, es) $ Map.toList . AS.find cIds $ archetypes es+{-# INLINE mapDyn #-}++-- | Map all matched entities.+--+-- @since 0.10+filterMapDyn :: (Monad m) => Set ComponentID -> (Node -> Bool) -> DynamicQueryT m a -> Entities -> m (Vector a, Entities)+filterMapDyn cIds f q es =+  let go = runDynQuery q+   in if Set.null cIds+        then do+          (as, _) <- go A.empty {A.entities = Map.keysSet $ entities es}+          return (as, es)+        else+          let go' (acc, esAcc) (aId, n) = do+                (as', arch') <- go $ nodeArchetype n+                let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc+                return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})+           in foldlM go' (V.empty, es) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es+{-# INLINE filterMapDyn #-}++-- | Map a single matched entity.+--+-- @since 0.10+mapSingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (a, Entities)+mapSingleDyn cIds q es = do+  res <- mapSingleMaybeDyn cIds q es+  return $ case res of+    (Just a, es') -> (a, es')+    _ -> error "mapSingleDyn: expected single matching entity"++-- | Map a single matched entity, or @Nothing@.+--+-- @since 0.10+mapSingleMaybeDyn :: (Monad m) => Set ComponentID -> DynamicQueryT m a -> Entities -> m (Maybe a, Entities)+mapSingleMaybeDyn cIds q es =+  if Set.null cIds+    then case Map.keys $ entities es of+      [eId] -> do+        res <- runDynQuery q $ A.singleton eId+        return $ case res of+          (v, _) | V.length v == 1 -> (Just (V.head v), es)+          _ -> (Nothing, es)+      _ -> pure (Nothing, es)+    else case Map.toList $ AS.find cIds $ archetypes es of+      [(aId, n)] -> do+        res <- runDynQuery q $ AS.nodeArchetype n+        return $ case res of+          (v, arch')+            | V.length v == 1 ->+                let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es+                 in (Just (V.head v), es {archetypes = (archetypes es) {AS.nodes = nodes}})+          _ -> (Nothing, es)+      _ -> pure (Nothing, es)+{-# INLINE mapSingleMaybeDyn #-}
+ src/Aztecs/ECS/Query/Dynamic/Class.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FunctionalDependencies #-}++-- |+-- Module      : Aztecs.ECS.Query.Dynamic.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Dynamic.Class (DynamicQueryF (..)) where++import Aztecs.ECS.Component+import Control.Monad++-- | Dynamic query functor.+--+-- @since 0.10+class (Monad m, Functor f) => DynamicQueryF m f | f -> m where+  -- | Adjust a `Component` by its `ComponentID`.+  --+  -- @since 0.10+  adjustDyn :: (Component a) => (b -> a -> a) -> ComponentID -> f b -> f a++  -- | Adjust a `Component` by its `ComponentID`, ignoring any output.+  --+  -- @since 0.10+  adjustDyn_ :: (Component a) => (b -> a -> a) -> ComponentID -> f b -> f ()+  adjustDyn_ f cId = void . adjustDyn f cId++  -- | Adjust a `Component` by its `ComponentID` with some applicative functor @g@.+  --+  -- @since 0.10+  adjustDynM :: (Monad m, Component a) => (b -> a -> m a) -> ComponentID -> f b -> f a++  -- | Set a `Component` by its `ComponentID`.+  --+  -- @since 0.10+  setDyn :: (Component a) => ComponentID -> f a -> f a
+ src/Aztecs/ECS/Query/Dynamic/Reader.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Aztecs.ECS.Query.Dynamic.Reader+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Dynamic.Reader+  ( -- * Dynamic queries+    DynamicQueryReader (..),+    DynamicQueryReaderF (..),++    -- ** Running+    allDyn,+    filterDyn,+    singleDyn,+    singleMaybeDyn,++    -- * Dynamic query filters+    DynamicQueryFilter (..),+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Dynamic.Reader.Class+import Aztecs.ECS.World.Archetype (Archetype)+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node)+import qualified Aztecs.ECS.World.Archetypes as AS+import Aztecs.ECS.World.Entities (Entities (..))+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Stack++-- | Dynamic query reader.+--+-- @since 0.10+newtype DynamicQueryReader a = DynamicQueryReader+  { -- | Run a dynamic query reader.+    --+    -- @since 0.10+    runDynQueryReader :: Archetype -> Vector a+  }+  deriving (Functor)++-- | @since 0.10+instance Applicative DynamicQueryReader where+  pure a = DynamicQueryReader $ \arch -> V.replicate (length $ A.entities arch) a+  {-# INLINE pure #-}++  f <*> g = DynamicQueryReader $ \arch ->+    V.zipWith ($) (runDynQueryReader f arch) $ runDynQueryReader g arch+  {-# INLINE (<*>) #-}++-- | @since 0.10+instance DynamicQueryReaderF DynamicQueryReader where+  entity = DynamicQueryReader $ \arch -> V.fromList . Set.toList $ A.entities arch+  {-# INLINE entity #-}++  fetchDyn cId = DynamicQueryReader $ \arch -> A.lookupComponentsAsc cId arch+  {-# INLINE fetchDyn #-}++  fetchMaybeDyn cId = DynamicQueryReader $ \arch -> case A.lookupComponentsAscMaybe cId arch of+    Just as -> V.map Just as+    Nothing -> V.replicate (length $ A.entities arch) Nothing+  {-# INLINE fetchMaybeDyn #-}++-- | Dynamic query for components by ID.+--+-- @since 0.9++-- | Dynamic query filter.+--+-- @since 0.9+data DynamicQueryFilter = DynamicQueryFilter+  { -- | `ComponentID`s to include.+    --+    -- @since 0.9+    filterWith :: !(Set ComponentID),+    -- | `ComponentID`s to exclude.+    --+    -- @since 0.9+    filterWithout :: !(Set ComponentID)+  }++-- | @since 0.9+instance Semigroup DynamicQueryFilter where+  DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB =+    DynamicQueryFilter (withA <> withB) (withoutA <> withoutB)++-- | @since 0.9+instance Monoid DynamicQueryFilter where+  mempty = DynamicQueryFilter mempty mempty++-- | Match all entities.+--+-- @since 0.10+allDyn :: Set ComponentID -> DynamicQueryReader a -> Entities -> Vector a+allDyn cIds q es =+  if Set.null cIds+    then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities es}+    else+      let go n = runDynQueryReader q $ AS.nodeArchetype n+       in V.concat . fmap go . Map.elems $ AS.find cIds $ archetypes es++-- | Match all entities with a filter.+--+-- @since 0.10+filterDyn :: Set ComponentID -> (Node -> Bool) -> DynamicQueryReader a -> Entities -> Vector a+filterDyn cIds f q es =+  if Set.null cIds+    then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities es}+    else+      let go n = runDynQueryReader q $ AS.nodeArchetype n+       in V.concat . fmap go . Map.elems . Map.filter f $ AS.find cIds $ archetypes es++-- | Match a single entity.+--+-- @since 0.10+singleDyn :: (HasCallStack) => Set ComponentID -> DynamicQueryReader a -> Entities -> a+singleDyn cIds q es = case singleMaybeDyn cIds q es of+  Just a -> a+  _ -> error "singleDyn: expected a single entity"++-- | Match a single entity, or `Nothing`.+--+-- @since 0.10+singleMaybeDyn :: Set ComponentID -> DynamicQueryReader a -> Entities -> Maybe a+singleMaybeDyn cIds q es =+  if Set.null cIds+    then case Map.keys $ entities es of+      [eId] -> case runDynQueryReader q $ A.singleton eId of+        v | V.length v == 1 -> Just (V.head v)+        _ -> Nothing+      _ -> Nothing+    else case Map.elems $ AS.find cIds $ archetypes es of+      [n] -> case runDynQueryReader q $ AS.nodeArchetype n of+        v | V.length v == 1 -> Just (V.head v)+        _ -> Nothing+      _ -> Nothing
+ src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs view
@@ -0,0 +1,32 @@+-- |+-- Module      : Aztecs.ECS.Query.Dynamic.Reader.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Dynamic.Reader.Class (DynamicQueryReaderF (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity++-- | Dynamic query reader functor.+--+-- @since 0.10+class (Functor f) => DynamicQueryReaderF f where+  -- | Fetch the currently matched `EntityID`.+  --+  -- @since 0.10+  entity :: f EntityID++  -- | Fetch a `Component` by its `ComponentID`.+  --+  -- @since 0.10+  fetchDyn :: (Component a) => ComponentID -> f a++  -- | Try to fetch a `Component` by its `ComponentID`.+  --+  -- @since 0.10+  fetchMaybeDyn :: (Component a) => ComponentID -> f (Maybe a)+  fetchMaybeDyn cId = Just <$> fetchDyn cId
− src/Aztecs/ECS/Query/Internal.hs 
@@ -1,274 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.Query.Internal where
-
-import qualified Aztecs.ECS.HSet as HS
-import Aztecs.ECS.Query
-import Data.Kind
-import Data.Maybe
-import GHC.Generics
-import Prelude hiding (Read)
-
-type family (++) (xs :: [Type]) (ys :: [Type]) :: [Type] where
-  '[] ++ ys = ys
-  (x ': xs) ++ ys = x ': (xs ++ ys)
-
-type family AccessToComponents (accesses :: [Type]) :: [Type] where
-  AccessToComponents '[] = '[]
-  AccessToComponents (Read a ': rest) = a ': AccessToComponents rest
-  AccessToComponents (Write a ': rest) = a ': AccessToComponents rest
-  AccessToComponents (With a ': rest) = a ': AccessToComponents rest
-  AccessToComponents (Without a ': rest) = AccessToComponents rest
-
-type family ReadComponents (accesses :: [Type]) :: [Type] where
-  ReadComponents '[] = '[]
-  ReadComponents (Read a ': rest) = a ': ReadComponents rest
-  ReadComponents (Write a ': rest) = ReadComponents rest
-  ReadComponents (With a ': rest) = ReadComponents rest
-  ReadComponents (Without a ': rest) = ReadComponents rest
-
-type family WriteComponents (accesses :: [Type]) :: [Type] where
-  WriteComponents '[] = '[]
-  WriteComponents (Read a ': rest) = WriteComponents rest
-  WriteComponents (Write a ': rest) = a ': WriteComponents rest
-  WriteComponents (With a ': rest) = WriteComponents rest
-  WriteComponents (Without a ': rest) = WriteComponents rest
-
-type family WithComponents (accesses :: [Type]) :: [Type] where
-  WithComponents '[] = '[]
-  WithComponents (Read a ': rest) = WithComponents rest
-  WithComponents (Write a ': rest) = WithComponents rest
-  WithComponents (With a ': rest) = a ': WithComponents rest
-  WithComponents (Without a ': rest) = WithComponents rest
-
-type family WithoutComponents (accesses :: [Type]) :: [Type] where
-  WithoutComponents '[] = '[]
-  WithoutComponents (Read a ': rest) = WithoutComponents rest
-  WithoutComponents (Write a ': rest) = WithoutComponents rest
-  WithoutComponents (With a ': rest) = WithoutComponents rest
-  WithoutComponents (Without a ': rest) = a ': WithoutComponents rest
-
-type family Contains (a :: Type) (list :: [Type]) :: Bool where
-  Contains a '[] = 'False
-  Contains a (a ': rest) = 'True
-  Contains a (b ': rest) = Contains a rest
-
-type family HasOverlap (list1 :: [Type]) (list2 :: [Type]) :: Bool where
-  HasOverlap '[] list2 = 'False
-  HasOverlap (a ': rest) list2 = Or (Contains a list2) (HasOverlap rest list2)
-
-type family HasDuplicates (list :: [Type]) :: Bool where
-  HasDuplicates '[] = 'False
-  HasDuplicates (a ': rest) = Or (Contains a rest) (HasDuplicates rest)
-
-type family ValidateAccess (accesses :: [Type]) :: Bool where
-  ValidateAccess accesses =
-    And
-      (Not (HasOverlap (WriteComponents accesses) (ReadComponents accesses)))
-      (Not (HasDuplicates (WriteComponents accesses)))
-
-type family And (a :: Bool) (b :: Bool) :: Bool where
-  And 'True 'True = 'True
-  And 'True 'False = 'False
-  And 'False 'True = 'False
-  And 'False 'False = 'False
-
-type family Or (a :: Bool) (b :: Bool) :: Bool where
-  Or 'True _ = 'True
-  Or 'False 'True = 'True
-  Or 'False 'False = 'False
-
-type family Not (b :: Bool) :: Bool where
-  Not 'True = 'False
-  Not 'False = 'True
-
-type ValidAccess accesses = (ValidateAccess accesses ~ 'True)
-
-data Read (a :: Type)
-
-data Write (a :: Type)
-
-data With (a :: Type) = With
-
-data Without (a :: Type) = Without
-
-type family AccessComponent (access :: Type) :: Type where
-  AccessComponent (Read a) = a
-  AccessComponent (Write a) = a
-  AccessComponent (With a) = a
-  AccessComponent (Without a) = a
-
-type family GenericQueryableAccess (f :: Type -> Type) :: [Type] where
-  GenericQueryableAccess (M1 _ _ f) = GenericQueryableAccess f
-  GenericQueryableAccess (f :*: g) = GenericQueryableAccess f ++ GenericQueryableAccess g
-  GenericQueryableAccess (K1 _ a) = QueryableAccess a
-  GenericQueryableAccess U1 = '[]
-
-class GenericQueryable m (f :: Type -> Type) where
-  genericQueryableRep :: m [Maybe (f p)]
-
-instance (Monad m) => GenericQueryable m U1 where
-  genericQueryableRep = pure [Just U1]
-  {-# INLINE genericQueryableRep #-}
-
-instance
-  ( Monad m,
-    GenericQueryable m f,
-    GenericQueryable m g
-  ) =>
-  GenericQueryable m (f :*: g)
-  where
-  genericQueryableRep = do
-    fs <- genericQueryableRep
-    zipWith (\f g -> (:*:) <$> f <*> g) fs <$> genericQueryableRep
-  {-# INLINE genericQueryableRep #-}
-
-instance (Functor m, GenericQueryable m f) => GenericQueryable m (M1 i c f) where
-  genericQueryableRep = map (fmap M1) <$> genericQueryableRep
-  {-# INLINE genericQueryableRep #-}
-
-instance (Functor m, Queryable m a) => GenericQueryable m (K1 i a) where
-  genericQueryableRep = fmap (map (fmap K1) . unQuery) queryable
-  {-# INLINE genericQueryableRep #-}
-
-class Queryable m a where
-  type QueryableAccess a :: [Type]
-  type QueryableAccess a = GenericQueryableAccess (Rep a)
-
-  queryable :: m (Query a)
-  default queryable ::
-    ( Functor m,
-      Generic a,
-      GenericQueryable m (Rep a),
-      QueryableAccess a ~ GenericQueryableAccess (Rep a),
-      ValidAccess (QueryableAccess a)
-    ) =>
-    m (Query a)
-  queryable = fmap (Query . map (fmap to)) genericQueryableRep
-  {-# INLINE queryable #-}
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    ValidAccess (QueryableAccess a ++ QueryableAccess b)
-  ) =>
-  Queryable m (a, b)
-  where
-  type QueryableAccess (a, b) = QueryableAccess a ++ QueryableAccess b
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    Queryable m c,
-    ValidAccess (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
-  ) =>
-  Queryable m (a, b, c)
-  where
-  type QueryableAccess (a, b, c) = QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c)
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    Queryable m c,
-    Queryable m d,
-    ValidAccess
-      ((QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d))
-  ) =>
-  Queryable m (a, b, c, d)
-  where
-  type QueryableAccess (a, b, c, d) = (QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d)
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    Queryable m c,
-    Queryable m d,
-    Queryable m e,
-    ValidAccess
-      ( (QueryableAccess a ++ QueryableAccess b)
-          ++ (QueryableAccess c ++ (QueryableAccess d ++ QueryableAccess e))
-      )
-  ) =>
-  Queryable m (a, b, c, d, e)
-  where
-  type
-    QueryableAccess (a, b, c, d, e) =
-      (QueryableAccess a ++ QueryableAccess b)
-        ++ (QueryableAccess c ++ (QueryableAccess d ++ QueryableAccess e))
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    Queryable m c,
-    Queryable m d,
-    Queryable m e,
-    Queryable m f,
-    ValidAccess
-      ( (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
-          ++ (QueryableAccess d ++ (QueryableAccess e ++ QueryableAccess f))
-      )
-  ) =>
-  Queryable m (a, b, c, d, e, f)
-  where
-  type
-    QueryableAccess (a, b, c, d, e, f) =
-      ( (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
-          ++ (QueryableAccess d ++ (QueryableAccess e ++ QueryableAccess f))
-      )
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    Queryable m c,
-    Queryable m d,
-    Queryable m e,
-    Queryable m f,
-    Queryable m g,
-    ValidAccess
-      ( (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
-          ++ ((QueryableAccess d ++ QueryableAccess e) ++ (QueryableAccess f ++ QueryableAccess g))
-      )
-  ) =>
-  Queryable m (a, b, c, d, e, f, g)
-  where
-  type
-    QueryableAccess (a, b, c, d, e, f, g) =
-      (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
-        ++ ((QueryableAccess d ++ QueryableAccess e) ++ (QueryableAccess f ++ QueryableAccess g))
-
-instance
-  ( Monad m,
-    Queryable m a,
-    Queryable m b,
-    Queryable m c,
-    Queryable m d,
-    Queryable m e,
-    Queryable m f,
-    Queryable m g,
-    Queryable m h,
-    ValidAccess
-      ( ((QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d))
-          ++ ((QueryableAccess e ++ QueryableAccess f) ++ (QueryableAccess g ++ QueryableAccess h))
-      )
-  ) =>
-  Queryable m (a, b, c, d, e, f, g, h)
-  where
-  type
-    QueryableAccess (a, b, c, d, e, f, g, h) =
-      ((QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d))
-        ++ ((QueryableAccess e ++ QueryableAccess f) ++ (QueryableAccess g ++ QueryableAccess h))
+ src/Aztecs/ECS/Query/Reader.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.Query.Dynamic+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Reader+  ( -- * Queries+    QueryReader (..),+    QueryReaderF (..),+    DynamicQueryReaderF (..),++    -- ** Running+    all,+    all',+    single,+    single',+    singleMaybe,+    singleMaybe',++    -- * Filters+    QueryFilter (..),+    with,+    without,+    DynamicQueryFilter (..),+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Dynamic.Reader+import Aztecs.ECS.Query.Reader.Class+import Aztecs.ECS.World.Components (Components)+import qualified Aztecs.ECS.World.Components as CS+import Aztecs.ECS.World.Entities (Entities (..))+import qualified Aztecs.ECS.World.Entities as E+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector)+import GHC.Stack+import Prelude hiding (all)++-- | Query to read from entities.+--+-- @since 0.10+newtype QueryReader a+  = QueryReader+  { -- | Run a query reader.+    --+    -- @since 0.10+    runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReader a)+  }+  deriving (Functor)++-- | @since 0.10+instance Applicative QueryReader where+  pure a = QueryReader (mempty,,pure a)+  {-# INLINE pure #-}++  (QueryReader f) <*> (QueryReader g) = QueryReader $ \cs ->+    let !(cIdsG, cs', aQS) = g cs+        !(cIdsF, cs'', bQS) = f cs'+     in (cIdsG <> cIdsF, cs'', bQS <*> aQS)+  {-# INLINE (<*>) #-}++-- | @since 0.10+instance QueryReaderF QueryReader where+  fetch :: forall a. (Component a) => QueryReader a+  fetch = QueryReader $ \cs ->+    let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchDyn cId)+  {-# INLINE fetch #-}++  fetchMaybe :: forall a. (Component a) => QueryReader (Maybe a)+  fetchMaybe = QueryReader $ \cs ->+    let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchMaybeDyn cId)+  {-# INLINE fetchMaybe #-}++-- | @since 0.10+instance DynamicQueryReaderF QueryReader where+  entity = QueryReader (mempty,,entity)+  {-# INLINE entity #-}++  fetchDyn cId = QueryReader (Set.singleton cId,,fetchDyn cId)+  {-# INLINE fetchDyn #-}++  fetchMaybeDyn cId = QueryReader (Set.singleton cId,,fetchMaybeDyn cId)+  {-# INLINE fetchMaybeDyn #-}++-- | Filter for a `Query`.+--+-- @since 0.9+newtype QueryFilter = QueryFilter+  { -- | Run a query filter.+    runQueryFilter :: Components -> (DynamicQueryFilter, Components)+  }++-- | @since 0.9+instance Semigroup QueryFilter where+  a <> b =+    QueryFilter+      ( \cs ->+          let !(withA', cs') = runQueryFilter a cs+              !(withB', cs'') = runQueryFilter b cs'+           in (withA' <> withB', cs'')+      )++-- | @since 0.9+instance Monoid QueryFilter where+  mempty = QueryFilter (mempty,)++-- | Filter for entities containing this component.+--+-- @since 0.9+with :: forall a. (Component a) => QueryFilter+with = QueryFilter $ \cs ->+  let !(cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')++-- | Filter out entities containing this component.+--+-- @since 0.9+without :: forall a. (Component a) => QueryFilter+without = QueryFilter $ \cs ->+  let !(cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')++-- | Match all entities.+--+-- @since 0.10+all :: QueryReader a -> Entities -> (Vector a, Entities)+all q es = let !(as, cs) = all' q es in (as, es {E.components = cs})+{-# INLINE all #-}++-- | Match all entities.+--+-- @since 0.10+all' :: QueryReader a -> Entities -> (Vector a, Components)+all' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (allDyn rs dynQ es, cs')+{-# INLINE all' #-}++-- | Match a single entity.+--+-- @since 0.10+single :: (HasCallStack) => QueryReader a -> Entities -> (a, Entities)+single q es = let !(a, cs) = single' q es in (a, es {E.components = cs})+{-# INLINE single #-}++-- | Match a single entity.+--+-- @since 0.10+single' :: (HasCallStack) => QueryReader a -> Entities -> (a, Components)+single' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleDyn rs dynQ es, cs')+{-# INLINE single' #-}++-- | Match a single entity.+--+-- @since 0.10+singleMaybe :: QueryReader a -> Entities -> (Maybe a, Entities)+singleMaybe q es = let !(a, cs) = singleMaybe' q es in (a, es {E.components = cs})+{-# INLINE singleMaybe #-}++-- | Match a single entity.+--+-- @since 0.10+singleMaybe' :: QueryReader a -> Entities -> (Maybe a, Components)+singleMaybe' q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleMaybeDyn rs dynQ es, cs')+{-# INLINE singleMaybe' #-}
+ src/Aztecs/ECS/Query/Reader/Class.hs view
@@ -0,0 +1,26 @@+-- |+-- Module      : Aztecs.ECS.Query.Reader.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.Query.Reader.Class (QueryReaderF (..)) where++import Aztecs.ECS.Component++-- | Query reader functor.+--+-- @since 0.10+class (Functor f) => QueryReaderF f where+  -- | Fetch a `Component` by its type.+  --+  -- @since 0.10+  fetch :: (Component a) => f a++  -- | Fetch a `Component` by its type, returning `Nothing` if it doesn't exist.+  --+  -- @since 0.10+  fetchMaybe :: (Component a) => f (Maybe a)+  fetchMaybe = Just <$> fetch
− src/Aztecs/ECS/R.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}
-
-module Aztecs.ECS.R (R (..)) where
-
--- | Read-only 'Queryable' component access.
-newtype R a = R {unR :: a}
-  deriving (Show, Eq, Functor)
− src/Aztecs/ECS/Schedule.hs 
@@ -1,3 +0,0 @@-module Aztecs.ECS.Schedule (Schedule (..)) where
-
-import Aztecs.ECS.Schedule.Internal
− src/Aztecs/ECS/Schedule/Internal.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.Schedule.Internal where
-
-import Aztecs.ECS.Access.Internal
-import Aztecs.ECS.HSet
-import Aztecs.ECS.Query.Internal
-import Aztecs.ECS.System
-import Data.Kind
-
-class Schedule m s where
-  type Scheduled m s :: Type
-
-  schedule :: s -> Scheduled m s
-
-type family SystemInOf m sys :: [Type] where
-  SystemInOf m sys = AccessType (SystemIn m sys)
-
-type family HasInputOverlap (inputs1 :: [Type]) (inputs2 :: [Type]) :: Bool where
-  HasInputOverlap inputs1 inputs2 =
-    Or
-      (HasComponentOverlap (WriteComponents inputs1) (AccessToComponents inputs2))
-      (HasComponentOverlap (WriteComponents inputs2) (AccessToComponents inputs1))
-
-type family HasComponentOverlap (components1 :: [Type]) (components2 :: [Type]) :: Bool where
-  HasComponentOverlap '[] components2 = 'False
-  HasComponentOverlap (c ': rest) components2 =
-    Or (Contains c components2) (HasComponentOverlap rest components2)
-
-type family GroupSystems m (systems :: [Type]) :: [[Type]] where
-  GroupSystems m '[] = '[]
-  GroupSystems m '[sys] = '[ '[sys]]
-  GroupSystems m (sys1 ': sys2 ': rest) =
-    If
-      (HasInputOverlap (SystemInOf m sys1) (SystemInOf m sys2))
-      (GroupSystemsConflict m (sys1 ': sys2 ': rest))
-      (GroupSystemsNoConflict m (sys1 ': sys2 ': rest))
-
-type family GroupSystemsConflict m (systems :: [Type]) :: [[Type]] where
-  GroupSystemsConflict m (sys ': rest) = '[sys] ': GroupSystems m rest
-
-type family GroupSystemsNoConflict m (systems :: [Type]) :: [[Type]] where
-  GroupSystemsNoConflict m (sys1 ': sys2 ': rest) =
-    MergeCompatibleSystems m '[sys1, sys2] rest
-
-type family MergeCompatibleSystems m (group :: [Type]) (remaining :: [Type]) :: [[Type]] where
-  MergeCompatibleSystems m group '[] = '[group]
-  MergeCompatibleSystems m group (sys ': rest) =
-    If
-      (CanAddSystemToGroup m sys group)
-      (MergeCompatibleSystems m (AppendToGroup sys group) rest)
-      (group ': GroupSystems m (sys ': rest))
-
-type family CanAddSystemToGroup m (sys :: Type) (group :: [Type]) :: Bool where
-  CanAddSystemToGroup m sys '[] = 'True
-  CanAddSystemToGroup m sys (groupSys ': rest) =
-    And
-      (Not (HasInputOverlap (SystemInOf m sys) (SystemInOf m groupSys)))
-      (CanAddSystemToGroup m sys rest)
-
-type family AppendToGroup (sys :: Type) (group :: [Type]) :: [Type] where
-  AppendToGroup sys group = sys ': group
-
-type family If (condition :: Bool) (then_ :: k) (else_ :: k) :: k where
-  If 'True then_ else_ = then_
-  If 'False then_ else_ = else_
-
-type family GroupsToNestedHSet m (groups :: [[Type]]) :: [Type] where
-  GroupsToNestedHSet m '[] = '[]
-  GroupsToNestedHSet m (group ': rest) = HSet (MapToIdentityT m group) ': GroupsToNestedHSet m rest
-
-instance Schedule m (HSet '[]) where
-  type Scheduled m (HSet '[]) = HSet '[]
-  schedule HEmpty = HEmpty
-  {-# INLINE schedule #-}
-
-instance (System m sys) => Schedule m (HSet '[sys]) where
-  type Scheduled m (HSet '[sys]) = HSet (GroupsToNestedHSet m (GroupSystems m '[sys]))
-  schedule (HCons sys HEmpty) = HCons (HCons sys HEmpty) HEmpty
-  {-# INLINE schedule #-}
-
-instance
-  ( System m sys,
-    AllSystems m rest,
-    rest ~ (sys2 ': rest'),
-    CompileGroups m (GroupSystems m (sys ': rest)) (sys ': rest)
-  ) =>
-  Schedule m (HSet (sys ': rest))
-  where
-  type Scheduled m (HSet (sys ': rest)) = HSet (GroupsToNestedHSet m (GroupSystems m (sys ': rest)))
-  schedule = compileGroups @m @(GroupSystems m (sys ': rest)) @(sys ': rest)
-  {-# INLINE schedule #-}
-
-class AllSystems m systems
-
-instance AllSystems m '[]
-
-instance (System m (Run constraints sys), AllSystems m rest) => AllSystems m (Run constraints sys ': rest)
-
-instance {-# OVERLAPPABLE #-} (System m sys, AllSystems m rest) => AllSystems m (sys ': rest)
-
-class CompileGroups m (groups :: [[Type]]) (systems :: [Type]) where
-  compileGroups :: HSet systems -> HSet (GroupsToNestedHSet m groups)
-
-instance CompileGroups m '[] systems where
-  compileGroups _ = HEmpty
-  {-# INLINE compileGroups #-}
-
-instance (CompileGroup m group systems) => CompileGroups m '[group] systems where
-  compileGroups systems = HCons (compileGroup @m @group @systems systems) HEmpty
-  {-# INLINE compileGroups #-}
-
-instance
-  (CompileGroup m group systems, CompileGroups m rest systems) =>
-  CompileGroups m (group ': rest) systems
-  where
-  compileGroups systems =
-    HCons (compileGroup @m @group @systems systems) (compileGroups @m @rest @systems systems)
-  {-# INLINE compileGroups #-}
-
-class CompileGroup m (group :: [Type]) (systems :: [Type]) where
-  compileGroup :: HSet systems -> HSet (MapToIdentityT m group)
-
-type family MapToIdentityT m (systems :: [Type]) :: [Type] where
-  MapToIdentityT m '[] = '[]
-  MapToIdentityT m (sys ': rest) = sys ': MapToIdentityT m rest
-
-instance CompileGroup m '[] systems where
-  compileGroup _ = HEmpty
-  {-# INLINE compileGroup #-}
-
-instance (ExtractSystem m sys systems) => CompileGroup m '[sys] systems where
-  compileGroup systems = HCons (extractSystem @m @sys @systems systems) HEmpty
-  {-# INLINE compileGroup #-}
-
-instance
-  (ExtractSystem m sys systems, CompileGroup m rest systems) =>
-  CompileGroup m (sys ': rest) systems
-  where
-  compileGroup systems =
-    HCons (extractSystem @m @sys @systems systems) (compileGroup @m @rest @systems systems)
-  {-# INLINE compileGroup #-}
-
-class ExtractSystem m (sys :: Type) (systems :: [Type]) where
-  extractSystem :: HSet systems -> sys
-
-instance ExtractSystem m sys (sys ': rest) where
-  extractSystem (HCons sys _) = sys
-  {-# INLINE extractSystem #-}
-
-instance (ExtractSystem m sys rest) => ExtractSystem m sys (other ': rest) where
-  extractSystem (HCons _ rest) = extractSystem @m @sys @rest rest
-  {-# INLINE extractSystem #-}
-
-data Before (sys :: Type)
-
-data After (sys :: Type)
-
-data Run (constraints :: [Type]) (sys :: Type) where
-  Run :: sys -> Run constraints sys
-
-type family UnwrapSystem (runSys :: Type) :: Type where
-  UnwrapSystem (Run constraints sys) = sys
-  UnwrapSystem sys = sys
-
-type family GetConstraints (runSys :: Type) :: [Type] where
-  GetConstraints (Run constraints sys) = constraints
-  GetConstraints sys = '[]
-
-instance (Show sys) => Show (Run constraints sys) where
-  show (Run sys) = "Run " ++ show sys
-
-instance (System m sys) => System m (Run constraints sys) where
-  type SystemIn m (Run constraints sys) = SystemIn m sys
-  runSystem (Run sys) = runSystem sys
-  {-# INLINE runSystem #-}
− src/Aztecs/ECS/Scheduler.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Aztecs.ECS.Scheduler
-  ( Scheduler (..),
-    runSchedule,
-    Run (..),
-    Before (..),
-    After (..),
-  )
-where
-
-import Aztecs.ECS.Executor
-import Aztecs.ECS.HSet
-import Aztecs.ECS.Schedule.Internal
-import Aztecs.ECS.Scheduler.Internal
-import Data.Foldable
-
-executeSchedule ::
-  forall m cs s.
-  ( Scheduler m s,
-    Execute m (SchedulerOutput m s),
-    s ~ HSet (SchedulerInput m s)
-  ) =>
-  s ->
-  ExecutorT m ()
-executeSchedule s = execute (buildSchedule @m @s s)
-{-# INLINE executeSchedule #-}
-
-runSchedule ::
-  forall m cs s.
-  ( Applicative m,
-    Execute m (SchedulerOutput m s),
-    s ~ HSet (SchedulerInput m s),
-    AllSystems m (SchedulerInput m s),
-    ScheduleLevelsBuilder
-      m
-      (TopologicalSort (BuildSystemGraph (SchedulerInput m s)))
-      (SchedulerInput m s)
-  ) =>
-  s ->
-  m ()
-runSchedule s = runSystems (executeSchedule @m @cs @s s) $
-  \actions -> sequenceA_ actions
-{-# INLINE runSchedule #-}
− src/Aztecs/ECS/Scheduler/Internal.hs 
@@ -1,298 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.ECS.Scheduler.Internal where
-
-import Aztecs.ECS.Access.Internal
-import Aztecs.ECS.Class
-import Aztecs.ECS.Executor
-import Aztecs.ECS.HSet
-import Aztecs.ECS.Schedule.Internal
-import Data.Kind
-
-class Scheduler m s where
-  type SchedulerInput m s :: [Type]
-  type SchedulerOutput m s :: Type
-
-  buildSchedule :: HSet (SchedulerInput m s) -> SchedulerOutput m s
-
-instance (Applicative m, ECS m) => Access m (HSet '[]) where
-  type AccessType (HSet '[]) = '[]
-  access = pure HEmpty
-  {-# INLINE access #-}
-
-instance
-  ( AllSystems m systems,
-    BuildSystemGraph systems ~ graph,
-    TopologicalSort graph ~ levels,
-    ScheduleLevels m levels ~ output,
-    ScheduleLevelsBuilder m levels systems
-  ) =>
-  Scheduler m (HSet systems)
-  where
-  type SchedulerInput m (HSet systems) = systems
-  type
-    SchedulerOutput m (HSet systems) =
-      HSet (LevelsToNestedHSet (ScheduleLevels m (TopologicalSort (BuildSystemGraph systems))))
-
-  buildSchedule = scheduleSystemLevels @m @(TopologicalSort (BuildSystemGraph systems))
-  {-# INLINE buildSchedule #-}
-
-type family BuildSystemGraph (systems :: [Type]) :: DependencyGraph where
-  BuildSystemGraph '[] = EmptyGraph
-  BuildSystemGraph (runSys ': rest) =
-    AddSystemToGraph
-      (UnwrapSystem runSys)
-      (GetConstraints runSys)
-      (BuildSystemGraph rest)
-
-data ConstrainedSystem = ConstrainedSystem Type [Type]
-
-type family BuildDependencyGraph (constrainedSystems :: [ConstrainedSystem]) :: DependencyGraph where
-  BuildDependencyGraph '[] = EmptyGraph
-  BuildDependencyGraph ('ConstrainedSystem sys constraints ': rest) =
-    AddSystemToGraph sys constraints (BuildDependencyGraph rest)
-
-type family AddSystemToGraph (sys :: Type) (constraints :: [Type]) (graph :: DependencyGraph) :: DependencyGraph where
-  AddSystemToGraph sys '[] graph = AddNode sys graph
-  AddSystemToGraph sys (Before target ': rest) graph =
-    AddSystemToGraph sys rest (AddEdge sys (UnwrapSystem target) graph)
-  AddSystemToGraph sys (After source ': rest) graph =
-    AddSystemToGraph sys rest (AddEdge (UnwrapSystem source) sys graph)
-  AddSystemToGraph sys (other ': rest) graph =
-    AddSystemToGraph sys rest graph
-
-data DependencyGraph = EmptyGraph | Graph [Type] [(Type, Type)] [Type]
-
-type family AddNode (sys :: Type) (graph :: DependencyGraph) :: DependencyGraph where
-  AddNode sys EmptyGraph = Graph '[sys] '[] '[]
-  AddNode sys (Graph nodes edges groups) = Graph (AddToList sys nodes) edges groups
-
-type family AddEdge (from :: Type) (to :: Type) (graph :: DependencyGraph) :: DependencyGraph where
-  AddEdge from to EmptyGraph = Graph '[from, to] '[ '(from, to)] '[]
-  AddEdge from to (Graph nodes edges groups) =
-    Graph (AddToList to (AddToList from nodes)) (AddToList '(from, to) edges) groups
-
-type family AddGroupConstraint (sys :: Type) (graph :: DependencyGraph) :: DependencyGraph where
-  AddGroupConstraint sys EmptyGraph = Graph '[sys] '[] '[sys]
-  AddGroupConstraint sys (Graph nodes edges groups) =
-    Graph (AddToList sys nodes) edges (AddToList sys groups)
-
-type family AddToList (item :: k) (list :: [k]) :: [k] where
-  AddToList item '[] = '[item]
-  AddToList item (item ': rest) = item ': rest
-  AddToList item (other ': rest) = other ': AddToList item rest
-
-type family TopologicalSort (graph :: DependencyGraph) :: [[Type]] where
-  TopologicalSort EmptyGraph = '[]
-  TopologicalSort (Graph nodes edges groups) = TopSortHelper nodes edges '[]
-
-type family TopSortHelper (nodes :: [Type]) (edges :: [(Type, Type)]) (result :: [[Type]]) :: [[Type]] where
-  TopSortHelper '[] edges result = Reverse result
-  TopSortHelper nodes edges result =
-    TopSortHelper
-      (RemoveNodes (NoIncomingEdges nodes edges) nodes)
-      (RemoveEdgesFrom (NoIncomingEdges nodes edges) edges)
-      (NoIncomingEdges nodes edges ': result)
-
-type family NoIncomingEdges (nodes :: [Type]) (edges :: [(Type, Type)]) :: [Type] where
-  NoIncomingEdges '[] edges = '[]
-  NoIncomingEdges (node ': rest) edges =
-    If
-      (HasIncomingEdge node edges)
-      (NoIncomingEdges rest edges)
-      (node ': NoIncomingEdges rest edges)
-
-type family HasIncomingEdge (node :: Type) (edges :: [(Type, Type)]) :: Bool where
-  HasIncomingEdge node '[] = 'False
-  HasIncomingEdge node ('(from, to) ': rest) =
-    If (TypeEq node to) 'True (HasIncomingEdge node rest)
-
-type family RemoveNodes (toRemove :: [Type]) (nodes :: [Type]) :: [Type] where
-  RemoveNodes '[] nodes = nodes
-  RemoveNodes (remove ': rest) nodes = RemoveNodes rest (FilterOut remove nodes)
-
-type family FilterOut (item :: Type) (list :: [Type]) :: [Type] where
-  FilterOut item '[] = '[]
-  FilterOut item (item ': rest) = FilterOut item rest
-  FilterOut item (other ': rest) = other ': FilterOut item rest
-
-type family RemoveEdgesFrom (removed :: [Type]) (edges :: [(Type, Type)]) :: [(Type, Type)] where
-  RemoveEdgesFrom '[] edges = edges
-  RemoveEdgesFrom (node ': rest) edges = RemoveEdgesFrom rest (FilterOutEdgesFrom node edges)
-
-type family FilterOutEdgesFrom (node :: Type) (edges :: [(Type, Type)]) :: [(Type, Type)] where
-  FilterOutEdgesFrom node '[] = '[]
-  FilterOutEdgesFrom node ('(from, to) ': rest) =
-    If
-      (TypeEq node from)
-      (FilterOutEdgesFrom node rest)
-      ('(from, to) ': FilterOutEdgesFrom node rest)
-
-type family TypeEq (a :: Type) (b :: Type) :: Bool where
-  TypeEq a a = 'True
-  TypeEq a b = 'False
-
-type family Reverse (list :: [k]) :: [k] where
-  Reverse list = ReverseHelper list '[]
-
-type family ReverseHelper (list :: [k]) (acc :: [k]) :: [k] where
-  ReverseHelper '[] acc = acc
-  ReverseHelper (x ': xs) acc = ReverseHelper xs (x ': acc)
-
-type family ScheduleLevels (m :: Type -> Type) (levels :: [[Type]]) :: [[Type]] where
-  ScheduleLevels m '[] = '[]
-  ScheduleLevels m (level ': rest) =
-    GroupByConflicts m level ': ScheduleLevels m rest
-
-type family GroupByConflicts (m :: Type -> Type) (systems :: [Type]) :: [Type] where
-  GroupByConflicts m '[] = '[]
-  GroupByConflicts m '[sys] = '[sys]
-  GroupByConflicts m systems = systems
-
-scheduleSystemLevels ::
-  forall m levels systems.
-  ( AllSystems m systems,
-    ScheduleLevelsBuilder m levels systems
-  ) =>
-  HSet systems ->
-  HSet (LevelsToNestedHSet (ScheduleLevels m levels))
-scheduleSystemLevels = buildScheduleLevels @m @levels @systems
-{-# INLINE scheduleSystemLevels #-}
-
-type family LevelsToNestedHSet (levels :: [[Type]]) :: [Type] where
-  LevelsToNestedHSet '[] = '[]
-  LevelsToNestedHSet (level ': rest) = HSet level ': LevelsToNestedHSet rest
-
-class ScheduleLevelsBuilder (m :: Type -> Type) (levels :: [[Type]]) (systems :: [Type]) where
-  buildScheduleLevels ::
-    HSet systems ->
-    HSet (LevelsToNestedHSet (ScheduleLevels m levels))
-
-instance ScheduleLevelsBuilder m '[] systems where
-  buildScheduleLevels _ = HEmpty
-  {-# INLINE buildScheduleLevels #-}
-
-instance
-  ( GroupByConflicts m systems ~ systems
-  ) =>
-  ScheduleLevelsBuilder m '[systems] systems
-  where
-  buildScheduleLevels systems = HCons systems HEmpty
-  {-# INLINE buildScheduleLevels #-}
-
-instance
-  ( SystemReorderer originalSystems levelSystems,
-    GroupByConflicts m levelSystems ~ levelSystems
-  ) =>
-  ScheduleLevelsBuilder m '[levelSystems] originalSystems
-  where
-  buildScheduleLevels originalSystems =
-    HCons (reorderSystems @originalSystems @levelSystems originalSystems) HEmpty
-  {-# INLINE buildScheduleLevels #-}
-
-instance
-  ( SystemReorderer originalSystems levelSystems1,
-    SystemReorderer originalSystems levelSystems2,
-    GroupByConflicts m levelSystems1 ~ levelSystems1,
-    GroupByConflicts m levelSystems2 ~ levelSystems2
-  ) =>
-  ScheduleLevelsBuilder m '[levelSystems1, levelSystems2] originalSystems
-  where
-  buildScheduleLevels originalSystems =
-    HCons (reorderSystems @originalSystems @levelSystems1 originalSystems) $
-      HCons
-        (reorderSystems @originalSystems @levelSystems2 originalSystems)
-        HEmpty
-  {-# INLINE buildScheduleLevels #-}
-
-instance
-  {-# OVERLAPPABLE #-}
-  ( SystemReorderer originalSystems levelSystems,
-    GroupByConflicts m levelSystems ~ levelSystems,
-    ScheduleLevelsBuilder m restLevels originalSystems
-  ) =>
-  ScheduleLevelsBuilder m (levelSystems ': restLevels) originalSystems
-  where
-  buildScheduleLevels originalSystems =
-    HCons (reorderSystems @originalSystems @levelSystems originalSystems) $
-      buildScheduleLevels @m @restLevels @originalSystems originalSystems
-  {-# INLINE buildScheduleLevels #-}
-
-class SystemReorderer (originalSystems :: [Type]) (targetSystems :: [Type]) where
-  reorderSystems ::
-    HSet originalSystems ->
-    HSet targetSystems
-
-instance SystemReorderer originalSystems '[] where
-  reorderSystems _ = HEmpty
-  {-# INLINE reorderSystems #-}
-
-instance
-  ( ExtractFromHSet targetSys originalSystems,
-    SystemReorderer (RemainingAfterExtract targetSys originalSystems) restTargets
-  ) =>
-  SystemReorderer originalSystems (targetSys ': restTargets)
-  where
-  reorderSystems originalSystems =
-    let (targetSys, remaining) = extractFromHSet @targetSys @originalSystems originalSystems
-        rest = reorderSystems @(RemainingAfterExtract targetSys originalSystems) @restTargets remaining
-     in HCons targetSys rest
-  {-# INLINE reorderSystems #-}
-
-type family RemainingAfterExtract (targetSys :: Type) (systems :: [Type]) :: [Type] where
-  RemainingAfterExtract sys (sys ': rest) = rest
-  RemainingAfterExtract sys (Run constraints sys ': rest) = rest
-  RemainingAfterExtract targetSys (other ': rest) = other ': RemainingAfterExtract targetSys rest
-
-class ExtractFromHSet (targetSys :: Type) (systems :: [Type]) where
-  extractFromHSet ::
-    HSet systems ->
-    (targetSys, HSet (RemainingAfterExtract targetSys systems))
-
-instance {-# OVERLAPPING #-} ExtractFromHSet sys (sys ': rest) where
-  extractFromHSet (HCons sys rest) = (sys, rest)
-  {-# INLINE extractFromHSet #-}
-
-instance
-  {-# OVERLAPPING #-}
-  (RemainingAfterExtract sys (Run constraints sys ': rest) ~ rest) =>
-  ExtractFromHSet sys (Run constraints sys ': rest)
-  where
-  extractFromHSet (HCons (Run sys) rest) = (sys, rest)
-  {-# INLINE extractFromHSet #-}
-
-instance
-  ( ExtractFromHSet targetSys rest,
-    RemainingAfterExtract targetSys (other ': rest) ~ (other ': RemainingAfterExtract targetSys rest),
-    TypeEq targetSys other ~ 'False
-  ) =>
-  ExtractFromHSet targetSys (other ': rest)
-  where
-  extractFromHSet (HCons other rest) =
-    let (target, remaining) = extractFromHSet @targetSys @rest rest
-     in (target, HCons other remaining)
-  {-# INLINE extractFromHSet #-}
-
-instance
-  {-# OVERLAPPING #-}
-  ( Monad m,
-    Execute' m (HSet level),
-    Execute m (HSet restLevels)
-  ) =>
-  Execute m (HSet (HSet level ': restLevels))
-  where
-  execute (HCons level restLevels) = do
-    ExecutorT $ \run -> run $ execute' level
-    execute restLevels
-  {-# INLINE execute #-}
src/Aztecs/ECS/System.hs view
@@ -1,24 +1,162 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Aztecs.ECS.System where
-
-import Aztecs.ECS.Access.Internal
-import Aztecs.ECS.Class
-
-class System m sys where
-  type SystemIn m sys
-
-  runSystem :: sys -> SystemIn m sys -> m ()
-
-system ::
-  ( ECS m,
-    Monad m,
-    System (Task m) sys,
-    Access m (SystemIn (Task m) sys)
-  ) =>
-  sys ->
-  m ()
-system sys = access >>= task . runSystem sys
-{-# INLINE system #-}
+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- 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 queries in parallel.+module Aztecs.ECS.System+  ( System,+    SystemT (..),+    MonadReaderSystem (..),+    MonadSystem (..),+    MonadDynamicReaderSystem (..),+    MonadDynamicSystem (..),+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query+import qualified Aztecs.ECS.Query as Q+import Aztecs.ECS.Query.Dynamic (DynamicQueryT)+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.Query.Reader+import Aztecs.ECS.System.Class+import Aztecs.ECS.System.Dynamic.Class+import Aztecs.ECS.System.Dynamic.Reader.Class+import Aztecs.ECS.System.Reader.Class+import qualified Aztecs.ECS.View as V+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node (..))+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Category+import Control.Concurrent.STM+import Control.Monad.Reader+import qualified Data.Foldable as F+import qualified Data.Map as Map+import Data.Set (Set)+import Prelude hiding (all, filter, id, map, (.))++-- | @since 0.9+type System = SystemT STM++-- | System to process queries in parallel.+--+-- @since 0.9+newtype SystemT m a = SystemT+  { -- | Run a system on a collection of `Entities`.+    --+    -- @since 0.9+    runSystemT :: ReaderT (TVar Entities) m a+  }+  deriving (Functor, Applicative, Monad)++-- | @since 0.9+instance MonadDynamicSystem (DynamicQueryT STM) System where+  mapDyn cIds q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.view cIds $ archetypes w+    (o, v') <- lift $ V.mapDyn q v+    lift . modifyTVar wVar $ V.unview v'+    return o+  mapSingleMaybeDyn cIds q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    case V.viewSingle cIds $ archetypes w of+      Just v -> do+        (o, v') <- lift $ V.mapSingleDyn q v+        lift . modifyTVar wVar $ V.unview v'+        return o+      Nothing -> return Nothing+  filterMapDyn cIds f q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.filterView cIds f $ archetypes w+    (o, v') <- lift $ V.mapDyn q v+    lift . modifyTVar wVar $ V.unview v'+    return o++-- | @since 0.9+instance MonadSystem (QueryT STM) System where+  map q = SystemT $ do+    (rws, dynQ) <- runSystemT $ fromQuery q+    runSystemT $ mapDyn (Q.reads rws <> Q.writes rws) dynQ+  mapSingleMaybe q = SystemT $ do+    (rws, dynQ) <- runSystemT $ fromQuery q+    runSystemT $ mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ+  filterMap q qf = SystemT $ do+    wVar <- ask+    let go w =+          let (rws, cs', dynQ) = runQuery q $ components w+              (dynF, cs'') = runQueryFilter qf cs'+           in ((rws, dynQ, dynF), w {components = cs''})+    (rws, dynQ, dynF) <- lift $ stateTVar wVar go+    let f' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+    runSystemT $ filterMapDyn (Q.reads rws <> Q.writes rws) f' dynQ++-- | @since 0.9+instance MonadReaderSystem QueryReader System where+  all q = SystemT $ do+    (cIds, dynQ) <- runSystemT $ fromQueryReader q+    runSystemT $ allDyn cIds dynQ+  filter q qf = SystemT $ do+    wVar <- ask+    let go w =+          let (cIds, cs', dynQ) = runQueryReader q $ components w+              (dynF, cs'') = runQueryFilter qf cs'+           in ((cIds, dynQ, dynF), w {components = cs''})+    (cIds, dynQ, dynF) <- lift $ stateTVar wVar go+    let f' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF)+    runSystemT $ filterDyn cIds dynQ f'++-- | @since 0.9+instance MonadDynamicReaderSystem DynamicQueryReader System where+  allDyn cIds q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.view cIds $ archetypes w+    return $+      if V.null v+        then runDynQueryReader q A.empty {A.entities = Map.keysSet $ entities w}+        else V.allDyn q v+  filterDyn cIds q f = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.filterView cIds f $ archetypes w+    return $ V.allDyn q v++-- | Convert a `QueryReaderT` to a `System`.+--+-- @since 0.9+fromQueryReader :: QueryReader a -> System (Set ComponentID, DynamicQueryReader a)+fromQueryReader q = SystemT $ do+  wVar <- ask+  let go w =+        let (cIds, cs', dynQ) = runQueryReader q $ components w+         in ((cIds, dynQ), w {components = cs'})+  lift $ stateTVar wVar go++-- | Convert a `QueryT` to a `System`.+--+-- @since 0.9+fromQuery :: QueryT STM a -> System (ReadsWrites, DynamicQueryT STM a)+fromQuery q = SystemT $ do+  wVar <- ask+  let go w =+        let (rws, cs', dynQ) = runQuery q $ components w+         in ((rws, dynQ), w {components = cs'})+  lift $ stateTVar wVar go
+ src/Aztecs/ECS/System/Class.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FunctionalDependencies #-}++-- |+-- Module      : Aztecs.ECS.System.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.System.Class (MonadSystem (..)) where++import Aztecs.ECS.Query.Reader (QueryFilter (..))+import Data.Vector (Vector)+import GHC.Stack+import Prelude hiding (map)++-- | Monadic system.+--+-- @since 0.9+class (Monad m) => MonadSystem q m | m -> q where+  -- | Map all matching entities with a query.+  --+  -- @since 0.9+  map :: q a -> m (Vector a)++  -- | Map a single matching entity with a query, or @Nothing@.+  --+  -- @since 0.9+  mapSingleMaybe :: q a -> m (Maybe a)++  -- | Map a single matching entity with a query.+  --+  -- @since 0.9+  mapSingle :: (HasCallStack) => q a -> m a+  mapSingle q = do+    res <- mapSingleMaybe q+    case res of+      Just a -> return a+      Nothing -> error "Expected a single matching entity."++  -- | Map all matching entities with a query and filter.+  --+  -- @since 0.9+  filterMap :: q a -> QueryFilter -> m (Vector a)
+ src/Aztecs/ECS/System/Dynamic/Class.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FunctionalDependencies #-}++-- |+-- Module      : Aztecs.ECS.System.Dynamic.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.System.Dynamic.Class (MonadDynamicSystem (..)) where++import Aztecs.ECS.Component (ComponentID)+import Aztecs.ECS.World.Archetypes (Node (..))+import Data.Set (Set)+import Data.Vector (Vector)+import GHC.Stack++-- | Monadic dynamic system.+--+-- @since 0.9+class (Monad m) => MonadDynamicSystem q m | m -> q where+  -- | Map all matching entities with a query.+  --+  -- @since 0.9+  mapDyn :: Set ComponentID -> q a -> m (Vector a)++  -- | Map a single matching entity with a query, or @Nothing@.+  --+  -- @since 0.9+  mapSingleMaybeDyn :: Set ComponentID -> q a -> m (Maybe a)++  -- | Map a single matching entity with a query.+  mapSingleDyn :: (HasCallStack) => Set ComponentID -> q a -> m a+  mapSingleDyn cIds q = do+    res <- mapSingleMaybeDyn cIds q+    case res of+      Just a -> return a+      Nothing -> error "Expected a single matching entity."++  -- | Map all matching entities with a query and filter.+  --+  -- @since 0.9+  filterMapDyn :: Set ComponentID -> (Node -> Bool) -> q a -> m (Vector a)
+ src/Aztecs/ECS/System/Dynamic/Reader/Class.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FunctionalDependencies #-}++-- |+-- Module      : Aztecs.ECS.System.Dynamic.Reader.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.System.Dynamic.Reader.Class (MonadDynamicReaderSystem (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.World.Archetypes (Node)+import Data.Set (Set)+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Stack++-- | Monadic dynamic reader system.+--+-- @since 0.9+class (Monad m) => MonadDynamicReaderSystem q m | m -> q where+  -- | Match all entities with a query.+  --+  -- @since 0.9+  allDyn :: Set ComponentID -> q a -> m (Vector a)++  -- | Match a single entity with a query.+  --+  -- @since 0.9+  singleDyn :: (HasCallStack) => Set ComponentID -> q a -> m a+  singleDyn cIds q = do+    os <- allDyn cIds q+    case V.length os of+      1 -> return $ V.head os+      _ -> error "singleDyn: expected a single result, but got multiple"++  -- | Match a single entity with a query, or Nothing.+  --+  -- @since 0.9+  singleMaybeDyn :: Set ComponentID -> q a -> m (Maybe a)+  singleMaybeDyn cIds q = do+    os <- allDyn cIds q+    return $ case V.length os of+      1 -> Just (V.head os)+      _ -> Nothing++  -- | Match all entities with a query and filter.+  --+  -- @since 0.9+  filterDyn :: Set ComponentID -> q a -> (Node -> Bool) -> m (Vector a)
+ src/Aztecs/ECS/System/Reader/Class.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FunctionalDependencies #-}++-- |+-- Module      : Aztecs.ECS.System.Reader.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.System.Reader.Class (MonadReaderSystem (..)) where++import Aztecs.ECS.Query.Reader (QueryFilter (..))+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Stack+import Prelude hiding (all)++-- | Monadic reader system.+--+-- @since 0.9+class (Monad m) => MonadReaderSystem q m | m -> q where+  -- | Match all entities with a query.+  --+  -- @since 0.9+  all :: q a -> m (Vector a)++  -- | Match a single entity with a query.+  --+  -- @since 0.9+  single :: (HasCallStack) => q a -> m a+  single q = do+    os <- all q+    case V.length os of+      1 -> return $ V.head os+      _ -> error "single: expected a single result"++  -- | Match a single entity with a query, or @Nothing@.+  --+  -- @since 0.9+  singleMaybe :: q a -> m (Maybe a)+  singleMaybe q = do+    os <- all q+    return $ case V.length os of+      1 -> Just (V.head os)+      _ -> Nothing++  -- | Match all entities with a query and filter.+  --+  -- @since 0.9+  filter :: q a -> QueryFilter -> m (Vector a)
+ src/Aztecs/ECS/View.hs view
@@ -0,0 +1,141 @@+{-# 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,+    filterView,+    null,+    unview,+    allDyn,+    singleDyn,+    mapDyn,+    mapSingleDyn,+  )+where++import Aztecs.ECS.Query.Dynamic (DynamicQueryT (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.World.Archetypes+import qualified Aztecs.ECS.World.Archetypes as AS+import Aztecs.ECS.World.Components+import Aztecs.ECS.World.Entities (Entities)+import qualified Aztecs.ECS.World.Entities as E+import Data.Foldable (foldlM)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Prelude hiding (null)++-- | View into a `World`, containing a subset of archetypes.+--+-- @since 0.9+newtype View = View+  { -- | 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 :: Set ComponentID -> Archetypes -> View+view cIds as = View $ AS.find cIds as++-- | View into a single archetype containing the provided component IDs.+--+-- @since 0.9+viewSingle :: Set ComponentID -> Archetypes -> Maybe View+viewSingle cIds as = case Map.toList $ AS.find cIds as of+  [a] -> Just . View $ uncurry Map.singleton a+  _ -> Nothing++-- | View into all archetypes containing the provided component IDs and matching the provided predicate.+--+-- @since 0.9+filterView ::+  Set ComponentID ->+  (Node -> Bool) ->+  Archetypes ->+  View+filterView cIds f as = View $ Map.filter f (AS.find cIds as)++-- | @True@ if the `View` is empty.+--+-- @since 0.9+null :: View -> Bool+null = 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 :: DynamicQueryReader a -> View -> Vector a+allDyn q v =+  foldl'+    ( \acc n ->+        let as = runDynQueryReader q $ nodeArchetype n+         in as V.++ acc+    )+    V.empty+    (viewArchetypes v)++-- | Query all matching entities in a `View`.+--+-- @since 0.9+singleDyn :: DynamicQueryReader a -> View -> Maybe a+singleDyn q v = case allDyn q v of+  as | V.length as == 1 -> Just (V.head as)+  _ -> Nothing++-- | Map all matching entities in a `View`.+--+-- @since 0.9+mapDyn :: (Monad m) => DynamicQueryT m a -> View -> m (Vector a, View)+mapDyn q v = do+  (as, arches) <-+    foldlM+      ( \(acc, archAcc) (aId, n) -> do+          (as', arch') <- runDynQuery q $ nodeArchetype n+          return (as' V.++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)+      )+      (V.empty, 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 | V.length a == 1 -> (Just (V.head a), arches)+    _ -> (Nothing, arches)
− src/Aztecs/ECS/W.hs 
@@ -1,8 +0,0 @@-module Aztecs.ECS.W (W (..)) where
-
--- | Read-write 'Queryable' component access.
-data W m c = W
-  { readW :: m c,
-    writeW :: c -> m (),
-    modifyW :: (c -> c) -> m ()
-  }
+ src/Aztecs/ECS/World.hs view
@@ -0,0 +1,104 @@+{-# 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 Data.Dynamic+import Data.IntMap (IntMap)+import GHC.Generics+import Prelude hiding (lookup)++-- | World of entities and their components.+--+-- @since 0.9+data World = World+  { -- | Entities and their components.+    --+    -- @since 0.9+    entities :: !Entities,+    -- | Next unique entity identifier.+    --+    -- @since 0.9+    nextEntityId :: !EntityID+  }+  deriving (Show, Generic)++-- | Empty `World`.+--+-- @since 0.9+empty :: World+empty =+  World+    { 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})
+ src/Aztecs/ECS/World/Archetype.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.World.Archetype+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Archetype+  ( Archetype (..),+    empty,+    singleton,+    lookupComponent,+    lookupComponents,+    lookupComponentsAsc,+    lookupComponentsAscMaybe,+    lookupStorage,+    member,+    remove,+    removeStorages,+    insertComponent,+    insertComponents,+    insertAscVector,+    zipWith,+    zipWith_,+    zipWithM,+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity+import qualified Aztecs.ECS.World.Storage as S+import Aztecs.ECS.World.Storage.Dynamic+import qualified Aztecs.ECS.World.Storage.Dynamic as S+import Control.Monad.Writer+  ( MonadWriter (..),+    WriterT (..),+    runWriter,+  )+import Data.Dynamic+import Data.Foldable+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Generics+import Prelude hiding (map, zipWith)++-- | Archetype of entities and components.+-- An archetype is guranteed to contain one of each stored component per entity.+--+-- @since 0.9+data Archetype = Archetype+  { -- | Component storages.+    --+    -- @since 0.9+    storages :: !(IntMap DynamicStorage),+    -- | Entities stored in this archetype.+    --+    -- @since 0.9+    entities :: !(Set EntityID)+  }+  deriving (Show, Generic)++instance Semigroup Archetype where+  a <> b = Archetype {storages = storages a <> storages b, entities = entities a <> entities b}++instance Monoid Archetype where+  mempty = empty++-- | Empty archetype.+--+-- @since 0.9+empty :: Archetype+empty = Archetype {storages = IntMap.empty, entities = Set.empty}++-- | Archetype with a single entity.+--+-- @since 0.9+singleton :: EntityID -> Archetype+singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e}++-- | Lookup a component `Storage` by its `ComponentID`.+--+-- @since 0.9+lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a)+lookupStorage cId w = do+  !dynS <- IntMap.lookup (unComponentId cId) $ storages w+  fromDynamic $ storageDyn dynS+{-# INLINE lookupStorage #-}++-- | Lookup a component by its `EntityID` and `ComponentID`.+--+-- @since 0.9+lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a+lookupComponent e cId w = lookupComponents cId w Map.!? e+{-# INLINE lookupComponent #-}++-- | Lookup all components by their `ComponentID`.+--+-- @since 0.9+lookupComponents :: (Component a) => ComponentID -> Archetype -> Map EntityID a+lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of+  Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) (V.toList as)+  Nothing -> Map.empty+{-# INLINE lookupComponents #-}++-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.+--+-- @since 0.9+lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> Vector a+lookupComponentsAsc cId = fromMaybe V.empty . lookupComponentsAscMaybe cId+{-# INLINE lookupComponentsAsc #-}++-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.+--+-- @since 0.9+lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe (Vector a)+lookupComponentsAscMaybe cId arch = S.toAscVector <$> lookupStorage @a cId arch+{-# INLINE lookupComponentsAscMaybe #-}++-- | Insert a component into the archetype.+-- This assumes the archetype contains one of each stored component per entity.+--+-- @since 0.9+insertComponent ::+  forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype+insertComponent e cId c arch =+  let !storage =+        S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch+   in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}++-- | @True@ if this archetype contains an entity with the provided `ComponentID`.+--+-- @since 0.9+member :: ComponentID -> Archetype -> Bool+member cId = IntMap.member (unComponentId cId) . storages++-- | Zip a vector of components with a function and a component storage.+--+-- @since 0.9+zipWith ::+  forall a c. (Component c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype -> (Vector c, Archetype)+zipWith as f cId arch =+  let go maybeDyn = case maybeDyn of+        Just dyn -> case fromDynamic $ storageDyn dyn of+          Just s -> do+            let !(cs', s') = S.zipWith @c @(StorageT c) f as s+            tell cs'+            return $ Just $ dyn {storageDyn = toDyn s'}+          Nothing -> return maybeDyn+        Nothing -> return Nothing+      !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch+   in (cs, arch {storages = storages'})+{-# INLINE zipWith #-}++-- | Zip a vector of components with a monadic function and a component storage.+--+-- @since 0.9+zipWithM ::+  forall m a c. (Monad m, Component c) => Vector a -> (a -> c -> m c) -> ComponentID -> Archetype -> m (Vector c, Archetype)+zipWithM as f cId arch = do+  let go maybeDyn = case maybeDyn of+        Just dyn -> case fromDynamic $ storageDyn dyn of+          Just s ->+            WriterT $+              fmap+                (\(cs, s') -> (Just dyn {storageDyn = toDyn s'}, cs))+                (S.zipWithM @c @(StorageT c) f as s)+          Nothing -> pure maybeDyn+        Nothing -> pure Nothing+  res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch+  return (snd res, arch {storages = fst res})++-- | Zip a vector of components with a function and a component storage.+--+-- @since 0.9+zipWith_ ::+  forall a c. (Component c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype -> Archetype+zipWith_ as f cId arch =+  let maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of+        Just dyn -> case fromDynamic $ storageDyn dyn of+          Just s ->+            let !s' = S.zipWith_ @c @(StorageT c) f as s in Just $ dyn {storageDyn = toDyn s'}+          Nothing -> Nothing+        Nothing -> Nothing+   in (empty {storages = maybe IntMap.empty (IntMap.singleton (unComponentId cId)) maybeStorage})+{-# INLINE zipWith_ #-}++-- | Insert a vector of components into the archetype, sorted in ascending order by their `EntityID`.+--+-- @since 0.9+insertAscVector :: forall a. (Component a) => ComponentID -> Vector a -> Archetype -> Archetype+insertAscVector cId as arch =+  let !storage = dynStorage @a $ S.fromAscVector @a @(StorageT a) as+   in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch}+{-# INLINE insertAscVector #-}++-- | Remove an entity from an archetype, returning its components.+--+-- @since 0.9+remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype)+remove e arch =+  let go (dynAcc, archAcc) (cId, dynS) =+        let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS+            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs+            dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS+            !dynAcc' = case dynA of+              Just d -> IntMap.insert cId d dynAcc+              Nothing -> dynAcc+         in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})+      arch' = arch {entities = Set.delete e $ entities arch}+   in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'++-- | Remove an entity from an archetype, returning its component storages.+--+-- @since 0.9+removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype)+removeStorages e arch =+  let go (dynAcc, archAcc) (cId, dynS) =+        let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS+            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs+            dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS+            !dynAcc' = case dynA of+              Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc+              Nothing -> dynAcc+         in (dynAcc', archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})+      arch' = arch {entities = Set.delete e $ entities arch}+   in foldl' go (IntMap.empty, arch') . IntMap.toList $ storages arch'++-- | Insert a map of component storages and their `EntityID` into the archetype.+--+-- @since 0.9+insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype+insertComponents e cs arch =+  let f archAcc (itemCId, dyn) =+        let storages' = IntMap.adjust go itemCId (storages archAcc)+            es = Set.toList $ entities archAcc+            go s =+              let ecs = V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip es . V.toList $ toAscVectorDyn s+               in fromAscVectorDyn ecs s+         in archAcc {storages = storages', entities = Set.insert e $ entities archAcc}+   in foldl' f arch (IntMap.toList cs)
+ src/Aztecs/ECS/World/Archetypes.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.World.Archetypes+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Archetypes+  ( ArchetypeID (..),+    Node (..),+    Archetypes (..),+    empty,+    insertArchetype,+    lookupArchetypeId,+    findArchetypeIds,+    lookup,+    find,+    map,+    adjustArchetype,+    insert,+    remove,+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity+import Aztecs.ECS.World.Archetype (Archetype (..))+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Bundle.Dynamic+import Aztecs.ECS.World.Storage.Dynamic+import Data.Dynamic+import qualified Data.IntMap.Strict as IntMap+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Vector as V+import GHC.Generics+import Prelude hiding (all, lookup, map)++-- | `Archetype` ID.+--+-- @since 0.9+newtype ArchetypeID = ArchetypeID+  { -- | Unique integer identifier.+    --+    -- @since 0.9+    unArchetypeId :: Int+  }+  deriving newtype (Eq, Ord, Show)++-- | Node in `Archetypes`.+--+-- @since 0.9+data Node = Node+  { -- | Unique set of `ComponentID`s of this `Node`.+    --+    -- @since 0.9+    nodeComponentIds :: !(Set ComponentID),+    -- | `Archetype` of this `Node`.+    --+    -- @since 0.9+    nodeArchetype :: !Archetype+  }+  deriving (Show, Generic)++-- | `Archetype` map.+data Archetypes = Archetypes+  { -- | Archetype nodes in the map.+    --+    -- @since 0.9+    nodes :: !(Map ArchetypeID Node),+    -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.+    --+    -- @since 0.9+    archetypeIds :: !(Map (Set ComponentID) ArchetypeID),+    -- | Next unique `ArchetypeID`.+    --+    -- @since 0.9+    nextArchetypeId :: !ArchetypeID,+    -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.+    --+    -- @since 0.9+    componentIds :: !(Map ComponentID (Set ArchetypeID))+  }+  deriving (Show, Generic)++-- | Empty `Archetypes`.+--+-- @since 0.9+empty :: Archetypes+empty =+  Archetypes+    { nodes = mempty,+      archetypeIds = mempty,+      nextArchetypeId = ArchetypeID 0,+      componentIds = mempty+    }++-- | Insert an archetype by its set of `ComponentID`s.+--+-- @since 0.9+insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)+insertArchetype cIds n arches =+  let aId = nextArchetypeId arches+   in ( aId,+        arches+          { nodes = Map.insert aId n (nodes arches),+            archetypeIds = Map.insert cIds aId (archetypeIds arches),+            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1),+            componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches)+          }+      )++-- | Adjust an `Archetype` by its `ArchetypeID`.+--+-- @since 0.9+adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes+adjustArchetype aId f arches =+  arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}++-- | Find `ArchetypeID`s containing a set of `ComponentID`s.+--+-- @since 0.9+findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID+findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of+  (aId : aIds') -> foldl' Set.intersection aId aIds'+  [] -> Set.empty++-- | Lookup `Archetype`s containing a set of `ComponentID`s.+--+-- @since 0.9+find :: Set ComponentID -> Archetypes -> Map ArchetypeID Node+find cIds arches = Map.fromSet (\aId -> nodes arches Map.! aId) (findArchetypeIds cIds arches)++-- | Map over `Archetype`s containing a set of `ComponentID`s.+--+-- @since 0.9+map :: Set ComponentID -> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes)+map cIds f arches =+  let go (acc, archAcc) aId =+        let !node = nodes archAcc Map.! aId+            !(a, arch') = f (nodeArchetype node)+            nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc)+         in (a : acc, archAcc {nodes = nodes'})+   in foldl' go ([], arches) $ findArchetypeIds cIds arches++-- | Lookup an `ArchetypeID` by its set of `ComponentID`s.+--+-- @since 0.9+lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID+lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches)++-- | Lookup an `Archetype` by its `ArchetypeID`.+--+-- @since 0.9+lookup :: ArchetypeID -> Archetypes -> Maybe Node+lookup aId arches = Map.lookup aId (nodes arches)++-- | Insert a component into an entity with its `ComponentID`.+--+-- @since 0.9+insert ::+  EntityID ->+  ArchetypeID ->+  Set ComponentID ->+  DynamicBundle ->+  Archetypes ->+  (Maybe ArchetypeID, Archetypes)+insert e aId cIds b arches = case lookup aId arches of+  Just node ->+    if Set.isSubsetOf cIds $ nodeComponentIds node+      then+        let go n = n {nodeArchetype = runDynamicBundle b e $ nodeArchetype n}+         in (Nothing, arches {nodes = Map.adjust go aId $ nodes arches})+      else+        let cIds' = cIds <> nodeComponentIds node+         in case lookupArchetypeId cIds' arches of+              Just nextAId ->+                let !(cs, arch) = A.remove e $ nodeArchetype node+                    node' = node {nodeArchetype = arch}+                    !nodes' = Map.insert aId node' $ nodes arches+                    adjustNode nextNode =+                      let nextArch = nodeArchetype nextNode+                          nextArch' = nextArch {A.entities = Set.insert e $ A.entities nextArch}+                          !nextArch'' = A.insertComponents e cs nextArch'+                       in nextNode {nodeArchetype = runDynamicBundle b e nextArch''}+                 in (Just nextAId, arches {nodes = Map.adjust adjustNode nextAId nodes'})+              Nothing ->+                let !(s, arch) = A.removeStorages e $ nodeArchetype node+                    nodes' = Map.insert aId node {nodeArchetype = arch} $ nodes arches+                    !nextArch = runDynamicBundle b e Archetype {storages = s, entities = Set.singleton e}+                    !n = Node {nodeComponentIds = cIds', nodeArchetype = nextArch}+                    !(nextAId, arches') = insertArchetype cIds' n arches {nodes = nodes'}+                 in (Just nextAId, arches')+  Nothing -> (Nothing, arches)++-- | Remove a component from an entity with its `ComponentID`.+--+-- @since 0.9+remove ::+  (Component a) =>+  EntityID ->+  ArchetypeID ->+  ComponentID ->+  Archetypes ->+  (Maybe (a, ArchetypeID), Archetypes)+remove e aId cId arches = case lookup aId arches of+  Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of+    Just nextAId ->+      let !(cs, arch') = A.remove e (nodeArchetype node)+          !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}+          (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs+          go' archAcc (itemCId, dyn) =+            let adjustStorage s = fromAscVectorDyn (V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) . V.toList $ toAscVectorDyn s) s+             in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)}+          go nextNode =+            nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')}+       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') . V.toList $ toAscVectorDyn s+             in (res, fromAscVectorDyn . V.fromList $ Map.elems dyns)+       in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)),+            arches' {nodes = Map.insert aId node' (nodes arches')}+          )+  Nothing -> (Nothing, arches)
+ src/Aztecs/ECS/World/Bundle.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# 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 (..),+    MonoidBundle (..),+    MonoidDynamicBundle (..),+    runBundle,+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity+import Aztecs.ECS.World.Archetype+import Aztecs.ECS.World.Bundle.Class+import Aztecs.ECS.World.Bundle.Dynamic+import Aztecs.ECS.World.Components+import qualified Aztecs.ECS.World.Components as CS+import 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.9+instance MonoidBundle Bundle where+  bundle :: forall a. (Component a) => a -> Bundle+  bundle a = Bundle $ \cs ->+    let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', dynBundle cId a)++-- | @since 0.9+instance MonoidDynamicBundle Bundle where+  dynBundle cId c = Bundle (Set.singleton cId,,dynBundle cId c)++-- | 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')
+ src/Aztecs/ECS/World/Bundle/Class.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      : Aztecs.ECS.World.Bundle.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Bundle.Class (MonoidBundle (..)) where++import Aztecs.ECS.Component++-- | Monoid bundle of components.+--+-- @since 0.9+class (Monoid a) => MonoidBundle a where+  -- | Add a component to the bundle.+  --+  -- @since 0.9+  bundle :: forall c. (Component c) => c -> a
+ src/Aztecs/ECS/World/Bundle/Dynamic.hs view
@@ -0,0 +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 (..), MonoidDynamicBundle (..)) where++import Aztecs.ECS.Entity+import Aztecs.ECS.World.Archetype+import Aztecs.ECS.World.Bundle.Dynamic.Class++-- | Dynamic bundle of components.+--+-- @since 0.9+newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}++-- | @since 0.9+instance Semigroup DynamicBundle where+  DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch)++-- | @since 0.9+instance Monoid DynamicBundle where+  mempty = DynamicBundle $ \_ arch -> arch++-- | @since 0.9+instance MonoidDynamicBundle DynamicBundle where+  dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch
+ src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs view
@@ -0,0 +1,20 @@+-- |+-- Module      : Aztecs.ECS.World.Bundle.Dynamic.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Bundle.Dynamic.Class (MonoidDynamicBundle (..)) where++import Aztecs.ECS.Component++-- | Monoid bundle of dynamic components.+--+-- @since 0.9+class MonoidDynamicBundle a where+  -- | Add a component to the bundle by its `ComponentID`.+  --+  -- @since 0.9+  dynBundle :: (Component c) => ComponentID -> c -> a
+ src/Aztecs/ECS/World/Components.hs view
@@ -0,0 +1,83 @@+{-# 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 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)++-- | 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)+          }+      )
+ src/Aztecs/ECS/World/Entities.hs view
@@ -0,0 +1,205 @@+{-# 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 Data.Dynamic+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Generics+import Prelude hiding (lookup)++-- | World of entities and their components.+--+-- @since 0.9+data Entities = Entities+  { -- | Archetypes.+    --+    -- @since 0.9+    archetypes :: !Archetypes,+    -- | Components.+    --+    -- @since 0.9+    components :: !Components,+    -- | Entities and their archetype identifiers.+    --+    -- @since 0.9+    entities :: !(Map EntityID ArchetypeID)+  }+  deriving (Show, Generic)++-- | Empty `World`.+--+-- @since 0.9+empty :: Entities+empty =+  Entities+    { 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)
+ src/Aztecs/ECS/World/Storage.hs view
@@ -0,0 +1,81 @@+{-# 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 Data.Data+import Data.Vector (Vector)+import qualified Data.Vector as V+import Prelude hiding (map, zipWith)++-- | Component storage, containing zero or many components of the same type.+--+-- @since 0.9+class (Typeable s, Typeable a) => Storage a s where+  -- | Storage with a single component.+  --+  -- @since 0.9+  singleton :: a -> s++  -- | Vector of all components in the storage in ascending order.+  --+  -- @since 0.9+  toAscVector :: s -> Vector a++  -- | Convert a sorted vector of components (in ascending order) into a storage.+  --+  -- @since 0.9+  fromAscVector :: Vector a -> s++  -- | Map a function over all components in the storage.+  --+  --+  -- @since 0.9+  map :: (a -> a) -> s -> s++  -- | Map a function with some input over all components in the storage.+  --+  -- @since 0.9+  zipWith :: (i -> a -> a) -> Vector i -> s -> (Vector a, s)++  -- | Map an applicative functor with some input over all components in the storage.+  --+  -- @since 0.9+  zipWithM :: (Monad m) => (i -> a -> m a) -> Vector i -> s -> m (Vector a, s)++  -- | Map a function with some input over all components in the storage.+  --+  -- @since 0.9+  zipWith_ :: (i -> a -> a) -> Vector i -> s -> s+  zipWith_ f is as = snd $ zipWith f is as++-- | @since 0.9+instance (Typeable a) => Storage a (Vector a) where+  singleton a = V.singleton a+  {-# INLINE singleton #-}++  toAscVector = id+  {-# INLINE toAscVector #-}++  fromAscVector = id+  {-# INLINE fromAscVector #-}++  map = V.map+  {-# INLINE map #-}++  zipWith f is as = let as' = V.zipWith f is as in (as', as')+  {-# INLINE zipWith #-}++  zipWith_ f is as = V.zipWith f is as+  {-# INLINE zipWith_ #-}++  zipWithM f is as = (\as' -> (as', as')) <$> V.zipWithM f is as+  {-# INLINE zipWithM #-}
+ src/Aztecs/ECS/World/Storage/Dynamic.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Aztecs.ECS.World.Storage.Dynamic+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.World.Storage.Dynamic+  ( DynamicStorage (..),+    dynStorage,+    singletonDyn,+    fromAscVectorDyn,+    toAscVectorDyn,+  )+where++import qualified Aztecs.ECS.World.Storage as S+import Data.Dynamic+import Data.Maybe+import Data.Vector (Vector)+import qualified Data.Vector as V++-- | Dynamic storage of components.+--+-- @since 0.9+data DynamicStorage = DynamicStorage+  { -- | Dynamic storage.+    --+    -- @since 0.9+    storageDyn :: !Dynamic,+    -- | Singleton storage.+    --+    -- @since 0.9+    singletonDyn' :: !(Dynamic -> Dynamic),+    -- | Convert this storage to an ascending vector.+    --+    -- @since 0.9+    toAscVectorDyn' :: !(Dynamic -> Vector Dynamic),+    -- | Convert from an ascending vector.+    --+    -- @since 0.9+    fromAscVectorDyn' :: !(Vector Dynamic -> Dynamic)+  }++-- | @since 0.9+instance Show DynamicStorage where+  show s = "DynamicStorage " ++ show (storageDyn s)++-- | Create a dynamic storage from a storage.+--+-- @since 0.9+dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage+dynStorage s =+  DynamicStorage+    { storageDyn = toDyn s,+      singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic,+      toAscVectorDyn' = \d -> V.map toDyn (S.toAscVector @a @s (fromMaybe (error "TODO") $ fromDynamic d)),+      fromAscVectorDyn' = toDyn . S.fromAscVector @a @s . V.map (fromMaybe (error "TODO") . fromDynamic)+    }+{-# INLINE dynStorage #-}++-- | Singleton dynamic storage.+--+-- @since 0.9+singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage+singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn}++-- | Convert from an ascending vector.+--+-- @since 0.9+fromAscVectorDyn :: Vector Dynamic -> DynamicStorage -> DynamicStorage+fromAscVectorDyn dyns s = s {storageDyn = fromAscVectorDyn' s dyns}++-- | Convert this storage to an ascending vector.+--+-- @since 0.9+toAscVectorDyn :: DynamicStorage -> Vector Dynamic+toAscVectorDyn = toAscVectorDyn' <*> storageDyn
− src/Aztecs/Entity.hs 
@@ -1,22 +0,0 @@-module Aztecs.Entity where
-
-import Data.Bits
-import Data.Word
-
-newtype Entity = Entity {unEntity :: Word64}
-  deriving (Eq, Ord)
-
-instance Show Entity where
-  show e = "Entity {index = " ++ show (entityIndex e) ++ ", generation = " ++ show (entityGeneration e) ++ "}"
-
-mkEntity :: Word32 -> Word32 -> Entity
-mkEntity index generation = Entity $ (fromIntegral generation `shiftL` 32) .|. fromIntegral index
-{-# INLINE mkEntity #-}
-
-entityIndex :: Entity -> Word32
-entityIndex (Entity e) = fromIntegral (e .&. 0xFFFFFFFF)
-{-# INLINE entityIndex #-}
-
-entityGeneration :: Entity -> Word32
-entityGeneration (Entity e) = fromIntegral ((e `shiftR` 32) .&. 0xFFFFFFFF)
-{-# INLINE entityGeneration #-}
+ src/Aztecs/Hierarchy.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Aztecs.Asset.AssetServer+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+--+-- Hierarchical relationships.+-- A `Children` component forms a one-to-many relationship with `Parent` components.+module Aztecs.Hierarchy+  ( Parent (..),+    Children (..),+    update,+    Hierarchy (..),+    toList,+    foldWithKey,+    mapWithKey,+    mapWithAccum,+    hierarchy,+    hierarchies,+    ParentState (..),+    ChildState (..),+  )+where++import Aztecs.ECS+import qualified Aztecs.ECS.Access as A+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.System as S+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Generics++-- | Parent component.+--+-- @since 0.9+newtype Parent = Parent+  { -- | Parent entity ID.+    --+    -- @since 0.9+    unParent :: EntityID+  }+  deriving (Eq, Ord, Show, Generic)++-- | @since 0.9+instance Component Parent++-- | Parent internal state component.+--+-- @since 0.9+newtype ParentState = ParentState {unParentState :: EntityID}+  deriving (Show, Generic)++-- | @since 0.9+instance Component ParentState++-- | Children component.+--+-- @since 0.9+newtype Children = Children {unChildren :: Set EntityID}+  deriving (Eq, Ord, Show, Semigroup, Monoid, Generic)++-- | @since 0.9+instance Component Children++-- | Child internal state component.+newtype ChildState = ChildState {unChildState :: Set EntityID}+  deriving (Show, Generic)++-- | @since 0.9+instance Component ChildState++-- | Update the parent-child relationships.+--+-- @since 0.9+update ::+  ( Applicative qr,+    QueryReaderF qr,+    DynamicQueryReaderF qr,+    MonadReaderSystem qr s,+    MonadAccess b m+  ) =>+  s (m ())+update = do+  parents <- S.all $ do+    entity <- Q.entity+    parent <- Q.fetch+    maybeParentState <- Q.fetchMaybe @_ @ParentState+    return (entity, unParent parent, maybeParentState)++  children <- S.all $ do+    entity <- Q.entity+    cs <- Q.fetch+    maybeChildState <- Q.fetchMaybe @_ @ChildState+    return (entity, unChildren cs, maybeChildState)++  let go = do+        mapM_+          ( \(entity, parent, maybeParentState) -> case maybeParentState of+              Just (ParentState parentState) -> do+                when (parent /= parentState) $ do+                  A.insert parent . bundle $ ParentState parent++                  -- Remove this entity from the previous parent's children.+                  maybeLastChildren <- A.lookup parentState+                  let lastChildren = maybe mempty unChildren maybeLastChildren+                  let lastChildren' = Set.filter (/= entity) lastChildren+                  A.insert parentState . bundle . Children $ lastChildren'++                  -- Add this entity to the new parent's children.+                  maybeChildren <- A.lookup parent+                  let parentChildren = maybe mempty unChildren maybeChildren+                  A.insert parent . bundle . Children $ Set.insert entity parentChildren+              Nothing -> do+                A.spawn_ . bundle $ ParentState parent+                maybeChildren <- A.lookup parent+                let parentChildren = maybe mempty unChildren maybeChildren+                A.insert parent . bundle . Children $ Set.insert entity parentChildren+          )+          parents+        mapM_+          ( \(entity, children', maybeChildState) -> case maybeChildState of+              Just (ChildState childState) -> do+                when (children' /= childState) $ do+                  A.insert entity . bundle $ ChildState children'+                  let added = Set.difference children' childState+                      removed = Set.difference childState children'+                  mapM_ (\e -> A.insert e . bundle . Parent $ entity) added+                  mapM_ (A.remove @_ @_ @Parent) removed+              Nothing -> do+                A.insert entity . bundle $ ChildState children'+                mapM_ (\e -> A.insert e . bundle . Parent $ entity) children'+          )+          children+  return go++-- | Hierarchy of entities.+--+-- @since 0.9+data Hierarchy a = Node+  { -- | Entity ID.+    --+    -- @since 0.9+    nodeEntityId :: EntityID,+    -- | Entity components.+    nodeEntity :: a,+    -- | Child nodes.+    --+    -- @since 0.9+    nodeChildren :: [Hierarchy a]+  }+  deriving (Functor)++-- | @since 0.9+instance Foldable Hierarchy where+  foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n)++-- | @since 0.9+instance Traversable Hierarchy where+  traverse f n =+    Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n)++-- | Convert a hierarchy to a vector of entity IDs and components.+--+-- @since 0.9+toList :: Hierarchy a -> Vector (EntityID, a)+toList n = V.singleton (nodeEntityId n, nodeEntity n) <> V.concatMap toList (V.fromList $ nodeChildren n)++-- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator.+--+-- @since 0.9+foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b+foldWithKey f n b = f (nodeEntityId n) (nodeEntity n) (foldr (foldWithKey f) b (nodeChildren n))++-- | Map a hierarchy with a function that takes the entity ID and entity.+--+-- @since 0.9+mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b+mapWithKey f n =+  Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n))++-- | Map a hierarchy with a function that takes the entity ID, entity, and accumulator.+--+-- @since 0.9+mapWithAccum :: (EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c+mapWithAccum f b n = case f (nodeEntityId n) (nodeEntity n) b of+  (c, b') -> Node (nodeEntityId n) c (map (mapWithAccum f b') (nodeChildren n))++-- | System to read a hierarchy of parents to children with the given query.+--+-- @since 0.9+hierarchy ::+  (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) =>+  EntityID ->+  q a ->+  s (Maybe (Hierarchy a))+hierarchy e q = do+  children <- S.all $ do+    entity <- Q.entity+    cs <- Q.fetch+    a <- q+    return (entity, (unChildren cs, a))++  let childMap = Map.fromList $ V.toList children+  return $ hierarchy' e childMap++-- | Build all hierarchies of parents to children, joined with the given query.+--+-- @since 0.9+hierarchies ::+  (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) =>+  q a ->+  s (Vector (Hierarchy a))+hierarchies q = do+  children <-+    S.all+      ( do+          entity <- Q.entity+          cs <- Q.fetch+          a <- q+          return (entity, (unChildren cs, a))+      )++  let childMap = Map.fromList $ V.toList children+  roots <- S.filter Q.entity $ with @Children <> without @Parent+  return $ V.mapMaybe (`hierarchy'` childMap) roots++-- | Build a hierarchy of parents to children.+--+-- @since 0.9+hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)+hierarchy' e childMap = case Map.lookup e childMap of+  Just (cs, a) ->+    let bs = mapMaybe (`hierarchy'` childMap) (Set.toList cs)+     in Just+          Node+            { nodeEntityId = e,+              nodeEntity = a,+              nodeChildren = bs+            }+  Nothing -> Nothing
− src/Aztecs/Internal.hs 
@@ -1,217 +0,0 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.Internal
-  ( AztecsT (..),
-    runAztecsT,
-    runAztecsT_,
-  )
-where
-
-import Aztecs.ECS.Bundle
-import Aztecs.ECS.Bundle.Class
-import Aztecs.ECS.Class
-import Aztecs.ECS.Commands
-import Aztecs.ECS.Component (Component (ComponentStorage, componentHooks), Hooks (..))
-import Aztecs.ECS.HSet (AdjustM, HSet (..), Lookup (..))
-import qualified Aztecs.ECS.HSet as HS
-import Aztecs.ECS.Query
-import Aztecs.ECS.Query.Internal
-import Aztecs.ECS.R
-import qualified Aztecs.ECS.Scheduler as Scheduler
-import Aztecs.ECS.W
-import qualified Aztecs.Entity as E
-import Aztecs.Storage
-import qualified Aztecs.Storage as S
-import Aztecs.World (SparseStorage, WorldComponents)
-import qualified Aztecs.World as W
-import qualified Aztecs.World.Entities as E
-import Control.Monad.Primitive
-import Control.Monad.State.Strict
-import qualified Data.IntMap.Strict as IntMap
-import qualified Data.Map.Strict as Map
-import Data.Maybe
-import Data.Proxy
-import qualified Data.Set as Set
-import Data.Typeable
-import Prelude hiding (Read, lookup)
-
-newtype AztecsT cs m a = AztecsT {unAztecsT :: StateT (W.World m cs) m a}
-  deriving (Functor, Applicative, Monad, MonadIO, PrimMonad)
-
-instance MonadTrans (AztecsT cs) where
-  lift = AztecsT . lift
-  {-# INLINE lift #-}
-
-instance (PrimMonad m) => ECS (AztecsT cs m) where
-  type Entity (AztecsT cs m) = E.Entity
-  type Task (AztecsT cs m) = (Commands (AztecsT cs) m)
-
-  spawn b = do
-    w <- AztecsT get
-    let (e, counter) = E.mkEntityWithCounter (W.worldEntities w)
-    AztecsT $ put w {W.worldEntities = counter}
-    runBundle b e
-    return e
-  {-# INLINE spawn #-}
-  insert e b = runBundle b e
-  {-# INLINE insert #-}
-  remove e = AztecsT $ do
-    w <- get
-    w' <- lift $ W.remove e w
-    put w'
-  {-# INLINE remove #-}
-  task = runCommands
-  {-# INLINE task #-}
-
-instance
-  ( PrimMonad m,
-    Typeable c,
-    Component (AztecsT cs m) c,
-    AdjustM m (SparseStorage m c) (WorldComponents m cs)
-  ) =>
-  Bundleable c (AztecsT cs m)
-  where
-  bundle c = Bundle $ \entity -> do
-    w <- AztecsT get
-    let entityIdx = fromIntegral $ E.entityIndex entity
-        componentType = typeOf c
-        go = S.insertStorage entity c
-        hooks = componentHooks (Proxy :: Proxy c)
-    cs <- lift . HS.adjustM @_ @(SparseStorage m c) go $ W.worldComponents w
-    let entityComponents' =
-          IntMap.insertWith
-            Map.union
-            entityIdx
-            (Map.singleton componentType (W.removeComponent' @m @c entity))
-            (W.worldEntityComponents w)
-    AztecsT $ put w {W.worldComponents = cs, W.worldEntityComponents = entityComponents'}
-    onInsert hooks entity
-  {-# INLINE bundle #-}
-
-runAztecsT :: (Monad m) => AztecsT cs m a -> W.World m cs -> m (a, W.World m cs)
-runAztecsT (AztecsT m) = runStateT m
-{-# INLINE runAztecsT #-}
-
-runAztecsT_ :: (Monad m) => AztecsT cs m a -> W.World m cs -> m a
-runAztecsT_ (AztecsT m) = evalStateT m
-{-# INLINE runAztecsT_ #-}
-
-instance (PrimMonad m) => Queryable (AztecsT cs m) E.Entity where
-  type QueryableAccess E.Entity = '[]
-  queryable = AztecsT $ do
-    w <- get
-    return . Query . map pure . E.entities $ W.worldEntities w
-  {-# INLINE queryable #-}
-
-instance
-  ( PrimMonad m,
-    Lookup (ComponentStorage m a a) (WorldComponents m cs),
-    Storage m (ComponentStorage m a)
-  ) =>
-  Queryable (AztecsT cs m) (With a)
-  where
-  type QueryableAccess (With a) = '[With a]
-  queryable = AztecsT $ do
-    w <- get
-    withComponent <-
-      lift
-        . S.queryStorageR
-        . HS.lookup @(ComponentStorage m a a)
-        $ W.worldComponents w
-    return . fmap (const With) $ withComponent
-  {-# INLINE queryable #-}
-
-instance
-  ( PrimMonad m,
-    Lookup (ComponentStorage m a a) (WorldComponents m cs),
-    Storage m (ComponentStorage m a)
-  ) =>
-  Queryable (AztecsT cs m) (Without a)
-  where
-  type QueryableAccess (Without a) = '[Without a]
-  queryable = AztecsT $ do
-    w <- get
-    (Query cs) <-
-      lift
-        . S.queryStorageR
-        . HS.lookup @(ComponentStorage m a a)
-        $ W.worldComponents w
-    let go m = case m of
-          Just v -> Nothing
-          Nothing -> Just Without
-    return . Query $ fmap go cs
-  {-# INLINE queryable #-}
-
-instance
-  ( PrimMonad m,
-    Lookup (ComponentStorage m a a) (WorldComponents m cs),
-    Storage (AztecsT cs m) (ComponentStorage m a)
-  ) =>
-  Queryable (AztecsT cs m) (R a)
-  where
-  type QueryableAccess (R a) = '[Read a]
-  queryable = do
-    w <- AztecsT get
-    S.queryStorageR . HS.lookup @(ComponentStorage m a a) $ W.worldComponents w
-  {-# INLINE queryable #-}
-
-instance
-  ( PrimMonad m,
-    PrimState m ~ s,
-    Lookup (ComponentStorage m a a) (WorldComponents m cs),
-    Storage m (ComponentStorage m a)
-  ) =>
-  Queryable (AztecsT cs m) (W (Commands (AztecsT cs) m) a)
-  where
-  type QueryableAccess (W (Commands (AztecsT cs) m) a) = '[Write a]
-  queryable = AztecsT $ do
-    w <- get
-    Query results <-
-      lift
-        . S.queryStorageW
-        . HS.lookup @(ComponentStorage m a a)
-        $ W.worldComponents w
-    let liftToCommands m = Commands $ (,pure ()) <$> m
-        go (W r wf mf) =
-          W
-            (liftToCommands r)
-            (liftToCommands . wf)
-            (liftToCommands . mf)
-    return . Query $ map (fmap go) results
-  {-# INLINE queryable #-}
-
--- Additional instance for direct AztecsT usage in scheduler
-instance
-  ( PrimMonad m,
-    PrimState m ~ s,
-    Lookup (ComponentStorage m a a) (WorldComponents m cs),
-    Storage m (ComponentStorage m a)
-  ) =>
-  Queryable (AztecsT cs m) (W (AztecsT cs m) a)
-  where
-  type QueryableAccess (W (AztecsT cs m) a) = '[Write a]
-  queryable = AztecsT $ do
-    w <- get
-    Query results <-
-      lift
-        . S.queryStorageW
-        . HS.lookup @(ComponentStorage m a a)
-        $ W.worldComponents w
-    let liftToAztecs (W r wf mf) =
-          W
-            (AztecsT $ lift r)
-            (AztecsT . lift . wf)
-            (AztecsT . lift . mf)
-    return . Query $ map (fmap liftToAztecs) results
-  {-# INLINE queryable #-}
− src/Aztecs/Storage.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Aztecs.Storage (Storage (..), Empty (..)) where
-
-import Aztecs.ECS.HSet
-import qualified Aztecs.ECS.HSet as HS
-import Aztecs.ECS.Query
-import Aztecs.ECS.R
-import Aztecs.ECS.W
-import Aztecs.Entity
-import Control.Monad.Primitive
-import qualified Data.SparseSet.Strict as S
-import Data.SparseSet.Strict.Mutable (MSparseSet)
-import qualified Data.SparseSet.Strict.Mutable as MS
-import Data.Word
-import Prelude hiding (lookup)
-
-class Storage m s where
-  emptyStorage :: m (s a)
-
-  insertStorage :: Entity -> a -> s a -> m (s a)
-
-  removeStorage :: Entity -> s a -> m (s a)
-
-  queryStorageR :: s a -> m (Query (R a))
-
-  queryStorageW :: s a -> m (Query (W m a))
-
-instance (PrimMonad m, PrimState m ~ s) => Storage m (MSparseSet s Word32) where
-  emptyStorage = MS.empty
-  {-# INLINE emptyStorage #-}
-
-  insertStorage entity a s = do
-    s' <- S.freeze s
-    S.thaw $ S.insert (entityIndex entity) a s'
-  {-# INLINE insertStorage #-}
-
-  removeStorage entity s = do
-    s' <- S.freeze s
-    S.thaw $ S.delete (entityIndex entity) s'
-  {-# INLINE removeStorage #-}
-
-  queryStorageR s = do
-    s' <- S.freeze s
-    return . Query . fmap (fmap R) $ S.toList s'
-  {-# INLINE queryStorageR #-}
-
-  queryStorageW s = do
-    !as <- MS.toList s
-    let go (i, _) =
-          W
-            { readW = MS.unsafeRead s (fromIntegral i),
-              writeW = MS.unsafeWrite s (fromIntegral i),
-              modifyW = MS.unsafeModify s (fromIntegral i)
-            }
-    return . Query $ map (fmap go) as
-  {-# INLINE queryStorageW #-}
-
-class Empty m a where
-  empty :: m a
-
-instance (Applicative m) => Empty m (HSet '[]) where
-  empty = pure HEmpty
-  {-# INLINE empty #-}
-
-instance (Monad m, Storage m s, Empty m (HSet ts)) => Empty m (HSet (s a ': ts)) where
-  empty = do
-    xs <- emptyStorage @m @s
-    HCons xs <$> empty
-  {-# INLINE empty #-}
− src/Aztecs/World.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Aztecs.World
-  ( World (..),
-    WorldComponents (..),
-    empty,
-    removeComponent,
-    removeComponent',
-    remove,
-    SparseStorage,
-  )
-where
-
-import qualified Aztecs.ECS.Class as ECS
-import Aztecs.ECS.Component
-import Aztecs.ECS.HSet
-import qualified Aztecs.ECS.HSet as HS
-import Aztecs.Entity
-import Aztecs.Storage hiding (empty)
-import qualified Aztecs.Storage as Storage
-import Aztecs.World.Entities
-import Control.Monad
-import Control.Monad.Primitive
-import Data.IntMap.Strict (IntMap)
-import qualified Data.IntMap.Strict as IntMap
-import Data.Kind
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Proxy
-import qualified Data.SparseSet.Strict as S
-import Data.SparseSet.Strict.Mutable (MSparseSet)
-import Data.Typeable
-import Data.Word
-
-type SparseStorage m = MSparseSet (PrimState m) Word32
-
-type family WorldComponents m (cs :: [Type]) :: [Type] where
-  WorldComponents m '[] = '[]
-  WorldComponents m (c ': cs) = ComponentStorage m c c ': WorldComponents m cs
-
-type WorldComponentSet m cs =
-  HSet (WorldComponents m cs)
-
-type WorldEntityComponents m cs =
-  IntMap (Map TypeRep (WorldComponentSet m cs -> m (WorldComponentSet m cs)))
-
-data World m cs = World
-  { worldComponents :: !(HSet (WorldComponents m cs)),
-    worldEntities :: {-# UNPACK #-} !Entities,
-    worldEntityComponents :: {-# UNPACK #-} !(WorldEntityComponents m cs)
-  }
-
-empty :: (Monad m, Empty m (HSet (WorldComponents m cs))) => m (World m cs)
-empty = do
-  cs <- Storage.empty
-  return $ World cs emptyEntities IntMap.empty
-{-# INLINE empty #-}
-
-lookupStorage ::
-  (Lookup (ComponentStorage m c c) (WorldComponents m cs)) =>
-  World m cs ->
-  ComponentStorage m c c
-lookupStorage = HS.lookup . worldComponents
-{-# INLINE lookupStorage #-}
-
-adjustStorage ::
-  forall m cs c.
-  ( PrimMonad m,
-    Typeable c,
-    Component m c,
-    AdjustM m (ComponentStorage m c c) (WorldComponents m cs),
-    Storage m (ComponentStorage m c)
-  ) =>
-  (ComponentStorage m c c -> m (ComponentStorage m c c)) ->
-  World m cs ->
-  m (World m cs)
-adjustStorage f w = do
-  cs <- HS.adjustM @m @(ComponentStorage m c c) f (worldComponents w)
-  return $ w {worldComponents = cs}
-{-# INLINE adjustStorage #-}
-
-removeComponent ::
-  forall m cs c.
-  ( AdjustM m (ComponentStorage m c c) (WorldComponents m cs),
-    PrimMonad m,
-    Component m c,
-    ECS.Entity m ~ Entity,
-    Typeable c,
-    Storage m (ComponentStorage m c)
-  ) =>
-  Entity ->
-  World m cs ->
-  m (World m cs)
-removeComponent entity w = do
-  let entityIdx = fromIntegral (entityIndex entity)
-      componentType = typeRep (Proxy :: Proxy c)
-      hooks = componentHooks (Proxy :: Proxy c)
-  -- Run the onRemove hook first
-  onRemove hooks entity
-  w' <- adjustStorage @_ @_ @c (removeStorage entity) w
-  let entityComponents' = IntMap.adjust (Map.delete componentType) entityIdx (worldEntityComponents w)
-  return $ w' {worldEntityComponents = entityComponents'}
-{-# INLINE removeComponent #-}
-
-removeComponent' ::
-  forall m (c :: Type) cs.
-  (AdjustM m (SparseStorage m c) cs, PrimMonad m) =>
-  Entity ->
-  HSet cs ->
-  m (HSet cs)
-removeComponent' e components = HS.adjustM @m @(SparseStorage m c) go components
-  where
-    go s = do
-      s' <- S.freeze s
-      S.thaw (S.delete (entityIndex e) s')
-{-# INLINE removeComponent' #-}
-
-remove :: (Monad m) => Entity -> World m cs -> m (World m cs)
-remove entity w = do
-  let entityIdx = fromIntegral (entityIndex entity)
-  case IntMap.lookup entityIdx (worldEntityComponents w) of
-    Nothing -> return w
-    Just componentRemovalFunctions -> do
-      cs' <- foldr (<=<) return (Map.elems componentRemovalFunctions) (worldComponents w)
-      let entityComponents' = IntMap.delete entityIdx (worldEntityComponents w)
-      return $ w {worldComponents = cs', worldEntityComponents = entityComponents'}
-{-# INLINE remove #-}
− src/Aztecs/World/Entities.hs 
@@ -1,33 +0,0 @@-module Aztecs.World.Entities where
-
-import Aztecs.Entity
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.Word
-
-data Entities = Entities
-  { entitiesNextGeneration :: Word32,
-    entitiesGenerations :: IntMap Word32,
-    entitiesNextIndex :: Word32,
-    entitiesFreeIndicies :: [Word32]
-  }
-
-emptyEntities :: Entities
-emptyEntities = Entities 0 IntMap.empty 0 []
-{-# INLINE emptyEntities #-}
-
-mkEntityWithCounter :: Entities -> (Entity, Entities)
-mkEntityWithCounter (Entities gen gens index free) =
-  let (i, nextIndex, free') = case free of
-        (i' : rest) -> (i', index, rest)
-        [] -> (index, index + 1, [])
-      nextGeneration = gen + 1
-      gens' = IntMap.insert (fromIntegral i) gen gens
-   in (mkEntity i gen, Entities nextGeneration gens' nextIndex free')
-{-# INLINE mkEntityWithCounter #-}
-
-entities :: Entities -> [Entity]
-entities (Entities _ gens _ _) = map go (IntMap.toList gens)
-  where
-    go (i, gen) = mkEntity (fromIntegral i) gen
-{-# INLINE entities #-}
test/Main.hs view
@@ -1,4 +1,188 @@-module Main where
-
-main :: IO ()
-main = return ()
+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Aztecs+import Aztecs.ECS.Component (ComponentID (ComponentID))+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.World as W+import Data.Functor.Identity (Identity (runIdentity))+import qualified Data.Vector as V+import Data.Word+import GHC.Generics+import Test.Hspec+import Test.QuickCheck++newtype X = X Int deriving (Eq, Show, Arbitrary, Generic)++instance Component X++newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic)++instance Component Y++newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic)++instance Component Z++main :: IO ()+main = hspec $ do+  describe "Aztecs.ECS.Query.single" $ do+    it "queries a single entity" prop_querySingle+  describe "Aztecs.ECS.Query.mapSingle" $ do+    it "maps a single entity" $ property prop_queryMapSingle+  describe "Aztecs.ECS.Query.all" $ 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 $ Q.all (Q.fetch @_ @X) $ W.entities W.empty in V.toList res `shouldMatchList` []++-- | Query all components from a list of `ComponentID`s.+queryComponentIds ::+  forall q a.+  (Applicative q, DynamicQueryReaderF q, Component a) =>+  [ComponentID] ->+  q (EntityID, [a])+queryComponentIds =+  let go cId qAcc = do+        x' <- 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 spawn xs' (acc, wAcc) =+        let spawn' x (bAcc, cAcc, idAcc) =+              ( dynBundle (ComponentID idAcc) x <> bAcc,+                (x, ComponentID idAcc) : cAcc,+                idAcc + 1+              )+            (b, cs, _) = foldr spawn' (mempty, [], 0) xs'+            (e, wAcc') = W.spawn b wAcc+         in ((e, cs) : acc, wAcc')+      (es, w) = foldr spawn ([], W.empty) xs+      go (e, cs) = do+        let q = queryComponentIds $ map snd cs+            (res, _) = Q.all q $ W.entities w+        return $ V.toList res `shouldContain` [(e, map fst cs)]+   in mapM_ go es++prop_queryTypedComponent :: [X] -> Expectation+prop_queryTypedComponent xs = do+  let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs+      (res, _) = Q.all Q.fetch $ W.entities w+  V.toList res `shouldMatchList` xs++prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation+prop_queryTwoTypedComponents xys = do+  let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys+      (res, _) = Q.all ((,) <$> Q.fetch <*> Q.fetch) $ W.entities w+  V.toList res `shouldMatchList` xys++prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation+prop_queryThreeTypedComponents xyzs = do+  let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs+      q = do+        x <- Q.fetch+        y <- Q.fetch+        z <- Q.fetch+        pure (x, y, z)+      (res, _) = Q.all q $ W.entities w+  V.toList res `shouldMatchList` xyzs++prop_querySingle :: Expectation+prop_querySingle =+  let (_, w) = W.spawn (bundle $ X 1) W.empty+      (res, _) = Q.single Q.fetch $ W.entities w+   in res `shouldBe` X 1++prop_queryMapSingle :: Word8 -> Expectation+prop_queryMapSingle n =+  let (_, w) = W.spawn (bundle $ X 0) W.empty+      q = Q.adjust (\_ (X x) -> X $ x + 1) (pure ())+      w' = foldr (\_ es -> snd . runIdentity $ Q.mapSingle q es) (W.entities w) [1 .. n]+      (res, _) = Q.single Q.fetch w'+   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+-}