packages feed

aztecs 0.8.0 → 0.9.0

raw patch · 57 files changed

+2478/−1488 lines, 57 filesdep +stm

Dependencies added: stm

Files

aztecs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          aztecs-version:       0.8.0+version:       0.9.0 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me@@ -39,23 +39,10 @@         Aztecs.ECS.Query.Dynamic.Reader.Class         Aztecs.ECS.Query.Reader         Aztecs.ECS.Query.Reader.Class-        Aztecs.ECS.Schedule-        Aztecs.ECS.Schedule.Access-        Aztecs.ECS.Schedule.Access.Class-        Aztecs.ECS.Schedule.Class-        Aztecs.ECS.Schedule.Dynamic-        Aztecs.ECS.Schedule.Dynamic.Reader-        Aztecs.ECS.Schedule.Reader-        Aztecs.ECS.Schedule.Reader.Class         Aztecs.ECS.System         Aztecs.ECS.System.Class-        Aztecs.ECS.System.Dynamic         Aztecs.ECS.System.Dynamic.Class-        Aztecs.ECS.System.Dynamic.Reader         Aztecs.ECS.System.Dynamic.Reader.Class-        Aztecs.ECS.System.Queue-        Aztecs.ECS.System.Queue.Class-        Aztecs.ECS.System.Reader         Aztecs.ECS.System.Reader.Class         Aztecs.ECS.View         Aztecs.ECS.World@@ -90,7 +77,8 @@         deepseq >=1,         linear >=1,         mtl >=2,-        parallel >=3+        parallel >=3,+        stm >=2  test-suite aztecs-test     type:             exitcode-stdio-1.0
bench/Bench.hs view
@@ -5,12 +5,13 @@  import Aztecs.ECS import qualified Aztecs.ECS.Query as Q-import qualified Aztecs.ECS.System as S-import Aztecs.ECS.World (World (..))+import Aztecs.ECS.World import qualified Aztecs.ECS.World as W+import Control.Arrow import Control.DeepSeq import Criterion.Main-import GHC.Generics (Generic)+import Data.Functor.Identity+import GHC.Generics  newtype Position = Position Int deriving (Show, Generic, NFData) @@ -21,21 +22,21 @@ instance Component Velocity  query :: Query () Position-query = proc () -> do-  Velocity v <- Q.fetch -< ()-  Position p <- Q.fetch -< ()-  Q.set -< Position $ p + v+query = Q.fetch >>> Q.adjust (\(Velocity v) (Position p) -> Position $ p + v) -run :: World -> World-run w = let !(_, es) = Q.map () query $ entities w in w {entities = es}+queryDo :: Query () Position+queryDo = proc () -> do+  Velocity v <- Q.fetch -< ()+  Q.adjust (\v (Position p) -> Position $ p + v) -< v -runSystem :: World -> IO World-runSystem w = do-  (_, _, w') <- runSchedule (system $ S.map query) w ()-  return w'+run :: Query () Position -> World -> [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 w, bench "iter system" . nfIO $ runSystem w]+  defaultMain+    [ bench "iter" $ nf (run query) w,+      bench "iter do-notation" $ nf (run queryDo) w+    ]
src/Aztecs/Asset.hs view
@@ -6,6 +6,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +-- |+-- Module      : Aztecs.Asset+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Asset   ( AssetId (..),     AssetServer (..),
src/Aztecs/Asset/AssetLoader.hs view
@@ -1,36 +1,58 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} +-- |+-- Module      : Aztecs.Asset.AssetLoader+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Asset.AssetLoader-  ( MonadAssetLoader (..),-    AssetLoader,+  ( AssetLoader,     AssetLoaderT (..),+    MonadAssetLoader (..),     load,     loadQuery,   ) where  import Aztecs.Asset.AssetLoader.Class-import Aztecs.Asset.AssetServer (AssetId (..), AssetServer (..), Handle (..))+import Aztecs.Asset.AssetServer import Aztecs.Asset.Class import Aztecs.ECS import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S-import Control.Arrow (returnA)-import Control.Concurrent (forkIO)-import Control.Monad.Identity (Identity)-import Control.Monad.State.Strict (MonadState (..), StateT, runState)-import Data.IORef (newIORef, writeIORef)+import Control.Arrow+import Control.Concurrent+import Control.Monad.Identity+import Control.Monad.State.Strict+import Data.IORef import qualified Data.Map.Strict as Map +-- | @since 9.0 type AssetLoader a o = AssetLoaderT a Identity o -newtype AssetLoaderT a m o = AssetLoaderT {unAssetLoader :: StateT (AssetServer a) m o}+-- | Asset loader monad.+--+-- @since 9.0+newtype AssetLoaderT a m o = AssetLoaderT+  { -- | State of the asset loader.+    --+    -- @since 9.0+    unAssetLoader :: StateT (AssetServer a) m o+  }   deriving newtype (Functor, Applicative, Monad) +-- | @since 9.0 instance (Monad m, Asset a) => MonadAssetLoader a (AssetLoaderT a m) where   asset path cfg = AssetLoaderT $ do     server <- get@@ -48,12 +70,18 @@         }     return $ Handle assetId -loadQuery :: (Asset a, ArrowQuery arr) => AssetLoader a o -> arr () o+-- | Query to load assets.+--+-- @since 9.0+loadQuery :: (Asset a, ArrowQuery m arr) => AssetLoader a o -> arr () o loadQuery a = proc () -> do-  assetServer <- Q.fetch -< ()-  let (o, assetServer') = runState (unAssetLoader a) assetServer-  Q.set -< assetServer'+  server <- Q.fetch -< ()+  let (o, server') = runState (unAssetLoader a) server+  Q.set -< server'   returnA -< o -load :: (ArrowQuery q, ArrowSystem q arr, Asset a) => AssetLoader a o -> arr () o-load a = S.mapSingle $ loadQuery a+-- | System to load assets.+--+-- @since 9.0+load :: forall m q s a o. (ArrowQuery m q, MonadSystem q s, Asset a) => AssetLoader a o -> s o+load a = S.mapSingle @q () $ loadQuery a
src/Aztecs/Asset/AssetLoader/Class.hs view
@@ -1,19 +1,23 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-} -module Aztecs.Asset.AssetLoader.Class-  ( MonadAssetLoader (..),-  )-where+-- |+-- Module      : Aztecs.Asset.AssetLoader.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.Asset.AssetLoader.Class (MonadAssetLoader (..)) where -import Aztecs.Asset.AssetServer (Handle)+import Aztecs.Asset.AssetServer import Aztecs.Asset.Class +-- | Monadic interface for loading assets.+--+-- @since 9.0 class MonadAssetLoader a m | m -> a where+  -- | Load an asset from a file path with a configuration.+  --+  -- @since 9.0   asset :: FilePath -> AssetConfig a -> m (Handle a)
src/Aztecs/Asset/AssetServer.hs view
@@ -1,22 +1,26 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-} +-- |+-- Module      : Aztecs.Asset.AssetServer+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Asset.AssetServer   ( AssetId (..),+    Handle (..),     AssetServer (..),     assetServer,-    Handle (..),+    lookupAsset,     setup,     loadAssets,-    lookupAsset,+    loadAssetServer,   ) where @@ -24,31 +28,56 @@ import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S-import Control.Arrow (returnA) import Control.DeepSeq-import Control.Monad.IO.Class (MonadIO (..))-import Data.Data (Typeable)-import Data.Foldable (foldrM)-import Data.IORef (IORef, readIORef)+import Control.Monad+import Control.Monad.IO.Class+import Data.Data+import Data.Foldable+import Data.IORef import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import GHC.Generics (Generic)+import GHC.Generics -newtype AssetId = AssetId {unAssetId :: Int}+-- | Unique identifier for an asset.+--+-- @since 9.0+newtype AssetId = AssetId+  { -- | Unique integer identifier.+    --+    -- @since 9.0+    unAssetId :: Int+  }   deriving (Eq, Ord, Show) +-- | Asset server.+--+-- @since 9.0 data AssetServer a = AssetServer-  { assetServerAssets :: !(Map AssetId a),+  { -- | Loaded assets.+    --+    -- @since 9.0+    assetServerAssets :: !(Map AssetId a),+    -- | Assets currently being loaded.+    --+    -- @since 9.0     loadingAssets :: !(Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))),+    -- | Next unique asset identifier.+    --+    -- @since 9.0     nextAssetId :: !AssetId   }   deriving (Generic) +-- | @since 9.0 instance (Typeable a) => Component (AssetServer a) +-- | @since 9.0 instance NFData (AssetServer a) where   rnf = rwhnf +-- | Empty asset server.+--+-- @since 9.0 assetServer :: AssetServer a assetServer =   AssetServer@@ -57,58 +86,57 @@       nextAssetId = AssetId 0     } -newtype Handle a = Handle {handleId :: AssetId}+-- | Handle to an asset.+--+-- @since 9.0+newtype Handle a = Handle+  { -- | Asset ID.+    --+    -- @since 9.0+    handleId :: AssetId+  }   deriving (Eq, Ord, Show) +-- | @since 9.0 instance NFData (Handle a) where   rnf = rwhnf +-- | Lookup an asset by its handle.+--+-- @since 9.0 lookupAsset :: Handle a -> AssetServer a -> Maybe a lookupAsset h server = Map.lookup (handleId h) (assetServerAssets server) -loadAssets ::-  forall a qr rs q s b m arr.-  ( Typeable a,-    ArrowQueryReader qr,-    ArrowReaderSystem qr rs,-    ArrowReaderSchedule rs arr,-    ArrowQuery q,-    ArrowSystem q s,-    ArrowSchedule s arr,-    MonadIO m,-    ArrowAccessSchedule b m arr-  ) =>-  arr () ()-loadAssets = proc () -> do-  server <- reader $ S.single (Q.fetch @_ @(AssetServer a)) -< ()-  server' <--    access-      ( \server ->-          liftIO $-            foldrM-              ( \(aId, v) acc -> do-                  case v of-                    Right r -> do-                      maybeSurface <- readIORef r-                      case maybeSurface of-                        Just surface ->-                          return-                            acc-                              { assetServerAssets = Map.insert aId surface (assetServerAssets acc),-                                loadingAssets = Map.delete aId (loadingAssets acc)-                              }-                        Nothing -> return acc-                    Left f -> do-                      v' <- f-                      return $ acc {loadingAssets = Map.insert aId (Right v') (loadingAssets server)}-              )-              server-              (Map.toList $ loadingAssets server)-      )-      -<-        server-  system $ S.mapSingle Q.set -< server'-  returnA -< ()+-- | Setup the asset server.+--+-- @since 9.0+setup :: forall m b a. (Typeable a, MonadAccess b m) => m ()+setup = A.spawn_ . bundle $ assetServer @a -setup :: forall a. (Typeable a) => System () ()-setup = S.queue . const . A.spawn_ . bundle $ assetServer @a+-- | Load any pending assets.+--+-- @since 9.0+loadAssets :: forall a q s m. (Typeable a, ArrowQuery m q, MonadSystem q s, MonadIO m) => s ()+loadAssets = void . S.map @q () $ Q.adjustM (\_ s -> loadAssetServer @m @a s)++-- | Load any pending assets in an `AssetServer`.+--+-- @since 9.0+loadAssetServer :: (MonadIO m) => AssetServer a -> m (AssetServer a)+loadAssetServer server =+  let go (aId, v) acc = do+        case v of+          Right r -> do+            maybeSurface <- readIORef r+            case maybeSurface of+              Just surface ->+                return+                  acc+                    { assetServerAssets = Map.insert aId surface (assetServerAssets acc),+                      loadingAssets = Map.delete aId (loadingAssets acc)+                    }+              Nothing -> return acc+          Left f -> do+            v' <- f+            return $ acc {loadingAssets = Map.insert aId (Right v') (loadingAssets server)}+   in liftIO . foldrM go server . Map.toList $ loadingAssets server
src/Aztecs/Asset/Class.hs view
@@ -1,10 +1,27 @@ {-# LANGUAGE TypeFamilies #-} +-- |+-- Module      : Aztecs.Asset.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Asset.Class (Asset (..)) where -import Data.Data (Typeable)+import Data.Data +-- | Loadable asset.+--+-- @since 9.0 class (Typeable a) => Asset a where+  -- | Configuration for loading an asset.+  --+  -- @since 9.0   type AssetConfig a +  -- | Load an asset from a file path with a configuration.+  --+  -- @since 9.0   loadAsset :: FilePath -> AssetConfig a -> IO a
src/Aztecs/Camera.hs view
@@ -1,8 +1,15 @@-{-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} +-- |+-- Module      : Aztecs.Camera+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Camera   ( Camera (..),     CameraTarget (..),@@ -14,47 +21,58 @@ import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query.Reader as Q import qualified Aztecs.ECS.System as S-import Aztecs.Window (Window)-import Control.Arrow (Arrow (..))+import Aztecs.Window+import Control.Arrow import Control.DeepSeq-import GHC.Generics (Generic)-import Linear (V2 (..))+import GHC.Generics+import Linear  -- | Camera component.+--+-- @since 9.0 data Camera = Camera   { -- | Camera viewport size.+    --+    -- @since 9.0     cameraViewport :: !(V2 Int),     -- | Camera scale factor.+    --+    -- @since 9.0     cameraScale :: !(V2 Float)   }   deriving (Show, Generic, NFData) +-- | @since 9.0 instance Component Camera  -- | Camera target component.+--+-- @since 9.0 newtype CameraTarget = CameraTarget   { -- | This camera's target window.+    --+    -- @since 9.0     cameraTargetWindow :: EntityID   }   deriving (Eq, Show, Generic, NFData) +-- | @since 9.0 instance Component CameraTarget  -- | Add `CameraTarget` components to entities with a new `Draw` component.+--+-- @since 9.0 addCameraTargets ::   ( ArrowQueryReader qr,     ArrowDynamicQueryReader qr,-    ArrowReaderSystem qr arr,-    ArrowQueueSystem b m arr+    MonadReaderSystem qr s,+    MonadAccess b m   ) =>-  arr () ()-addCameraTargets = proc () -> do-  windows <- S.all (Q.entity &&& Q.fetch @_ @Window) -< ()-  newCameras <- S.filter (Q.entity &&& Q.fetch @_ @Camera) (without @CameraTarget) -< ()-  S.queue-    ( \(newCameras, windows) -> case windows of-        (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ CameraTarget windowEId) newCameras+  s (m ())+addCameraTargets = do+  windows <- S.all () (Q.entity &&& Q.fetch @_ @Window)+  newCameras <- S.filter () (Q.entity &&& Q.fetch @_ @Camera) (without @CameraTarget)+  let go = case windows of+        (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId . bundle $ CameraTarget windowEId) newCameras         _ -> return ()-    )-    -<-      (newCameras, windows)+  return go
src/Aztecs/ECS.hs view
@@ -51,7 +51,10 @@ -- > main = runSystem_ $ setup >>> S.forever move module Aztecs.ECS   ( Access,+    AccessT,+    MonadAccess,     runAccessT,+    runAccessT_,     Bundle,     MonoidBundle (..),     DynamicBundle,@@ -59,6 +62,9 @@     Component (..),     EntityID,     Query,+    QueryT,+    QueryReader,+    QueryReaderT,     ArrowQueryReader,     ArrowQuery,     ArrowDynamicQueryReader,@@ -67,26 +73,14 @@     with,     without,     System,-    ArrowReaderSystem,-    ArrowSystem,-    ArrowQueueSystem,-    Schedule,-    ArrowReaderSchedule,-    ArrowSchedule,-    ArrowAccessSchedule,-    reader,-    system,-    delay,-    forever,-    forever_,-    access,-    runSchedule,-    runSchedule_,+    SystemT,+    MonadReaderSystem,+    MonadSystem,     World,   ) where -import Aztecs.ECS.Access (Access, runAccessT)+import Aztecs.ECS.Access import Aztecs.ECS.Component (Component (..)) import Aztecs.ECS.Entity (EntityID) import Aztecs.ECS.Query@@ -96,24 +90,12 @@     ArrowQueryReader,     Query,     QueryFilter,+    QueryT,     with,     without,   )-import Aztecs.ECS.Schedule-  ( ArrowAccessSchedule,-    ArrowReaderSchedule,-    ArrowSchedule,-    Schedule,-    access,-    delay,-    forever,-    forever_,-    reader,-    runSchedule,-    runSchedule_,-    system,-  )-import Aztecs.ECS.System (ArrowQueueSystem, ArrowReaderSystem, ArrowSystem, System)+import Aztecs.ECS.Query.Reader (QueryReader, QueryReaderT)+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
@@ -3,34 +3,77 @@ {-# 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 (MonadAccess (..))+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 (DynamicQueryReaderT)+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 Aztecs.ECS.World.Bundle (Bundle)-import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Identity (Identity)-import Control.Monad.State.Strict (MonadState (..), StateT (..))-import Prelude hiding (all, lookup, map)+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node (..))+import Aztecs.ECS.World.Bundle+import qualified Aztecs.ECS.World.Entities as E+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State.Strict+import qualified Data.Foldable as F +-- | @since 9.0 type Access = AccessT Identity  -- | Access into the `World`.+--+-- @since 9.0 newtype AccessT m a = AccessT {unAccessT :: StateT World m a}-  deriving (Functor, Applicative, Monad, MonadFix, MonadIO)+  deriving (Functor, Applicative, MonadFix, MonadIO) +-- | @since 9.0+instance (Monad m) => Monad (AccessT m) where+  a >>= f = AccessT $ do+    !w <- get+    (a', w') <- lift $ runAccessT a w+    put (rnf w' `seq` w')+    unAccessT $ f a'+ -- | Run an `Access` on a `World`, returning the output and updated `World`.+--+-- @since 9.0 runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World) runAccessT a = runStateT $ unAccessT a +-- | Run an `Access` on an empty `World`.+--+-- @since 9.0+runAccessT_ :: (Functor m) => AccessT m a -> m a+runAccessT_ a = fmap fst . runAccessT a $ W.empty++-- | @since 9.0 instance (Monad m) => MonadAccess Bundle (AccessT m) where   spawn b = AccessT $ do     !w <- get@@ -53,3 +96,81 @@     !w <- get     let !(_, w') = W.despawn e w     put w'++-- | @since 9.0+instance (Monad m) => MonadReaderSystem (QueryReaderT m) (AccessT m) where+  all i 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 i cIds dynQ+  filter i 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 i cIds dynQ f'++-- | @since 9.0+instance (Monad m) => MonadSystem (QueryT m) (AccessT m) where+  map i 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 i (Q.reads rws <> Q.writes rws) dynQ+  mapSingleMaybe i 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 i (Q.reads rws <> Q.writes rws) dynQ+  filterMap i 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 i (Q.reads rws <> Q.writes rws) f' dynQ++-- | @since 9.0+instance (Monad m) => MonadDynamicReaderSystem (DynamicQueryReaderT m) (AccessT m) where+  allDyn i cIds q = AccessT $ do+    !w <- get+    lift . Q.allDyn cIds i q $ entities w+  filterDyn i cIds q f = AccessT $ do+    !w <- get+    lift . Q.filterDyn cIds i f q $ entities w++-- | @since 9.0+instance (Monad m) => MonadDynamicSystem (DynamicQueryT m) (AccessT m) where+  mapDyn i cIds q = AccessT $ do+    !w <- get+    (as, es) <- lift . Q.mapDyn cIds i q $ entities w+    put w {entities = es}+    return as+  mapSingleMaybeDyn i cIds q = AccessT $ do+    !w <- get+    (res, es) <- lift . Q.mapSingleMaybeDyn cIds i q $ entities w+    put w {entities = es}+    return res+  filterMapDyn i cIds f q = AccessT $ do+    !w <- get+    (as, es) <- lift . Q.filterMapDyn cIds i f q $ entities w+    put w {entities = es}+    return as++-- | Run a `System`.+--+-- @since 9.0+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
@@ -1,32 +1,52 @@-{-# LANGUAGE FlexibleContexts #-} {-# 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 (Component (..))-import Aztecs.ECS.Entity (EntityID (..))-import Aztecs.ECS.World.Bundle (MonoidBundle (..))-import Prelude hiding (all, lookup, map)+import Aztecs.ECS.Component+import Aztecs.ECS.Entity+import Aztecs.ECS.World.Bundle.Class  -- | Monadic access to a `World`.+--+-- @since 9.0 class (MonoidBundle b, Monad m) => MonadAccess b m | m -> b where   -- | Spawn an entity with a component.+  --+  -- @since 9.0   spawn :: b -> m EntityID    -- | Spawn an entity with a component.+  --+  -- @since 9.0   spawn_ :: b -> m ()   spawn_ c = do     _ <- spawn c     return ()    -- | Insert a component into an entity.-  insert :: (Component a) => EntityID -> a -> m ()+  --+  -- @since 9.0+  insert :: EntityID -> b -> m ()    -- | Lookup a component on an entity.+  --+  -- @since 9.0   lookup :: (Component a) => EntityID -> m (Maybe a)    -- | Remove a component from an entity.+  --+  -- @since 9.0   remove :: (Component a) => EntityID -> m (Maybe a)    -- | Despawn an entity.+  --+  -- @since 9.0   despawn :: EntityID -> m ()
src/Aztecs/ECS/Component.hs view
@@ -3,21 +3,39 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Aztecs.ECS.Component (Component (..), ComponentID (..)) where+-- |+-- 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 (Storage)-import Control.DeepSeq (NFData)-import Data.Kind (Type)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)+import Aztecs.ECS.World.Storage+import Control.DeepSeq+import Data.Typeable+import GHC.Generics --- | Component ID.-newtype ComponentID = ComponentID {unComponentId :: Int}+-- | Unique component identifier.+--+-- @since 9.0+newtype ComponentID = ComponentID+  { -- | Unique integer identifier.+    --+    -- @since 9.0+    unComponentId :: Int+  }   deriving (Eq, Ord, Show, Generic, NFData)  -- | Component that can be stored in the `World`.+--+-- @since 9.0 class (Typeable a, Storage a (StorageT a)) => Component a where   -- | `Storage` of this component.-  type StorageT a :: Type+  --+  -- @since 9.0+  type StorageT a    type StorageT a = [a]
src/Aztecs/ECS/Entity.hs view
@@ -1,11 +1,26 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- |+-- Module      : Aztecs.ECS.Entity+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.ECS.Entity (EntityID (..)) where -import Control.DeepSeq (NFData)-import GHC.Generics (Generic)+import Control.DeepSeq+import GHC.Generics --- | Entity ID.-newtype EntityID = EntityID {unEntityId :: Int}+-- | Unique entity identifier.+--+-- @since 9.0+newtype EntityID = EntityID+  { -- | Unique integer identifier.+    --+    -- @since 9.0+    unEntityId :: Int+  }   deriving (Eq, Ord, Show, Generic, NFData)
src/Aztecs/ECS/Query.hs view
@@ -1,13 +1,43 @@+{-# 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 (..),+    Query,+    QueryT (..),     ArrowQueryReader (..),     ArrowQuery (..),     ArrowDynamicQueryReader (..),@@ -15,7 +45,14 @@      -- ** Running     all,+    all',+    single,+    single',+    singleMaybe,+    singleMaybe',     map,+    mapSingle,+    mapSingleMaybe,      -- ** Conversion     fromReader,@@ -33,102 +70,163 @@ where  import Aztecs.ECS.Component-import Aztecs.ECS.Query.Class (ArrowQuery (..))-import Aztecs.ECS.Query.Dynamic (DynamicQuery (..), fromDynReader, mapDyn, toDynReader)-import Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..))-import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..))-import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReader (..), with, without)+import Aztecs.ECS.Query.Class+import Aztecs.ECS.Query.Dynamic+import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReaderT (..), with, without) import qualified Aztecs.ECS.Query.Reader as QR-import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..))+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.Arrow (Arrow (..), ArrowChoice (..))-import Control.Category (Category (..))+import Control.Arrow+import Control.Category+import Control.Monad.Identity import Data.Set (Set) import qualified Data.Set as Set+import GHC.Stack import Prelude hiding (all, id, map, reads, (.)) +-- | @since 9.0+type Query i = QueryT Identity i+ -- | 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-newtype Query i o = Query {runQuery :: Components -> (ReadsWrites, Components, DynamicQuery i o)}+-- @since 9.0+newtype QueryT m i o = Query+  { -- | Run a query, producing a `DynamicQueryT`.+    --+    -- @since 9.0+    runQuery :: Components -> (ReadsWrites, Components, DynamicQueryT m i o)+  }   deriving (Functor) -instance Applicative (Query i) where+-- | @since 9.0+instance (Monad m) => Applicative (QueryT m i) where+  {-# INLINE pure #-}   pure a = Query (mempty,,pure a)+  {-# INLINE (<*>) #-}   (Query f) <*> (Query g) = Query $ \cs ->-    let (cIdsG, cs', aQS) = g cs-        (cIdsF, cs'', bQS) = f cs'+    let !(cIdsG, cs', aQS) = g cs+        !(cIdsF, cs'', bQS) = f cs'      in (cIdsG <> cIdsF, cs'', bQS <*> aQS) -instance Category Query where+-- | @since 9.0+instance (Monad m) => Category (QueryT m) where+  {-# INLINE id #-}   id = Query (mempty,,id)+  {-# INLINE (.) #-}   (Query f) . (Query g) = Query $ \cs ->-    let (cIdsG, cs', aQS) = g cs-        (cIdsF, cs'', bQS) = f cs'+    let !(cIdsG, cs', aQS) = g cs+        !(cIdsF, cs'', bQS) = f cs'      in (cIdsG <> cIdsF, cs'', bQS . aQS) -instance Arrow Query where+-- | @since 9.0+instance (Monad m) => Arrow (QueryT m) where+  {-# INLINE arr #-}   arr f = Query (mempty,,arr f)-  first (Query f) = Query $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', first qS)+  {-# INLINE first #-}+  first (Query f) = Query $ \cs -> let !(cIds, cs', qS) = f cs in (cIds, cs', first qS) -instance ArrowChoice Query where-  left (Query f) = Query $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', left qS)+-- |  @since 9.0+instance (Monad m) => ArrowChoice (QueryT m) where+  {-# INLINE left #-}+  left (Query f) = Query $ \cs -> let !(cIds, cs', qS) = f cs in (cIds, cs', left qS) -instance ArrowQueryReader Query where+-- | @since 9.0+instance (Monad m) => ArrowQueryReader (QueryT m) where+  {-# INLINE fetch #-}   fetch = fromReader fetch+  {-# INLINE fetchMaybe #-}   fetchMaybe = fromReader fetchMaybe -instance ArrowDynamicQueryReader Query where+-- | @since 9.0+instance (Monad m) => ArrowDynamicQueryReader (QueryT m) where+  {-# INLINE entity #-}   entity = fromReader entity+  {-# INLINE fetchDyn #-}   fetchDyn = fromReader . fetchDyn+  {-# INLINE fetchMaybeDyn #-}   fetchMaybeDyn = fromReader . fetchMaybeDyn -instance ArrowDynamicQuery Query where+-- | @since 9.0+instance (Monad m) => ArrowDynamicQuery m (QueryT m) where+  {-# INLINE adjustDyn #-}+  adjustDyn f cId = Query (ReadsWrites Set.empty (Set.singleton cId),,adjustDyn f cId)+  {-# INLINE adjustDyn_ #-}+  adjustDyn_ f cId = Query (ReadsWrites Set.empty (Set.singleton cId),,adjustDyn_ f cId)+  {-# INLINE adjustDynM #-}+  adjustDynM f cId = Query (ReadsWrites Set.empty (Set.singleton cId),,adjustDynM f cId)+  {-# INLINE setDyn #-}   setDyn cId = Query (ReadsWrites Set.empty (Set.singleton cId),,setDyn cId) -instance ArrowQuery Query where-  set :: forall a. (Component a) => Query a a-  set = Query $ \cs ->-    let (cId, cs') = CS.insert @a cs-     in (ReadsWrites Set.empty (Set.singleton cId), cs', setDyn cId)+-- | @since 9.0+instance (Monad m) => ArrowQuery m (QueryT m) where+  {-# INLINE adjust #-}+  adjust :: forall i a. (Component a) => (i -> a -> a) -> QueryT m i a+  adjust f = fromDyn @a $ adjustDyn f -fromReader :: QueryReader i o -> Query i o+  {-# INLINE adjust_ #-}+  adjust_ :: forall i a. (Component a) => (i -> a -> a) -> QueryT m i ()+  adjust_ f = fromDyn @a $ adjustDyn_ f++  {-# INLINE adjustM #-}+  adjustM :: forall i a. (Component a, Monad m) => (i -> a -> m a) -> QueryT m i a+  adjustM f = fromDyn @a $ adjustDynM f++  {-# INLINE set #-}+  set :: forall a. (Component a) => QueryT m a a+  set = fromDyn @a $ setDyn++-- | Convert a `DynamicQueryT` to a `Query`.+--+-- @since 9.0+{-# INLINE fromDyn #-}+fromDyn :: forall a m i o. (Component a) => (ComponentID -> DynamicQueryT m i o) -> QueryT m i o+fromDyn f = Query $ \cs ->+  let !(cId, cs') = CS.insert @a cs in (ReadsWrites (Set.singleton cId) (Set.singleton cId), cs', f cId)++-- | Convert a `QueryReader` to a `Query`.+--+-- @since 9.0+{-# INLINE fromReader #-}+fromReader :: (Monad m) => QueryReaderT m i o -> QueryT m i o fromReader (QueryReader f) = Query $ \cs ->-  let (cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ)+  let !(cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ) -toReader :: Query i o -> QueryReader i o+-- | Convert a `Query` to a `QueryReader`.+--+-- @since 9.0+{-# INLINE toReader #-}+toReader :: (Functor m) => QueryT m i o -> QueryReaderT m i o toReader (Query f) = QueryReader $ \cs ->-  let (rws, cs', dynQ) = f cs in (reads rws, cs', toDynReader dynQ)+  let !(rws, cs', dynQ) = f cs in (reads rws, cs', toDynReader dynQ)  -- | Reads and writes of a `Query`.+--+-- @since 9.0 data ReadsWrites = ReadsWrites-  { reads :: !(Set ComponentID),+  { -- | Component IDs being read.+    --+    -- @since 9.0+    reads :: !(Set ComponentID),+    -- | Component IDs being written.+    --+    -- @since 9.0     writes :: !(Set ComponentID)   }   deriving (Show) +-- | @since 9.0 instance Semigroup ReadsWrites where   ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2) +-- | @since 9.0 instance Monoid ReadsWrites where   mempty = ReadsWrites mempty mempty  -- | `True` if the reads and writes of two `Query`s overlap.+--+-- @since 9.0 disjoint :: ReadsWrites -> ReadsWrites -> Bool disjoint a b =   Set.disjoint (reads a) (writes b)@@ -136,13 +234,76 @@     || Set.disjoint (writes b) (writes a)  -- | Match all entities.-all :: i -> Query i a -> Entities -> ([a], Entities)+--+-- @since 9.0+{-# INLINE all #-}+all :: (Monad m) => i -> QueryT m i a -> Entities -> (m [a], Entities) all i = QR.all i . toReader +-- | Match all entities.+--+-- @since 9.0+{-# INLINE all' #-}+all' :: (Monad m) => i -> QueryT m i a -> Entities -> (m [a], Components)+all' i = QR.all' i . toReader++-- | Match a single entity.+--+-- @since 9.0+{-# INLINE single #-}+single :: (HasCallStack) => i -> Query i a -> Entities -> (a, Entities)+single i = QR.single i . toReader++-- | Match a single entity.+--+-- @since 9.0+{-# INLINE single' #-}+single' :: (HasCallStack) => i -> Query i a -> Entities -> (a, Components)+single' i = QR.single' i . toReader++-- | Match a single entity, or `Nothing`.+--+-- @since 9.0+{-# INLINE singleMaybe #-}+singleMaybe :: i -> Query i a -> Entities -> (Maybe a, Entities)+singleMaybe i = QR.singleMaybe i . toReader++-- | Match a single entity, or `Nothing`.+--+-- @since 9.0+{-# INLINE singleMaybe' #-}+singleMaybe' :: i -> Query i a -> Entities -> (Maybe a, Components)+singleMaybe' i = QR.singleMaybe' i . toReader+ -- | Map all matched entities.-map :: i -> Query i a -> Entities -> ([a], Entities)-map i q es =-  let (rws, cs', dynQ) = runQuery q (components es)-      cIds = reads rws <> writes rws-      (as, es') = mapDyn cIds i dynQ es-   in (as, es' {components = cs'})+--+-- @since 9.0+{-# INLINE map #-}+map :: (Monad m) => i -> QueryT m i o -> Entities -> m ([o], Entities)+map i q es = do+  let !(rws, cs', dynQ) = runQuery q $ components es+      !cIds = reads rws <> writes rws+  (as, es') <- mapDyn cIds i dynQ es+  return (as, es' {components = cs'})++-- | Map a single matched entity.+--+-- @since 9.0+{-# INLINE mapSingle #-}+mapSingle :: (HasCallStack, Monad m) => i -> QueryT m i a -> Entities -> m (a, Entities)+mapSingle i q es = do+  let !(rws, cs', dynQ) = runQuery q $ components es+      !cIds = reads rws <> writes rws+  (as, es') <- mapSingleDyn cIds i dynQ es+  return (as, es' {components = cs'})++-- | Map a single matched entity, or `Nothing`.+--+-- @since 9.0+{-# INLINE mapSingleMaybe #-}+mapSingleMaybe :: (Monad m) => i -> QueryT m i a -> Entities -> m (Maybe a, Entities)+mapSingleMaybe i q es = do+  let !(rws, cs', dynQ) = runQuery q $ components es+      !cIds = reads rws <> writes rws+  (as, es') <- mapSingleMaybeDyn cIds i dynQ es+  return (as, es' {components = cs'})
src/Aztecs/ECS/Query/Class.hs view
@@ -1,9 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- 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 (ArrowQuery (..)) where  import Aztecs.ECS.Component import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader)+import Control.Arrow  -- | Arrow for queries that can update entities.-class (ArrowQueryReader arr) => ArrowQuery arr where+--+-- @since 9.0+class (ArrowQueryReader arr) => ArrowQuery m arr | arr -> m where+  -- | Adjust a `Component` by its type.+  --+  -- @since 9.0+  adjust :: (Component a) => (i -> a -> a) -> arr i a++  -- | Adjust a `Component` by its type, ignoring any output.+  --+  -- @since 9.0+  adjust_ :: (Component a) => (i -> a -> a) -> arr i ()+  adjust_ f = adjust @m f >>> arr (const ())++  -- | Adjust a `Component` by its type with some `Monad` @m@.+  --+  -- @since 9.0+  adjustM :: (Component a) => (i -> a -> m a) -> arr i a+   -- | Set a `Component` by its type.+  --+  -- @since 9.0   set :: (Component a) => arr a a
src/Aztecs/ECS/Query/Dynamic.hs view
@@ -1,10 +1,21 @@ {-# 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 (..),+    DynamicQuery,+    DynamicQueryT (..),     ArrowDynamicQueryReader (..),     ArrowDynamicQuery (..), @@ -14,93 +25,192 @@      -- ** Running     mapDyn,+    filterMapDyn,+    mapSingleDyn,+    mapSingleMaybeDyn,      -- * Dynamic query filters     DynamicQueryFilter (..),   ) where -import Aztecs.ECS.Component (ComponentID)-import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryFilter (..), DynamicQueryReader (..))-import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..))+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.Arrow (Arrow (..), ArrowChoice (..))-import Control.Category (Category (..))+import Control.Arrow+import Control.Category+import Control.Monad.Identity import Data.Either (partitionEithers) import Data.Foldable import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set+import GHC.Stack (HasCallStack) import Prelude hiding ((.)) +-- | @since 9.0+type DynamicQuery = DynamicQueryT Identity+ -- | Dynamic query for components by ID.-newtype DynamicQuery i o-  = DynamicQuery {runDynQuery :: [i] -> [EntityID] -> Archetype -> ([o], Archetype)}+--+-- @since 9.0+newtype DynamicQueryT m i o+  = DynamicQuery+  { -- | Run a dynamic query with a list of inputs with length equal to the number of entities in the `Archetype`.+    -- This is an internal function that should typically not be used directly.+    --+    -- @since 9.0+    runDynQuery :: [i] -> Archetype -> m ([o], Archetype)+  }   deriving (Functor) -instance Applicative (DynamicQuery i) where-  pure a = DynamicQuery $ \_ es arch -> (replicate (length es) a, arch)--  f <*> g = DynamicQuery $ \i es arch ->-    let (as, arch') = runDynQuery g i es arch-        (fs, arch'') = runDynQuery f i es arch'-     in (zipWith ($) fs as, arch'')--instance Category DynamicQuery where-  id = DynamicQuery $ \as _ arch -> (as, arch)+-- | @since 9.0+instance (Monad m) => Applicative (DynamicQueryT m i) where+  {-# INLINE pure #-}+  pure a = DynamicQuery $ \is arch -> pure (replicate (length is) a, arch)+  {-# INLINE (<*>) #-}+  f <*> g = DynamicQuery $ \i arch -> do+    (as, arch') <- runDynQuery g i arch+    (fs, arch'') <- runDynQuery f i arch'+    return (zipWith ($) fs as, arch'') -  f . g = DynamicQuery $ \i es arch ->-    let (as, arch') = runDynQuery g i es arch in runDynQuery f as es arch'+-- | @since 9.0+instance (Monad m) => Category (DynamicQueryT m) where+  {-# INLINE id #-}+  id = DynamicQuery $ curry pure+  {-# INLINE (.) #-}+  f . g = DynamicQuery $ \i arch -> do+    (as, arch') <- runDynQuery g i arch+    runDynQuery f as arch' -instance Arrow DynamicQuery where-  arr f = DynamicQuery $ \bs _ arch -> (fmap f bs, arch)-  first f = DynamicQuery $ \bds es arch ->-    let (bs, ds) = unzip bds-        (cs, arch') = runDynQuery f bs es arch-     in (zip cs ds, arch')+-- | @since 9.0+instance (Monad m) => Arrow (DynamicQueryT m) where+  {-# INLINE arr #-}+  arr f = DynamicQuery $ \bs arch -> pure (fmap f bs, arch)+  {-# INLINE first #-}+  first f = DynamicQuery $ \bds arch -> do+    let !(bs, ds) = unzip bds+    (cs, arch') <- runDynQuery f bs arch+    return (zip cs ds, arch') -instance ArrowChoice DynamicQuery where-  left f = DynamicQuery $ \eds es arch ->-    let (es', ds) = partitionEithers eds-        (cs, arch') = runDynQuery f es' es arch-     in (fmap Left cs ++ fmap Right ds, arch')+-- | @since 9.0+instance (Monad m) => ArrowChoice (DynamicQueryT m) where+  {-# INLINE left #-}+  left f = DynamicQuery $ \eds arch -> do+    let !(es', ds) = partitionEithers eds+    (cs, arch') <- runDynQuery f es' arch+    return (fmap Left cs ++ fmap Right ds, arch') -instance ArrowDynamicQueryReader DynamicQuery where+-- | @since 9.0+instance (Monad m) => ArrowDynamicQueryReader (DynamicQueryT m) where+  {-# INLINE entity #-}   entity = fromDynReader entity+  {-# INLINE fetchDyn #-}   fetchDyn = fromDynReader . fetchDyn+  {-# INLINE fetchMaybeDyn #-}   fetchMaybeDyn = fromDynReader . fetchMaybeDyn -instance ArrowDynamicQuery DynamicQuery where-  setDyn cId = DynamicQuery $ \is _ arch ->-    let !arch' = A.insertAscList cId is arch in (is, arch')+-- | @since 9.0+instance (Monad m) => ArrowDynamicQuery m (DynamicQueryT m) where+  {-# INLINE adjustDyn #-}+  adjustDyn f cId = DynamicQuery $ \is arch -> pure $ A.zipWith is f cId arch -fromDynReader :: DynamicQueryReader i o -> DynamicQuery i o-fromDynReader q = DynamicQuery $ \is es arch ->-  let os = runDynQueryReader' q is es arch in (os, arch)+  {-# INLINE adjustDyn_ #-}+  adjustDyn_ f cId = DynamicQuery $ \is arch -> pure (repeat (), A.zipWith_ is f cId arch) -toDynReader :: DynamicQuery i o -> DynamicQueryReader i o-toDynReader q = DynamicQueryReader $ \is es arch -> fst $ runDynQuery q is es arch+  {-# INLINE adjustDynM #-}+  adjustDynM f cId = DynamicQuery $ \is arch -> A.zipWithM is f cId arch +  {-# INLINE setDyn #-}+  setDyn cId = DynamicQuery $ \is arch -> pure (is, A.insertAscList cId is arch)++-- | Convert a `DynamicQueryReaderT` to a `DynamicQueryT`.+--+-- @since 9.0+{-# INLINE fromDynReader #-}+fromDynReader :: (Monad m) => DynamicQueryReaderT m i o -> DynamicQueryT m i o+fromDynReader q = DynamicQuery $ \is arch -> do+  !os <- runDynQueryReader' q is arch+  return (os, arch)++-- | Convert a `DynamicQueryT` to a `DynamicQueryReaderT`.+--+-- @since 9.0+{-# INLINE toDynReader #-}+toDynReader :: (Functor m) => DynamicQueryT m i o -> DynamicQueryReaderT m i o+toDynReader q = DynamicQueryReader $ \is arch -> fst <$> runDynQuery q is arch+ -- | Map all matched entities.-mapDyn :: Set ComponentID -> i -> DynamicQuery i a -> Entities -> ([a], Entities)+--+-- @since 9.0+{-# INLINE mapDyn #-}+mapDyn :: (Monad m) => Set ComponentID -> i -> DynamicQueryT m i a -> Entities -> m ([a], Entities) mapDyn cIds i q es =-  let (as, es') =-        if Set.null cIds-          then (fst $ go (Map.keys $ entities es) A.empty, es)-          else-            foldl'-              ( \(acc, esAcc) (aId, n) ->-                  let (as', arch') = go (Set.toList . A.entities $ nodeArchetype n) (nodeArchetype n)-                      nodes = Map.insert aId n {nodeArchetype = arch'} (AS.nodes $ archetypes esAcc)-                   in (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})-              )-              ([], es)-              (Map.toList $ AS.find cIds (archetypes es))-      go = runDynQuery q (repeat i)-   in (as, es')+  let go = runDynQuery q (repeat i)+   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'} . AS.nodes $ archetypes esAcc+                return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})+           in foldlM go' ([], es) $ Map.toList . AS.find cIds $ archetypes es++-- | Map all matched entities.+--+-- @since 9.0+{-# INLINE filterMapDyn #-}+filterMapDyn :: (Monad m) => Set ComponentID -> i -> (Node -> Bool) -> DynamicQueryT m i a -> Entities -> m ([a], Entities)+filterMapDyn cIds i f q es =+  let go = runDynQuery q (repeat i)+   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'} . AS.nodes $ archetypes esAcc+                return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})+           in foldlM go' ([], es) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es++-- | Map a single matched entity.+--+-- @since 9.0+mapSingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> i -> DynamicQueryT m i a -> Entities -> m (a, Entities)+mapSingleDyn cIds i q es = do+  res <- mapSingleMaybeDyn cIds i 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 9.0+{-# INLINE mapSingleMaybeDyn #-}+mapSingleMaybeDyn :: (Monad m) => Set ComponentID -> i -> DynamicQueryT m i a -> Entities -> m (Maybe a, Entities)+mapSingleMaybeDyn cIds i q es =+  if Set.null cIds+    then case Map.keys $ entities es of+      [eId] -> do+        res <- runDynQuery q [i] $ A.singleton eId+        return $ case res of+          ([a], _) -> (Just a, es)+          _ -> (Nothing, es)+      _ -> pure (Nothing, es)+    else case Map.toList $ AS.find cIds $ archetypes es of+      [(aId, n)] -> do+        res <- runDynQuery q [i] (AS.nodeArchetype n)+        return $ case res of+          ([a], arch') ->+            let nodes = Map.insert aId n {nodeArchetype = arch'} . AS.nodes $ archetypes es+             in (Just a, es {archetypes = (archetypes es) {AS.nodes = nodes}})+          _ -> (Nothing, es)+      _ -> pure (Nothing, es)
src/Aztecs/ECS/Query/Dynamic/Class.hs view
@@ -1,7 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- 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 (ArrowDynamicQuery (..)) where  import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader)+import Aztecs.ECS.Query.Dynamic.Reader.Class+import Control.Arrow -class (ArrowDynamicQueryReader arr) => ArrowDynamicQuery arr where+-- | Arrow dynamic query.+--+-- @since 9.0+class (ArrowDynamicQueryReader arr) => ArrowDynamicQuery m arr | arr -> m where+  -- | Adjust a `Component` by its `ComponentID`.+  --+  -- @since 9.0+  adjustDyn :: (Component a) => (i -> a -> a) -> ComponentID -> arr i a++  -- | Adjust a `Component` by its `ComponentID`, ignoring any output.+  --+  -- @since 9.0+  adjustDyn_ :: (Component a) => (i -> a -> a) -> ComponentID -> arr i ()+  adjustDyn_ f cid = adjustDyn @m f cid >>> arr (const ())++  -- | Adjust a `Component` by its `ComponentID` with some `Monad` @m@.+  --+  -- @since 9.0+  adjustDynM :: (Component a) => (i -> a -> m a) -> ComponentID -> arr i a++  -- | Set a `Component` by its `ComponentID`.+  --+  -- @since 9.0   setDyn :: (Component a) => ComponentID -> arr a a
src/Aztecs/ECS/Query/Dynamic/Reader.hs view
@@ -1,19 +1,29 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# 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 (..),+    DynamicQueryReader,+    DynamicQueryReaderT (..),     ArrowDynamicQueryReader (..),      -- ** Running     allDyn,+    filterDyn,+    singleDyn,+    singleMaybeDyn,     runDynQueryReader,+    runDynQueryReaderT,      -- * Dynamic query filters     DynamicQueryFilter (..),@@ -21,84 +31,166 @@ where  import Aztecs.ECS.Component-import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..))+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 Aztecs.ECS.World.Storage as S import Control.Arrow import Control.Category-import Data.Either (partitionEithers)+import Control.Monad.Identity+import Data.Either import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set+import GHC.Stack +-- | @since 9.0+type DynamicQueryReader = DynamicQueryReaderT Identity+ -- | Dynamic query for components by ID.-newtype DynamicQueryReader i o-  = DynamicQueryReader {runDynQueryReader' :: [i] -> [EntityID] -> Archetype -> [o]}+--+-- @since 9.0+newtype DynamicQueryReaderT m i o+  = DynamicQueryReader+  { -- | Run a dynamic query with a list of inputs with length equal to the number of entities in the `Archetype`.+    -- This is an internal function that should typically not be used directly.+    --+    -- @since 9.0+    runDynQueryReader' :: [i] -> Archetype -> m [o]+  }   deriving (Functor) -instance Applicative (DynamicQueryReader i) where-  pure a = DynamicQueryReader $ \_ es _ -> replicate (length es) a-+-- | @since 9.0+instance (Monad m) => Applicative (DynamicQueryReaderT m i) where+  {-# INLINE pure #-}+  pure a = DynamicQueryReader $ \is _ -> pure $ replicate (length is) a+  {-# INLINE (<*>) #-}   f <*> g =-    DynamicQueryReader $ \i es arch ->-      let as = runDynQueryReader' g i es arch-          fs = runDynQueryReader' f i es arch-       in zipWith ($) fs as+    DynamicQueryReader $ \i arch -> do+      !as <- runDynQueryReader' g i arch+      !fs <- runDynQueryReader' f i arch+      return $ zipWith ($) fs as -instance Category DynamicQueryReader where-  id = DynamicQueryReader $ \as _ _ -> as-  f . g = DynamicQueryReader $ \i es arch ->-    let as = runDynQueryReader' g i es arch in runDynQueryReader' f as es arch+-- | @since 9.0+instance (Monad m) => Category (DynamicQueryReaderT m) where+  {-# INLINE id #-}+  id = DynamicQueryReader $ \as _ -> pure as+  {-# INLINE (.) #-}+  f . g = DynamicQueryReader $ \i arch -> do+    !as <- runDynQueryReader' g i arch+    runDynQueryReader' f as arch -instance Arrow DynamicQueryReader where-  arr f = DynamicQueryReader $ \bs _ _ -> fmap f bs-  first f = DynamicQueryReader $ \bds es arch ->-    let (bs, ds) = unzip bds-        cs = runDynQueryReader' f bs es arch-     in zip cs ds+-- | @since 9.0+instance (Monad m) => Arrow (DynamicQueryReaderT m) where+  {-# INLINE arr #-}+  arr f = DynamicQueryReader $ \bs _ -> pure $ fmap f bs+  {-# INLINE first #-}+  first f = DynamicQueryReader $ \bds arch -> do+    let !(bs, ds) = unzip bds+    !cs <- runDynQueryReader' f bs arch+    return $ zip cs ds -instance ArrowChoice DynamicQueryReader where-  left f = DynamicQueryReader $ \eds es arch ->-    let (es', ds) = partitionEithers eds-        cs = runDynQueryReader' f es' es arch-     in fmap Left cs ++ fmap Right ds+-- | @since 9.0+instance (Monad m) => ArrowChoice (DynamicQueryReaderT m) where+  {-# INLINE left #-}+  left f = DynamicQueryReader $ \eds arch -> do+    let !(es', ds) = partitionEithers eds+    !cs <- runDynQueryReader' f es' arch+    return $ fmap Left cs ++ fmap Right ds -instance ArrowDynamicQueryReader DynamicQueryReader where-  entity = DynamicQueryReader $ \_ es _ -> es-  fetchDyn :: forall a. (Component a) => ComponentID -> DynamicQueryReader () a-  fetchDyn cId = DynamicQueryReader $ \_ _ arch ->-    maybe [] (S.toAscList @a @(StorageT a)) (A.lookupStorage @a cId arch)-  fetchMaybeDyn :: forall a. (Component a) => ComponentID -> DynamicQueryReader () (Maybe a)-  fetchMaybeDyn cId = DynamicQueryReader $ \_ es arch -> case A.lookupStorage @a cId arch of-    Just s -> let !as = S.toAscList @a @(StorageT a) s in fmap Just as-    Nothing -> map (const Nothing) es+-- | @since 9.0+instance (Monad m) => ArrowDynamicQueryReader (DynamicQueryReaderT m) where+  {-# INLINE entity #-}+  entity = DynamicQueryReader $ \_ arch -> pure $ Set.toList $ A.entities arch+  {-# INLINE fetchDyn #-}+  fetchDyn cId = DynamicQueryReader $ \_ arch -> pure $ A.lookupComponentsAsc cId arch+  {-# INLINE fetchMaybeDyn #-}+  fetchMaybeDyn cId = DynamicQueryReader $ \is arch -> pure $ case A.lookupComponentsAscMaybe cId arch of+    Just as -> fmap Just as+    Nothing -> map (const Nothing) is +-- | Dynamic query filter.+--+-- @since 9.0 data DynamicQueryFilter = DynamicQueryFilter-  { filterWith :: !(Set ComponentID),+  { -- | `ComponentID`s to include.+    --+    -- @since 9.0+    filterWith :: !(Set ComponentID),+    -- | `ComponentID`s to exclude.+    --+    -- @since 9.0     filterWithout :: !(Set ComponentID)   } +-- | @since 9.0 instance Semigroup DynamicQueryFilter where   DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB =     DynamicQueryFilter (withA <> withB) (withoutA <> withoutB) +-- | @since 9.0 instance Monoid DynamicQueryFilter where   mempty = DynamicQueryFilter mempty mempty -runDynQueryReader :: i -> DynamicQueryReader i o -> [EntityID] -> Archetype -> [o]-runDynQueryReader i q = runDynQueryReader' q (repeat i)+-- | Run a dynamic query.+--+-- @since 9.0+{-# INLINE runDynQueryReaderT #-}+runDynQueryReaderT :: i -> DynamicQueryReaderT m i o -> Archetype -> m [o]+runDynQueryReaderT i q arch = runDynQueryReader' q (replicate (length $ A.entities arch) i) arch +-- | Run a dynamic query.+--+-- @since 9.0+{-# INLINE runDynQueryReader #-}+runDynQueryReader :: i -> DynamicQueryReader i o -> Archetype -> [o]+runDynQueryReader i q arch = runIdentity $ runDynQueryReaderT i q arch+ -- | Match all entities.-allDyn :: Set ComponentID -> i -> DynamicQueryReader i a -> Entities -> [a]+--+-- @since 9.0+allDyn :: (Monad m) => Set ComponentID -> i -> DynamicQueryReaderT m i a -> Entities -> m [a] allDyn cIds i q es =   if Set.null cIds-    then runDynQueryReader i q (Map.keys $ entities es) A.empty+    then runDynQueryReaderT i q A.empty {A.entities = Map.keysSet $ entities es}     else-      let go n =-            let eIds = Set.toList $ A.entities $ AS.nodeArchetype n-             in runDynQueryReader i q eIds (AS.nodeArchetype n)-       in concatMap go (AS.find cIds $ archetypes es)+      let go n = runDynQueryReaderT i q $ AS.nodeArchetype n+       in concat <$> mapM go (AS.find cIds $ archetypes es)++-- | Match all entities with a filter.+--+-- @since 9.0+filterDyn :: (Monad m) => Set ComponentID -> i -> (Node -> Bool) -> DynamicQueryReaderT m i a -> Entities -> m [a]+filterDyn cIds i f q es =+  if Set.null cIds+    then runDynQueryReaderT i q A.empty {A.entities = Map.keysSet $ entities es}+    else+      let go n = runDynQueryReaderT i q $ AS.nodeArchetype n+       in concat <$> mapM go (Map.filter f $ AS.find cIds $ archetypes es)++-- | Match a single entity.+--+-- @since 9.0+singleDyn :: (HasCallStack) => Set ComponentID -> i -> DynamicQueryReader i a -> Entities -> a+singleDyn cIds i q es = case singleMaybeDyn cIds i q es of+  Just a -> a+  _ -> error "singleDyn: expected a single entity"++-- | Match a single entity, or `Nothing`.+--+-- @since 9.0+singleMaybeDyn :: Set ComponentID -> i -> DynamicQueryReader i a -> Entities -> Maybe a+singleMaybeDyn cIds i q es =+  if Set.null cIds+    then case Map.keys $ entities es of+      [eId] -> case runDynQueryReader i q $ A.singleton eId of+        [a] -> Just a+        _ -> Nothing+      _ -> Nothing+    else case Map.elems $ AS.find cIds $ archetypes es of+      [n] -> case runDynQueryReader i q $ AS.nodeArchetype n of+        [a] -> Just a+        _ -> Nothing+      _ -> Nothing
src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs view
@@ -1,16 +1,33 @@+-- |+-- 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 (ArrowDynamicQueryReader (..)) where  import Aztecs.ECS.Component-import Aztecs.ECS.Entity (EntityID)-import Control.Arrow (Arrow (..), (>>>))+import Aztecs.ECS.Entity+import Control.Arrow +-- | Arrow dynamic query reader.+--+-- @since 9.0 class (Arrow arr) => ArrowDynamicQueryReader arr where   -- | Fetch the currently matched `EntityID`.+  --+  -- @since 9.0   entity :: arr () EntityID    -- | Fetch a `Component` by its `ComponentID`.+  --+  -- @since 9.0   fetchDyn :: (Component a) => ComponentID -> arr () a    -- | Try to fetch a `Component` by its `ComponentID`.+  --+  -- @since 9.0   fetchMaybeDyn :: (Component a) => ComponentID -> arr () (Maybe a)   fetchMaybeDyn cId = fetchDyn cId >>> arr Just
src/Aztecs/ECS/Query/Reader.hs view
@@ -1,20 +1,36 @@ {-# 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 (..),+    QueryReader,+    QueryReaderT (..),     ArrowQueryReader (..),     ArrowDynamicQueryReader (..),      -- ** Running     all,     all',+    single,+    single',+    singleMaybe,+    singleMaybe',      -- * Filters     QueryFilter (..),@@ -25,87 +41,162 @@ where  import Aztecs.ECS.Component-import Aztecs.ECS.Query.Dynamic (DynamicQueryFilter (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..), allDyn)-import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..))-import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..))+import Aztecs.ECS.Query.Dynamic.Reader+import Aztecs.ECS.Query.Reader.Class import Aztecs.ECS.World.Components (Components) import qualified Aztecs.ECS.World.Components as CS import Aztecs.ECS.World.Entities (Entities (..)) import qualified Aztecs.ECS.World.Entities as E-import Control.Arrow (Arrow (..), ArrowChoice (..))-import Control.Category (Category (..))+import Control.Arrow+import Control.Category+import Control.Monad.Identity import Data.Set (Set) import qualified Data.Set as Set+import GHC.Stack import Prelude hiding (all, id, (.)) +-- | @since 9.0+type QueryReader = QueryReaderT Identity+ -- | Query to read from entities.-newtype QueryReader i o-  = QueryReader {runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReader i o)}+--+-- @since 9.0+newtype QueryReaderT m i o+  = QueryReader+  { -- | Run a query reader.+    --+    -- @since 9.0+    runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReaderT m i o)+  }   deriving (Functor) -instance Applicative (QueryReader i) where-  pure a = QueryReader $ \cs -> (mempty, cs, pure a)+-- | @since 9.0+instance (Monad m) => Applicative (QueryReaderT m i) where+  {-# INLINE pure #-}+  pure a = QueryReader (mempty,,pure a)+  {-# INLINE (<*>) #-}   (QueryReader f) <*> (QueryReader g) = QueryReader $ \cs ->-    let (cIdsG, cs', aQS) = g cs-        (cIdsF, cs'', bQS) = f cs'+    let !(cIdsG, cs', aQS) = g cs+        !(cIdsF, cs'', bQS) = f cs'      in (cIdsG <> cIdsF, cs'', bQS <*> aQS) -instance Category QueryReader where-  id = QueryReader $ \cs -> (mempty, cs, id)+-- | @since 9.0+instance (Monad m) => Category (QueryReaderT m) where+  {-# INLINE id #-}+  id = QueryReader (mempty,,id)+  {-# INLINE (.) #-}   (QueryReader f) . (QueryReader g) = QueryReader $ \cs ->-    let (cIdsG, cs', aQS) = g cs-        (cIdsF, cs'', bQS) = f cs'+    let !(cIdsG, cs', aQS) = g cs+        !(cIdsF, cs'', bQS) = f cs'      in (cIdsG <> cIdsF, cs'', bQS . aQS) -instance Arrow QueryReader where-  arr f = QueryReader $ \cs -> (mempty, cs, arr f)-  first (QueryReader f) = QueryReader $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', first qS)+-- | @since 9.0+instance (Monad m) => Arrow (QueryReaderT m) where+  {-# INLINE arr #-}+  arr f = QueryReader (mempty,,arr f)+  {-# INLINE first #-}+  first (QueryReader f) = QueryReader $ \cs -> let !(cIds, comps', qS) = f cs in (cIds, comps', first qS) -instance ArrowChoice QueryReader where-  left (QueryReader f) = QueryReader $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', left qS)+-- | @since 9.0+instance (Monad m) => ArrowChoice (QueryReaderT m) where+  {-# INLINE left #-}+  left (QueryReader f) = QueryReader $ \cs -> let !(cIds, comps', qS) = f cs in (cIds, comps', left qS) -instance ArrowQueryReader QueryReader where-  fetch :: forall a. (Component a) => QueryReader () a+-- | @since 9.0+instance (Monad m) => ArrowQueryReader (QueryReaderT m) where+  {-# INLINE fetch #-}+  fetch :: forall a. (Component a) => QueryReaderT m () a   fetch = QueryReader $ \cs ->-    let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchDyn cId)-  fetchMaybe :: forall a. (Component a) => QueryReader () (Maybe a)+    let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchDyn cId)++  {-# INLINE fetchMaybe #-}+  fetchMaybe :: forall a. (Component a) => QueryReaderT m () (Maybe a)   fetchMaybe = QueryReader $ \cs ->-    let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchMaybeDyn cId)+    let !(cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchMaybeDyn cId) -instance ArrowDynamicQueryReader QueryReader where-  entity = QueryReader $ \cs -> (mempty, cs, entity)-  fetchDyn cId = QueryReader $ \cs -> (Set.singleton cId, cs, fetchDyn cId)-  fetchMaybeDyn cId = QueryReader $ \cs -> (Set.singleton cId, cs, fetchMaybeDyn cId)+-- | @since 9.0+instance (Monad m) => ArrowDynamicQueryReader (QueryReaderT m) where+  {-# INLINE entity #-}+  entity = QueryReader (mempty,,entity)+  {-# INLINE fetchDyn #-}+  fetchDyn cId = QueryReader (Set.singleton cId,,fetchDyn cId)+  {-# INLINE fetchMaybeDyn #-}+  fetchMaybeDyn cId = QueryReader (Set.singleton cId,,fetchMaybeDyn cId)  -- | Filter for a `Query`.-newtype QueryFilter = QueryFilter {runQueryFilter :: Components -> (DynamicQueryFilter, Components)}+--+-- @since 9.0+newtype QueryFilter = QueryFilter+  { -- | Run a query filter.+    runQueryFilter :: Components -> (DynamicQueryFilter, Components)+  } +-- | @since 9.0 instance Semigroup QueryFilter where   a <> b =     QueryFilter       ( \cs ->-          let (withA', cs') = runQueryFilter a cs-              (withB', cs'') = runQueryFilter b cs'+          let !(withA', cs') = runQueryFilter a cs+              !(withB', cs'') = runQueryFilter b cs'            in (withA' <> withB', cs'')       ) +-- | @since 9.0 instance Monoid QueryFilter where   mempty = QueryFilter (mempty,)  -- | Filter for entities containing this component.+--+-- @since 9.0 with :: forall a. (Component a) => QueryFilter with = QueryFilter $ \cs ->-  let (cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')+  let !(cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')  -- | Filter out entities containing this component.+--+-- @since 9.0 without :: forall a. (Component a) => QueryFilter without = QueryFilter $ \cs ->-  let (cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')+  let !(cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs') -all :: i -> QueryReader i a -> Entities -> ([a], Entities)-all i q es = let (as, cs) = all' i q es in (as, es {E.components = cs})+-- | Match all entities.+--+-- @since 9.0+{-# INLINE all #-}+all :: (Monad m) => i -> QueryReaderT m i a -> Entities -> (m [a], Entities)+all i q es = let !(as, cs) = all' i q es in (as, es {E.components = cs})  -- | Match all entities.-all' :: i -> QueryReader i a -> Entities -> ([a], Components)-all' i q es = let (rs, cs', dynQ) = runQueryReader q (E.components es) in (allDyn rs i dynQ es, cs')+--+-- @since 9.0+{-# INLINE all' #-}+all' :: (Monad m) => i -> QueryReaderT m i a -> Entities -> (m [a], Components)+all' i q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (allDyn rs i dynQ es, cs')++-- | Match a single entity.+--+-- @since 9.0+{-# INLINE single #-}+single :: (HasCallStack) => i -> QueryReader i a -> Entities -> (a, Entities)+single i q es = let !(a, cs) = single' i q es in (a, es {E.components = cs})++-- | Match a single entity.+--+-- @since 9.0+{-# INLINE single' #-}+single' :: (HasCallStack) => i -> QueryReader i a -> Entities -> (a, Components)+single' i q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleDyn rs i dynQ es, cs')++-- | Match a single entity.+--+-- @since 9.0+{-# INLINE singleMaybe #-}+singleMaybe :: i -> QueryReader i a -> Entities -> (Maybe a, Entities)+singleMaybe i q es = let !(a, cs) = singleMaybe' i q es in (a, es {E.components = cs})++-- | Match a single entity.+--+-- @since 9.0+{-# INLINE singleMaybe' #-}+singleMaybe' :: i -> QueryReader i a -> Entities -> (Maybe a, Components)+singleMaybe' i q es = let !(rs, cs', dynQ) = runQueryReader q (E.components es) in (singleMaybeDyn rs i dynQ es, cs')
src/Aztecs/ECS/Query/Reader/Class.hs view
@@ -1,13 +1,27 @@+-- |+-- 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 (ArrowQueryReader (..)) where  import Aztecs.ECS.Component-import Control.Arrow (Arrow (..), (>>>))+import Control.Arrow  -- | Arrow for queries that can read from entities.+--+-- @since 9.0 class (Arrow arr) => ArrowQueryReader arr where   -- | Fetch a `Component` by its type.+  --+  -- @since 9.0   fetch :: (Component a) => arr () a    -- | Fetch a `Component` by its type, returning `Nothing` if it doesn't exist.+  --+  -- @since 9.0   fetchMaybe :: (Component a) => arr () (Maybe a)   fetchMaybe = fetch >>> arr Just
− src/Aztecs/ECS/Schedule.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.Schedule-  ( -- * Schedules-    Schedule,-    ScheduleT (..),-    ArrowReaderSchedule (..),-    ArrowSchedule (..),-    ArrowAccessSchedule (..),-    fromReaderSchedule,-    delay,-    forever,-    forever_,-    runSchedule,-    runSchedule_,-  )-where--import Aztecs.ECS.Access (AccessT (..), runAccessT)-import Aztecs.ECS.Schedule.Access.Class-import Aztecs.ECS.Schedule.Class-import Aztecs.ECS.Schedule.Dynamic-import Aztecs.ECS.Schedule.Reader (ReaderScheduleT (..))-import Aztecs.ECS.Schedule.Reader.Class-import Aztecs.ECS.System-import Aztecs.ECS.System.Dynamic-import Aztecs.ECS.System.Reader (ReaderSystemT (..))-import qualified Aztecs.ECS.View as V-import Aztecs.ECS.World (World (..))-import qualified Aztecs.ECS.World as W-import Aztecs.ECS.World.Bundle (Bundle)-import Aztecs.ECS.World.Components (Components)-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Arrow-import Control.Category-import Control.DeepSeq-import Control.Exception-import Control.Monad.Fix-import Control.Monad.State (MonadState (..))-import Control.Monad.Trans (MonadTrans (..))-import Data.Functor-import Prelude hiding (id, (.))--type Schedule m = ScheduleT (AccessT m)--accessDyn :: (Monad m) => (i -> m o) -> DynamicScheduleT m i o-accessDyn f = DynamicSchedule $ \i -> do-  a <- f i-  return (a, accessDyn f)--delayDyn :: (Applicative m) => a -> DynamicScheduleT m a a-delayDyn d = DynamicSchedule $ \this -> pure (d, delayDyn this)---- | System schedule.-newtype ScheduleT m i o = Schedule {runSchedule' :: Components -> (DynamicScheduleT m i o, Components)}-  deriving (Functor)--instance (Monad m) => Category (ScheduleT m) where-  id = Schedule $ \cs -> (id, cs)-  Schedule f . Schedule g = Schedule $ \cs ->-    let (g', cs') = g cs-        (f', cs'') = f cs'-     in (f' . g', cs'')--instance (Monad m) => Arrow (ScheduleT m) where-  arr f = Schedule $ \cs -> (arr f, cs)-  first (Schedule f) = Schedule $ \cs -> let (f', cs') = f cs in (first f', cs')--instance (MonadFix m) => ArrowLoop (ScheduleT m) where-  loop (Schedule f) = Schedule $ \cs -> let (f', cs') = f cs in (loop f', cs')--instance (Monad m) => ArrowAccessSchedule Bundle (AccessT m) (Schedule m) where-  access f = Schedule $ \cs -> (accessDyn f, cs)--instance (Monad m) => ArrowReaderSchedule (ReaderSystemT m) (Schedule m) where-  reader = fromReaderSchedule . reader--instance (Monad m) => ArrowSchedule (SystemT m) (Schedule m) where-  system s = Schedule $ \cs ->-    let (dynS, _, cs') = runSystem s cs-        go dynSAcc i = AccessT $ do-          w <- get-          let (o, v, a, dynSAcc') = runSystemDyn dynSAcc (W.entities w) i-          ((), w') <- lift $ runAccessT a w {W.entities = V.unview v (W.entities w)}-          put w'-          return (o, DynamicSchedule $ go dynSAcc')-     in (DynamicSchedule $ go dynS, cs')--fromReaderSchedule :: (Monad m) => ReaderScheduleT m i o -> ScheduleT m i o-fromReaderSchedule s = Schedule $ \cs ->-  let (dynS, cs') = runReaderSchedule s cs in (fromDynReaderSchedule dynS, cs')--delay :: (Monad m) => a -> Schedule m a a-delay d = Schedule $ \cs -> (delayDyn d, cs)--runSchedule :: (Monad m) => Schedule m i o -> World -> i -> m (o, DynamicSchedule m i o, World)-runSchedule s w i = do-  let (f, cs) = runSchedule' s (components $ W.entities w)-  ((o, f'), w') <- runAccessT (runScheduleDyn f i) w {W.entities = (W.entities w) {components = cs}}-  return (o, f', w')--runSchedule_ :: (Monad m) => Schedule m () () -> m ()-runSchedule_ s = void (runSchedule s W.empty ())--forever :: Schedule IO i o -> (o -> IO ()) -> Schedule IO i ()-forever s f = Schedule $ \cs ->-  let (g, cs') = runSchedule' s cs-      go i = AccessT $ do-        w <- get-        let go' gAcc wAcc = do-              ((o, g'), wAcc') <- lift $ runAccessT (runScheduleDyn gAcc i) wAcc-              lift $ evaluate $ rnf wAcc'-              lift $ f o-              go' g' wAcc'-        go' g w-   in (DynamicSchedule go, cs')--forever_ :: Schedule IO i o -> Schedule IO i ()-forever_ s = forever s (const $ pure ())
− src/Aztecs/ECS/Schedule/Access.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.Schedule.Access (AcessSchedule (..), ArrowAccessSchedule (..)) where--import Aztecs.ECS.Access (AccessT (..))-import Aztecs.ECS.Schedule (ArrowAccessSchedule (..))-import Aztecs.ECS.World.Bundle (Bundle)-import Control.Arrow (Arrow (..))-import Control.Category (Category (..))-import Control.Monad ((>=>))--newtype AcessSchedule m i o = AcessSchedule {runAcessSchedule :: i -> AccessT m o}-  deriving (Functor)--instance (Monad m) => Category (AcessSchedule m) where-  id = AcessSchedule return-  AcessSchedule f . AcessSchedule g = AcessSchedule (g >=> f)--instance (Monad m) => Arrow (AcessSchedule m) where-  arr f = AcessSchedule $ \i -> return $ f i-  first (AcessSchedule f) = AcessSchedule $ \(b, d) -> do-    c <- f b-    return (c, d)--instance (Monad m) => ArrowAccessSchedule Bundle (AccessT m) (AcessSchedule m) where-  access = AcessSchedule
− src/Aztecs/ECS/Schedule/Access/Class.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}--module Aztecs.ECS.Schedule.Access.Class (ArrowAccessSchedule (..)) where--import Aztecs.ECS.Access (MonadAccess)-import Control.Arrow (Arrow (..))---- | Schedule arrow that provides access to a `World`.-class (MonadAccess b m, Arrow arr) => ArrowAccessSchedule b m arr | arr -> m where-  -- | Access the `World`.-  access :: (i -> m o) -> arr i o
− src/Aztecs/ECS/Schedule/Class.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}--module Aztecs.ECS.Schedule.Class (ArrowSchedule (..)) where--import Control.Arrow (Arrow (..))---- | Schedule arrow that runs systems.-class (Arrow arr) => ArrowSchedule s arr | arr -> s where-  -- | Schedule a system.-  system :: s i o -> arr i o
− src/Aztecs/ECS/Schedule/Dynamic.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecursiveDo #-}--module Aztecs.ECS.Schedule.Dynamic-  ( DynamicSchedule,-    DynamicScheduleT (..),-    fromDynReaderSchedule,-  )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Schedule.Dynamic.Reader (DynamicReaderScheduleT (..))-import Control.Arrow-import Control.Category-import Control.Monad.Fix-import Prelude hiding (id, (.))--type DynamicSchedule m = DynamicScheduleT (AccessT m)--newtype DynamicScheduleT m i o = DynamicSchedule {runScheduleDyn :: i -> m (o, DynamicScheduleT m i o)}-  deriving (Functor)--instance (Monad m) => Category (DynamicScheduleT m) where-  id = DynamicSchedule $ \i -> pure (i, id)-  DynamicSchedule f . DynamicSchedule g = DynamicSchedule $ \i -> do-    (b, g') <- g i-    (c, f') <- f b-    return (c, f' . g')--instance (Monad m) => Arrow (DynamicScheduleT m) where-  arr f = DynamicSchedule $ \i -> pure (f i, arr f)-  first (DynamicSchedule f) = DynamicSchedule $ \(b, d) -> do-    (c, f') <- f b-    return ((c, d), first f')--instance (Monad m) => ArrowChoice (DynamicScheduleT m) where-  left (DynamicSchedule f) = DynamicSchedule $ \i -> case i of-    Left b -> do-      (c, f') <- f b-      return (Left c, left f')-    Right d -> return (Right d, left (DynamicSchedule f))--instance (MonadFix m) => ArrowLoop (DynamicScheduleT m) where-  loop (DynamicSchedule f) = DynamicSchedule $ \b -> do-    rec ((c, d), f') <- f (b, d)-    return (c, loop f')--fromDynReaderSchedule :: (Monad m) => DynamicReaderScheduleT m i o -> DynamicScheduleT m i o-fromDynReaderSchedule (DynamicReaderSchedule f) = DynamicSchedule $ \i -> do-  (o, f') <- f i-  return (o, fromDynReaderSchedule f')
− src/Aztecs/ECS/Schedule/Dynamic/Reader.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE TypeFamilies #-}--module Aztecs.ECS.Schedule.Dynamic.Reader-  ( DynamicReaderSchedule,-    DynamicReaderScheduleT (..),-  )-where--import Aztecs.ECS.Access-import Control.Arrow-import Control.Category-import Control.Monad.Fix-import Prelude hiding (all, any, id, lookup, reads, (.))--type DynamicReaderSchedule m = DynamicReaderScheduleT (AccessT m)--newtype DynamicReaderScheduleT m i o = DynamicReaderSchedule {runScheduleDyn :: i -> m (o, DynamicReaderScheduleT m i o)}-  deriving (Functor)--instance (Monad m) => Category (DynamicReaderScheduleT m) where-  id = DynamicReaderSchedule $ \i -> pure (i, id)-  DynamicReaderSchedule f . DynamicReaderSchedule g = DynamicReaderSchedule $ \i -> do-    (b, g') <- g i-    (c, f') <- f b-    return (c, f' . g')--instance (Monad m) => Arrow (DynamicReaderScheduleT m) where-  arr f = DynamicReaderSchedule $ \i -> pure (f i, arr f)-  first (DynamicReaderSchedule f) = DynamicReaderSchedule $ \(b, d) -> do-    (c, f') <- f b-    return ((c, d), first f')--instance (Monad m) => ArrowChoice (DynamicReaderScheduleT m) where-  left (DynamicReaderSchedule f) = DynamicReaderSchedule $ \i -> case i of-    Left b -> do-      (c, f') <- f b-      return (Left c, left f')-    Right d -> return (Right d, left (DynamicReaderSchedule f))--instance (MonadFix m) => ArrowLoop (DynamicReaderScheduleT m) where-  loop (DynamicReaderSchedule f) = DynamicReaderSchedule $ \b -> do-    rec ((c, d), f') <- f (b, d)-    return (c, loop f')
− src/Aztecs/ECS/Schedule/Reader.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.Schedule.Reader-  ( ReaderScheduleT (..),-  )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Schedule.Dynamic.Reader-import Aztecs.ECS.Schedule.Reader.Class-import Aztecs.ECS.System.Dynamic.Reader-import Aztecs.ECS.System.Reader-import Aztecs.ECS.World (World (..))-import Aztecs.ECS.World.Components (Components)-import Control.Arrow-import Control.Category-import Control.Monad.Fix-import Control.Monad.State (MonadState (..))-import Control.Monad.Trans-import Prelude hiding (id, (.))--type ReaderSchedule m = ReaderScheduleT (AccessT m)--newtype ReaderScheduleT m i o-  = ReaderSchedule {runReaderSchedule :: Components -> (DynamicReaderScheduleT m i o, Components)}-  deriving (Functor)--instance (Monad m) => Category (ReaderScheduleT m) where-  id = ReaderSchedule $ \cs -> (id, cs)-  ReaderSchedule f . ReaderSchedule g = ReaderSchedule $ \cs ->-    let (g', cs') = g cs-        (f', cs'') = f cs'-     in (f' . g', cs'')--instance (Monad m) => Arrow (ReaderScheduleT m) where-  arr f = ReaderSchedule $ \cs -> (arr f, cs)-  first (ReaderSchedule f) = ReaderSchedule $ \cs -> let (f', cs') = f cs in (first f', cs')--instance (Monad m) => ArrowChoice (ReaderScheduleT m) where-  left (ReaderSchedule f) = ReaderSchedule $ \cs -> let (f', cs') = f cs in (left f', cs')--instance (MonadFix m) => ArrowLoop (ReaderScheduleT m) where-  loop (ReaderSchedule f) = ReaderSchedule $ \cs -> let (f', cs') = f cs in (loop f', cs')--instance (Monad m) => ArrowReaderSchedule (ReaderSystemT m) (ReaderSchedule m) where-  reader s = ReaderSchedule $ \cs ->-    let (dynS, _, cs') = runReaderSystem s cs-        go dynSAcc i = AccessT $ do-          w <- get-          let (o, a, dynSAcc') = runReaderSystemDyn dynSAcc (entities w) i-          ((), w') <- lift $ runAccessT a w-          put w'-          return (o, DynamicReaderSchedule $ go dynSAcc')-     in (DynamicReaderSchedule $ go dynS, cs')
− src/Aztecs/ECS/Schedule/Reader/Class.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}--module Aztecs.ECS.Schedule.Reader.Class (ArrowReaderSchedule (..)) where--import Control.Arrow (Arrow (..))---- | Schedule arrow that runs read-only systems.-class (Arrow arr) => ArrowReaderSchedule s arr | arr -> s where-  -- | Schedule a reader system.-  reader :: s i o -> arr i o
src/Aztecs/ECS/System.hs view
@@ -1,93 +1,163 @@ {-# 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 (..),-    ArrowReaderSystem (..),-    ArrowSystem (..),-    ArrowQueueSystem (..),-    fromReader,+    MonadReaderSystem (..),+    MonadSystem (..),+    MonadDynamicReaderSystem (..),+    MonadDynamicSystem (..),   ) where -import Aztecs.ECS.Access-import Aztecs.ECS.Query (Query (..), QueryFilter (..), ReadsWrites (..))+import Aztecs.ECS.Component+import Aztecs.ECS.Query import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Reader (DynamicQueryFilter (..), QueryReader (..))+import Aztecs.ECS.Query.Dynamic (DynamicQueryT)+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReaderT, runDynQueryReaderT)+import Aztecs.ECS.Query.Reader import Aztecs.ECS.System.Class-import Aztecs.ECS.System.Dynamic-import Aztecs.ECS.System.Reader+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.Bundle-import Aztecs.ECS.World.Components (Components)-import Control.Arrow+import Aztecs.ECS.World.Entities (Entities (..)) import Control.Category+import Control.Concurrent.STM import Control.Monad.Identity+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, (.))-import qualified Prelude hiding (filter, id, map) -type System = SystemT Identity+-- | @since 9.0+type System = SystemT STM --- | System to process entities.-newtype SystemT m i o = System-  { -- | Run a system, producing a `DynamicSystem` that can be repeatedly run.-    runSystem :: Components -> (DynamicSystemT m i o, ReadsWrites, Components)+-- | System to process queries in parallel.+--+-- @since 9.0+newtype SystemT m a = SystemT+  { -- | Run a system on a collection of `Entities`.+    --+    -- @since 9.0+    runSystemT :: ReaderT (TVar Entities) m a   }-  deriving (Functor)--instance (Monad m) => Category (SystemT m) where-  id = System $ \cs -> (DynamicSystem $ \_ i -> (i, mempty, pure (), id), mempty, cs)-  System f . System g = System $ \cs ->-    let (f', rwsF, cs') = f cs-        (g', rwsG, cs'') = g cs'-     in (f' . g', rwsF <> rwsG, cs'')--instance (Monad m) => Arrow (SystemT m) where-  arr f = System $ \cs -> (DynamicSystem $ \_ i -> (f i, mempty, pure (), arr f), mempty, cs)-  first (System f) = System $ \cs ->-    let (f', rwsF, cs') = f cs in (first f', rwsF, cs')-  f &&& g = System $ \cs ->-    let (dynF, rwsA, cs') = runSystem f cs-        (dynG, rwsB, cs'') = runSystem g cs'-        dynS = if Q.disjoint rwsA rwsB then dynF &&& dynG else raceDyn dynF dynG-     in (dynS, rwsA <> rwsB, cs'')+  deriving (Functor, Applicative, Monad, MonadFix) -instance (Monad m) => ArrowChoice (SystemT m) where-  left (System f) = System $ \cs -> let (f', rwsF, cs') = f cs in (left f', rwsF, cs')+-- | @since 9.0+instance MonadDynamicSystem (DynamicQueryT STM) System where+  mapDyn i cIds q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.view cIds $ archetypes w+    (o, v') <- lift $ V.mapDyn i q v+    lift . modifyTVar wVar $ V.unview v'+    return o+  mapSingleMaybeDyn i 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 i q v+        lift . modifyTVar wVar $ V.unview v'+        return o+      Nothing -> return Nothing+  filterMapDyn i cIds f q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.filterView cIds f $ archetypes w+    (o, v') <- lift $ V.mapDyn i q v+    lift . modifyTVar wVar $ V.unview v'+    return o -instance (Monad m) => ArrowLoop (SystemT m) where-  loop (System f) = System $ \cs -> let (f', rwsF, cs') = f cs in (loop f', rwsF, cs')+-- | @since 9.0+instance MonadSystem (QueryT STM) System where+  map i q = SystemT $ do+    (rws, dynQ) <- runSystemT $ fromQuery q+    runSystemT $ mapDyn i (Q.reads rws <> Q.writes rws) dynQ+  mapSingleMaybe i q = SystemT $ do+    (rws, dynQ) <- runSystemT $ fromQuery q+    runSystemT $ mapSingleMaybeDyn i (Q.reads rws <> Q.writes rws) dynQ+  filterMap i 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 i (Q.reads rws <> Q.writes rws) f' dynQ -instance (Monad m) => ArrowReaderSystem QueryReader (SystemT m) where-  all = fromReader . all-  filter q = fromReader . filter q+-- | @since 9.0+instance MonadReaderSystem (QueryReaderT STM) System where+  all i q = SystemT $ do+    (cIds, dynQ) <- runSystemT $ fromQueryReader q+    runSystemT $ allDyn i cIds dynQ+  filter i 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 i cIds dynQ f' -instance (Monad m) => ArrowSystem Query (SystemT m) where-  map q = System $ \cs ->-    let !(rws, cs', dynQ) = runQuery q cs-     in (mapDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')-  filterMap q qf = System $ \cs ->-    let !(rws, cs', dynQ) = runQuery q cs-        !(dynQf, cs'') = runQueryFilter qf cs'-        f' n =-          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)-            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)-     in (filterMapDyn (Q.reads rws <> Q.writes rws) dynQ f', rws, cs'')-  mapSingle q = System $ \cs ->-    let !(rws, cs', dynQ) = runQuery q cs-     in (mapSingleDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')-  mapSingleMaybe q = System $ \cs ->-    let !(rws, cs', dynQ) = runQuery q cs-     in (mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')+-- | @since 9.0+instance MonadDynamicReaderSystem (DynamicQueryReaderT STM) System where+  allDyn i cIds q = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.view cIds $ archetypes w+    lift $+      if V.null v+        then runDynQueryReaderT i q A.empty {A.entities = Map.keysSet $ entities w}+        else V.allDyn i q v+  filterDyn i cIds q f = SystemT $ do+    wVar <- ask+    w <- lift $ readTVar wVar+    let !v = V.filterView cIds f $ archetypes w+    lift $ V.allDyn i q v -instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (SystemT m) where-  queue f = System $ \cs -> (queue f, mempty, cs)+-- | Convert a `QueryReaderT` to a `System`.+--+-- @since 9.0+fromQueryReader :: QueryReaderT STM i o -> System (Set ComponentID, DynamicQueryReaderT STM i o)+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 -fromReader :: (Monad m) => ReaderSystemT m i o -> SystemT m i o-fromReader (ReaderSystem f) = System $ \cs ->-  let (f', rs, cs') = f cs in (fromDynReaderSystem f', ReadsWrites rs mempty, cs')+-- | Convert a `QueryT` to a `System`.+--+-- @since 9.0+fromQuery :: QueryT STM i o -> System (ReadsWrites, DynamicQueryT STM i o)+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
@@ -1,24 +1,44 @@ {-# LANGUAGE FunctionalDependencies #-} -module Aztecs.ECS.System.Class (ArrowSystem (..)) where+-- |+-- 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 Control.Arrow (Arrow (..), (>>>))+import GHC.Stack import Prelude hiding (map) -class (Arrow arr) => ArrowSystem q arr | arr -> q where-  -- | Query and update all matching entities.-  map :: q i a -> arr i [a]--  -- | Query and update all matching entities, ignoring the results.-  map_ :: q i o -> arr i ()-  map_ q = map q >>> arr (const ())+-- | Monadic system.+--+-- @since 9.0+class (Monad m) => MonadSystem q m | m -> q where+  -- | Map all matching entities with a query.+  --+  -- @since 9.0+  map :: i -> q i o -> m [o] -  -- | Map all matching entities with a `QueryFilter`, storing the updated entities.-  filterMap :: q i a -> QueryFilter -> arr i [a]+  -- | Map a single matching entity with a query, or @Nothing@.+  --+  -- @since 9.0+  mapSingleMaybe :: i -> q i o -> m (Maybe o) -  -- | Map a single matching entity, storing the updated components.-  -- If there are zero or multiple matching entities, an error will be thrown.-  mapSingle :: q i a -> arr i a+  -- | Map a single matching entity with a query.+  --+  -- @since 9.0+  mapSingle :: (HasCallStack) => i -> q i o -> m o+  mapSingle i q = do+    res <- mapSingleMaybe i q+    case res of+      Just a -> return a+      Nothing -> error "Expected a single matching entity." -  mapSingleMaybe :: q i a -> arr i (Maybe a)+  -- | Map all matching entities with a query and filter.+  --+  -- @since 9.0+  filterMap :: i -> q i o -> QueryFilter -> m [o]
− src/Aztecs/ECS/System/Dynamic.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.System.Dynamic-  ( DynamicSystem,-    DynamicSystemT (..),-    ArrowDynamicReaderSystem (..),-    ArrowDynamicSystem (..),-    ArrowQueueSystem (..),-    raceDyn,-    fromDynReaderSystem,-  )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))-import Aztecs.ECS.System.Dynamic.Class-import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystemT (..))-import Aztecs.ECS.System.Dynamic.Reader.Class-import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))-import Aztecs.ECS.View (View)-import qualified Aztecs.ECS.View as V-import Aztecs.ECS.World.Bundle-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Arrow-import Control.Category-import Control.Monad.Identity-import Control.Parallel (par)-import Data.Maybe (fromMaybe)-import Prelude hiding (id, (.))--type DynamicSystem = DynamicSystemT Identity--newtype DynamicSystemT m i o = DynamicSystem-  { -- | Run a dynamic system,-    -- producing some output, an updated `View` into the `World`, and any queued `Access`.-    runSystemDyn :: Entities -> i -> (o, View, AccessT m (), DynamicSystemT m i o)-  }-  deriving (Functor)--instance (Monad m) => Category (DynamicSystemT m) where-  id = DynamicSystem $ \_ i -> (i, mempty, pure (), id)-  DynamicSystem f . DynamicSystem g = DynamicSystem $ \w i ->-    let (b, gView, gAccess, g') = g w i-        (a, fView, fAccess, f') = f w b-     in (a, gView <> fView, gAccess >> fAccess, f' . g')--instance (Monad m) => Arrow (DynamicSystemT m) where-  arr f = DynamicSystem $ \_ i -> (f i, mempty, pure (), arr f)-  first (DynamicSystem f) = DynamicSystem $ \w (i, x) ->-    let (a, v, access, f') = f w i in ((a, x), v, access, first f')--instance (Monad m) => ArrowChoice (DynamicSystemT m) where-  left (DynamicSystem f) = DynamicSystem $ \w i -> case i of-    Left b -> let (c, v, access, f') = f w b in (Left c, v, access, left f')-    Right d -> (Right d, mempty, pure (), left (DynamicSystem f))--instance (Monad m) => ArrowLoop (DynamicSystemT m) where-  loop (DynamicSystem f) = DynamicSystem $ \w b ->-    let ((c, d), v, access, f') = f w (b, d) in (c, v, access, loop f')--instance (Monad m) => ArrowDynamicReaderSystem DynamicQueryReader (DynamicSystemT m) where-  allDyn cIds q = fromDynReaderSystem $ allDyn cIds q-  filterDyn cIds qf q = fromDynReaderSystem $ filterDyn cIds qf q--instance (Monad m) => ArrowDynamicSystem DynamicQuery (DynamicSystemT m) where-  mapDyn cIds q = DynamicSystem $ \w i ->-    let !v = V.view cIds $ archetypes w-        (o, v') = V.allDyn i q v-     in (o, v', pure (), mapDyn cIds q)-  mapSingleDyn cIds q = DynamicSystem $ \w i ->-    let s =-          mapSingleMaybeDyn cIds q-            >>> arr (fromMaybe (error "Expected a single matching entity."))-     in runSystemDyn s w i-  mapSingleMaybeDyn cIds q = DynamicSystem $ \w i ->-    let !res = V.viewSingle cIds $ archetypes w-        (res', v'') = case res of-          Just v -> let (o, v') = V.singleDyn i q v in (o, v')-          Nothing -> (Nothing, mempty)-     in (res', v'', pure (), mapSingleMaybeDyn cIds q)-  filterMapDyn cIds q f = DynamicSystem $ \w i ->-    let !v = V.filterView cIds f $ archetypes w-        (o, v') = V.allDyn i q v-     in (o, v', pure (), filterMapDyn cIds q f)--instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (DynamicSystemT m) where-  queue f = DynamicSystem $ \_ i -> ((), mempty, f i, queue f)--raceDyn :: (Monad m) => DynamicSystemT m i a -> DynamicSystemT m i b -> DynamicSystemT m i (a, b)-raceDyn (DynamicSystem f) (DynamicSystem g) = DynamicSystem $ \w i ->-  let fa = f w i-      gb = g w i-      gbPar = fa `par` gb-      (a, v, fAccess, f') = fa-      (b, v', gAccess, g') = gbPar-   in ((a, b), v <> v', fAccess >> gAccess, raceDyn f' g')--fromDynReaderSystem :: DynamicReaderSystemT m i o -> DynamicSystemT m i o-fromDynReaderSystem (DynamicReaderSystem f) = DynamicSystem $ \w i ->-  let (o, access, f') = f w i in (o, mempty, access, fromDynReaderSystem f')
src/Aztecs/ECS/System/Dynamic/Class.hs view
@@ -1,21 +1,43 @@ {-# LANGUAGE FunctionalDependencies #-} -module Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..)) where+-- |+-- Module      : Aztecs.ECS.System.Dynamic.Class+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions)+module Aztecs.ECS.System.Dynamic.Class (MonadDynamicSystem (..)) where  import Aztecs.ECS.Component (ComponentID) import Aztecs.ECS.World.Archetypes (Node (..)) import Data.Set (Set)+import GHC.Stack -class ArrowDynamicSystem q arr | arr -> q where-  -- | Map all matching entities, storing the updated entities.-  mapDyn :: Set ComponentID -> q i o -> arr i [o]+-- | Monadic dynamic system.+--+-- @since 9.0+class (Monad m) => MonadDynamicSystem q m | m -> q where+  -- | Map all matching entities with a query.+  --+  -- @since 9.0+  mapDyn :: i -> Set ComponentID -> q i o -> m [o] -  mapSingleDyn :: Set ComponentID -> q i o -> arr i o+  -- | Map a single matching entity with a query, or @Nothing@.+  --+  -- @since 9.0+  mapSingleMaybeDyn :: i -> Set ComponentID -> q i a -> m (Maybe a) -  mapSingleMaybeDyn :: Set ComponentID -> q i o -> arr i (Maybe o)+  -- | Map a single matching entity with a query.+  mapSingleDyn :: (HasCallStack) => i -> Set ComponentID -> q i o -> m o+  mapSingleDyn i cIds q = do+    res <- mapSingleMaybeDyn i cIds q+    case res of+      Just a -> return a+      Nothing -> error "Expected a single matching entity." -  filterMapDyn ::-    Set ComponentID ->-    q i o ->-    (Node -> Bool) ->-    arr i [o]+  -- | Map all matching entities with a query and filter.+  --+  -- @since 9.0+  filterMapDyn :: i -> Set ComponentID -> (Node -> Bool) -> q i a -> m [a]
− src/Aztecs/ECS/System/Dynamic/Reader.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.System.Dynamic.Reader-  ( DynamicReaderSystem,-    DynamicReaderSystemT (..),-    ArrowDynamicReaderSystem (..),-    ArrowQueueSystem (..),-    raceDyn,-  )-where--import Aztecs.ECS.Access-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..), runDynQueryReader)-import Aztecs.ECS.System.Dynamic.Reader.Class-import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))-import qualified Aztecs.ECS.View as V-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Bundle-import Aztecs.ECS.World.Entities (Entities (..))-import Control.Arrow-import Control.Category-import Control.Monad.Identity-import Control.Parallel (par)-import qualified Data.Map as Map-import Prelude hiding (id, (.))--type DynamicReaderSystem = DynamicReaderSystemT Identity--newtype DynamicReaderSystemT m i o = DynamicReaderSystem-  { -- | Run a dynamic system producing some output-    runReaderSystemDyn :: Entities -> i -> (o, AccessT m (), DynamicReaderSystemT m i o)-  }-  deriving (Functor)--instance (Monad m) => Category (DynamicReaderSystemT m) where-  id = DynamicReaderSystem $ \_ i -> (i, pure (), id)-  DynamicReaderSystem f . DynamicReaderSystem g = DynamicReaderSystem $ \w i ->-    let (b, gAccess, g') = g w i-        (c, fAccess, f') = f w b-     in (c, gAccess >> fAccess, f' . g')--instance (Monad m) => Arrow (DynamicReaderSystemT m) where-  arr f = DynamicReaderSystem $ \_ i -> (f i, pure (), arr f)-  first (DynamicReaderSystem f) = DynamicReaderSystem $ \w (i, x) ->-    let (a, access, f') = f w i in ((a, x), access, first f')--instance (Monad m) => ArrowChoice (DynamicReaderSystemT m) where-  left (DynamicReaderSystem f) = DynamicReaderSystem $ \w i -> case i of-    Left b -> let (c, access, f') = f w b in (Left c, access, left f')-    Right d -> (Right d, pure (), left (DynamicReaderSystem f))--instance (Monad m) => ArrowLoop (DynamicReaderSystemT m) where-  loop (DynamicReaderSystem f) = DynamicReaderSystem $ \w b ->-    let ((c, d), access, f') = f w (b, d) in (c, access, loop f')--instance (Monad m) => ArrowDynamicReaderSystem DynamicQueryReader (DynamicReaderSystemT m) where-  allDyn cIds q = DynamicReaderSystem $ \w i ->-    let !v = V.view cIds $ archetypes w-     in if V.null v-          then (runDynQueryReader i q (Map.keys $ entities w) A.empty, pure (), allDyn cIds q)-          else (V.readAllDyn i q v, pure (), allDyn cIds q)-  filterDyn cIds q f = DynamicReaderSystem $ \w i ->-    let !v = V.filterView cIds f $ archetypes w-     in (V.readAllDyn i q v, pure (), filterDyn cIds q f)--instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (DynamicReaderSystemT m) where-  queue f = DynamicReaderSystem $ \_ i -> let !a = f i in ((), a, queue f)--raceDyn :: (Monad m) => DynamicReaderSystemT m i a -> DynamicReaderSystemT m i b -> DynamicReaderSystemT m i (a, b)-raceDyn (DynamicReaderSystem f) (DynamicReaderSystem g) = DynamicReaderSystem $ \w i ->-  let fa = f w i-      gb = g w i-      gbPar = fa `par` gb-      (a, fAccess, f') = fa-      (b, gAccess, g') = gbPar-   in ((a, b), fAccess >> gAccess, raceDyn f' g')
src/Aztecs/ECS/System/Dynamic/Reader/Class.hs view
@@ -1,22 +1,50 @@ {-# LANGUAGE FunctionalDependencies #-} -module Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..)) where+-- |+-- 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 (ComponentID)+import Aztecs.ECS.Component import Aztecs.ECS.World.Archetypes (Node)-import Control.Arrow (Arrow (..), (>>>)) import Data.Set (Set)+import GHC.Stack -class (Arrow arr) => ArrowDynamicReaderSystem q arr | arr -> q where-  allDyn :: Set ComponentID -> q i o -> arr i [o]+-- | Monadic dynamic reader system.+--+-- @since 9.0+class (Monad m) => MonadDynamicReaderSystem q m | m -> q where+  -- | Match all entities with a query.+  --+  -- @since 9.0+  allDyn :: i -> Set ComponentID -> q i o -> m [o] -  filterDyn :: Set ComponentID -> q i o -> (Node -> Bool) -> arr i [o]+  -- | Match a single entity with a query.+  --+  -- @since 9.0+  singleDyn :: (HasCallStack) => i -> Set ComponentID -> q i o -> m o+  singleDyn i cIds q = do+    os <- allDyn i cIds q+    case os of+      [o] -> return o+      _ -> error "singleDyn: expected a single result, but got multiple" -  singleDyn :: Set ComponentID -> q () a -> arr () a-  singleDyn cIds q =-    allDyn cIds q-      >>> arr-        ( \as -> case as of-            [a] -> a-            _ -> error "TODO"-        )+  -- | Match a single entity with a query, or Nothing.+  --+  -- @since 9.0+  singleMaybeDyn :: i -> Set ComponentID -> q i o -> m (Maybe o)+  singleMaybeDyn i cIds q = do+    os <- allDyn i cIds q+    return $ case os of+      [o] -> Just o+      _ -> Nothing++  -- | Match all entities with a query and filter.+  --+  -- @since 9.0+  filterDyn :: i -> Set ComponentID -> q i a -> (Node -> Bool) -> m [a]
− src/Aztecs/ECS/System/Queue.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.System.Queue (QueueSystem (..), ArrowQueueSystem (..)) where--import Aztecs.ECS.Access (Access)-import Aztecs.ECS.System.Queue.Class (ArrowQueueSystem (..))-import Aztecs.ECS.World.Bundle (Bundle)-import Control.Arrow (Arrow (..))-import Control.Category (Category (..))---- | System that can queue `Access` to a `World`.-newtype QueueSystem i o = QueueSystem {runQueueSystem :: i -> (o, Access ())}-  deriving (Functor)--instance Category QueueSystem where-  id = QueueSystem $ \i -> (i, pure ())-  QueueSystem f . QueueSystem g = QueueSystem $ \i ->-    let (b, access) = g i-        (c, access') = f b-     in (c, access >> access')--instance Arrow QueueSystem where-  arr f = QueueSystem $ \i -> (f i, pure ())-  first (QueueSystem f) = QueueSystem $ \(b, d) ->-    let (c, access) = f b in ((c, d), access)--instance ArrowQueueSystem Bundle Access QueueSystem where-  queue f = QueueSystem $ \i -> let !a = f i in ((), a)
− src/Aztecs/ECS/System/Queue/Class.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}--module Aztecs.ECS.System.Queue.Class (ArrowQueueSystem (..)) where--import Aztecs.ECS.Access (MonadAccess)-import Control.Arrow (Arrow (..))--class (MonadAccess b m, Arrow arr) => ArrowQueueSystem b m arr | arr -> m where-  -- | Queue an `Access` to happen after this system schedule.-  queue :: (i -> m ()) -> arr i ()
− src/Aztecs/ECS/System/Reader.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.ECS.System.Reader-  ( ReaderSystem,-    ReaderSystemT (..),-    ArrowReaderSystem (..),-    ArrowQueueSystem (..),-  )-where--import Aztecs.ECS.Access (AccessT)-import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System.Dynamic.Reader-import Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..))-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (Node (..))-import Aztecs.ECS.World.Bundle (Bundle)-import Aztecs.ECS.World.Components (ComponentID, Components)-import Control.Arrow-import Control.Category-import Control.Monad.Identity-import qualified Data.Foldable as F-import Data.Set (Set)-import Prelude hiding (id, (.))--type ReaderSystem = ReaderSystemT Identity---- | System to process entities.-newtype ReaderSystemT m i o = ReaderSystem-  { -- | Run a system, producing a `DynamicSystem` that can be repeatedly run.-    runReaderSystem :: Components -> (DynamicReaderSystemT m i o, Set ComponentID, Components)-  }-  deriving (Functor)--instance (Monad m) => Category (ReaderSystemT m) where-  id = ReaderSystem $ \cs -> (id, mempty, cs)-  ReaderSystem f . ReaderSystem g = ReaderSystem $ \cs ->-    let (f', rwsF, cs') = f cs-        (g', rwsG, cs'') = g cs'-     in (f' . g', rwsF <> rwsG, cs'')--instance (Monad m) => Arrow (ReaderSystemT m) where-  arr f = ReaderSystem $ \cs -> (arr f, mempty, cs)-  first (ReaderSystem f) = ReaderSystem $ \cs ->-    let (f', rwsF, cs') = f cs in (first f', rwsF, cs')-  f &&& g = ReaderSystem $ \cs ->-    let (dynF, rwsA, cs') = runReaderSystem f cs-        (dynG, rwsB, cs'') = runReaderSystem g cs'-     in (raceDyn dynF dynG, rwsA <> rwsB, cs'')--instance (Monad m) => ArrowChoice (ReaderSystemT m) where-  left (ReaderSystem f) = ReaderSystem $ \cs -> let (f', rwsF, cs') = f cs in (left f', rwsF, cs')--instance (Monad m) => ArrowLoop (ReaderSystemT m) where-  loop (ReaderSystem f) = ReaderSystem $ \cs -> let (f', rwsF, cs') = f cs in (loop f', rwsF, cs')--instance (Monad m) => ArrowReaderSystem QueryReader (ReaderSystemT m) where-  all q = ReaderSystem $ \cs ->-    let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, rs, cs')-  filter q qf = ReaderSystem $ \cs ->-    let !(rs, cs', dynQ) = runQueryReader q cs-        !(dynQf, cs'') = runQueryFilter qf cs'-        qf' n =-          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)-            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)-     in (filterDyn rs dynQ qf', rs, cs'')--instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (ReaderSystemT m) where-  queue f = ReaderSystem $ \cs -> (queue f, mempty, cs)
src/Aztecs/ECS/System/Reader/Class.hs view
@@ -1,26 +1,49 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FunctionalDependencies #-} -module Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..)) where+-- |+-- 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 Control.Arrow (Arrow (..), (>>>))-import Prelude hiding (all, any, filter, id, lookup, map, mapM, reads, (.))+import GHC.Stack+import Prelude hiding (all) -class (Arrow arr) => ArrowReaderSystem q arr | arr -> q where-  -- | Query all matching entities.-  all :: q i a -> arr i [a]+-- | Monadic reader system.+--+-- @since 9.0+class (Monad m) => MonadReaderSystem q m | m -> q where+  -- | Match all entities with a query.+  --+  -- @since 9.0+  all :: i -> q i o -> m [o] -  -- | Query all matching entities with a `QueryFilter`.-  filter :: q () a -> QueryFilter -> arr () [a]+  -- | Match a single entity with a query.+  --+  -- @since 9.0+  single :: (HasCallStack) => i -> q i o -> m o+  single i q = do+    os <- all i q+    case os of+      [o] -> return o+      _ -> error "single: expected a single result" -  -- | Query a single matching entity.-  -- If there are zero or multiple matching entities, an error will be thrown.-  single :: q i a -> arr i a-  single q =-    all q-      >>> arr-        ( \as -> case as of-            [a] -> a-            _ -> error "TODO"-        )+  -- | Match a single entity with a query, or @Nothing@.+  --+  -- @since 9.0+  singleMaybe :: i -> q i o -> m (Maybe o)+  singleMaybe i q = do+    os <- all i q+    return $ case os of+      [o] -> Just o+      _ -> Nothing++  -- | Match all entities with a query and filter.+  --+  -- @since 9.0+  filter :: i -> q i o -> QueryFilter -> m [o]
src/Aztecs/ECS/View.hs view
@@ -3,6 +3,14 @@ {-# 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,@@ -12,39 +20,52 @@     unview,     allDyn,     singleDyn,-    readAllDyn,+    mapDyn,+    mapSingleDyn,   ) where -import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..), runDynQueryReader)-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..))+import Aztecs.ECS.Query.Dynamic (DynamicQueryT (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReaderT (..), runDynQueryReaderT)+import Aztecs.ECS.World.Archetypes import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Components (ComponentID)+import Aztecs.ECS.World.Components import Aztecs.ECS.World.Entities (Entities) import qualified Aztecs.ECS.World.Entities as E-import Data.Foldable (foldl')+import Data.Foldable (foldl', foldlM) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set)-import qualified Data.Set as Set import Prelude hiding (null)  -- | View into a `World`, containing a subset of archetypes.-newtype View = View {viewArchetypes :: Map ArchetypeID Node}+--+-- @since 9.0+newtype View = View+  { -- | Archetypes contained in this view.+    --+    -- @since 9.0+    viewArchetypes :: Map ArchetypeID Node+  }   deriving (Show, Semigroup, Monoid)  -- | View into all archetypes containing the provided component IDs.+--+-- @since 9.0 view :: Set ComponentID -> Archetypes -> View view cIds as = View $ AS.find cIds as +-- | View into a single archetype containing the provided component IDs.+--+-- @since 9.0 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 9.0 filterView ::   Set ComponentID ->   (Node -> Bool) ->@@ -52,10 +73,15 @@   View filterView cIds f as = View $ Map.filter f (AS.find cIds as) +-- | @True@ if the `View` is empty.+--+-- @since 9.0 null :: View -> Bool null = Map.null . viewArchetypes  -- | "Un-view" a `View` back into a `World`.+--+-- @since 9.0 unview :: View -> Entities -> Entities unview v es =   es@@ -67,31 +93,49 @@     }  -- | Query all matching entities in a `View`.-allDyn :: i -> DynamicQuery i a -> View -> ([a], View)+--+-- @since 9.0+allDyn :: (Monad m) => i -> DynamicQueryReaderT m i a -> View -> m [a] allDyn i q v =-  let (as, arches) =-        foldl'-          ( \(acc, archAcc) (aId, n) ->-              let (as', arch') = runDynQuery q (repeat i) (Set.toList . A.entities $ nodeArchetype n) (nodeArchetype n)-               in (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)-          )-          ([], Map.empty)-          (Map.toList $ viewArchetypes v)-   in (as, View arches)---- | Query all matching entities in a `View`.-singleDyn :: i -> DynamicQuery i a -> View -> (Maybe a, View)-singleDyn i q v = case allDyn i q v of-  -- TODO [a], removing this errors for now-  (a : _, v') -> (Just a, v')-  _ -> (Nothing, v)---- | Query all matching entities in a `View`.-readAllDyn :: i -> DynamicQueryReader i a -> View -> [a]-readAllDyn i q v =-  foldl'-    ( \acc n ->-        runDynQueryReader i q (Set.toList . A.entities $ nodeArchetype n) (nodeArchetype n) ++ acc+  foldlM+    ( \acc n -> do+        as <- runDynQueryReaderT i q $ nodeArchetype n+        return $ as ++ acc     )     []     (viewArchetypes v)++-- | Query all matching entities in a `View`.+--+-- @since 9.0+singleDyn :: (Monad m) => i -> DynamicQueryReaderT m i a -> View -> m (Maybe a)+singleDyn i q v = do+  as <- allDyn i q v+  return $ case as of+    [a] -> Just a+    _ -> Nothing++-- | Map all matching entities in a `View`.+--+-- @since 9.0+mapDyn :: (Monad m) => i -> DynamicQueryT m i a -> View -> m ([a], View)+mapDyn i q v = do+  (as, arches) <-+    foldlM+      ( \(acc, archAcc) (aId, n) -> do+          (as', arch') <- runDynQuery q (repeat i) $ nodeArchetype n+          return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)+      )+      ([], Map.empty)+      (Map.toList $ viewArchetypes v)+  return (as, View arches)++-- | Map a single matching entity in a `View`.+--+-- @since 9.0+mapSingleDyn :: (Monad m) => i -> DynamicQueryT m i a -> View -> m (Maybe a, View)+mapSingleDyn i q v = do+  (as, arches) <- mapDyn i q v+  return $ case as of+    [a] -> (Just a, arches)+    _ -> (Nothing, arches)
src/Aztecs/ECS/World.hs view
@@ -1,19 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-} {-# 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,-    spawnWithArchetypeId,     spawnEmpty,     insert,-    insertWithId,     lookup,     remove,     removeWithId,@@ -23,24 +28,33 @@  import Aztecs.ECS.Component import Aztecs.ECS.Entity-import Aztecs.ECS.World.Archetypes (ArchetypeID) import Aztecs.ECS.World.Bundle import Aztecs.ECS.World.Entities (Entities) import qualified Aztecs.ECS.World.Entities as E import Control.DeepSeq import Data.Dynamic-import Data.Map (Map)+import Data.IntMap (IntMap) import GHC.Generics import Prelude hiding (lookup)  -- | World of entities and their components.+--+-- @since 9.0 data World = World-  { entities :: Entities,+  { -- | Entities and their components.+    --+    -- @since 9.0+    entities :: !Entities,+    -- | Next unique entity identifier.+    --+    -- @since 9.0     nextEntityId :: !EntityID   }   deriving (Show, Generic, NFData)  -- | Empty `World`.+--+-- @since 9.0 empty :: World empty =   World@@ -48,46 +62,44 @@       nextEntityId = EntityID 0     } +-- | Spawn a `Bundle` into the `World`.+--+-- @since 9.0 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 9.0 spawnEmpty :: World -> (EntityID, World) spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID $ unEntityId e + 1}) --- | Spawn an entity with a component and its `ComponentID` directly into an archetype.-spawnWithArchetypeId ::-  forall a.-  (Component a) =>-  ArchetypeID ->-  ComponentID ->-  a ->-  World ->-  (EntityID, World)-spawnWithArchetypeId aId cId c w =-  let !(e, w') = spawnEmpty w-   in (e, w' {entities = E.spawnWithArchetypeId e aId cId c (entities w')})---- | Insert a component into an entity.-insert :: forall a. (Component a) => EntityID -> a -> World -> World+-- | Insert a `Bundle` into an entity.+--+-- @since 9.0+insert :: EntityID -> Bundle -> World -> World insert e c w = w {entities = E.insert e c (entities w)} --- | Insert a component into an entity with its `ComponentID`.-insertWithId :: (Component a) => EntityID -> ComponentID -> a -> World -> World-insertWithId e cId c w = w {entities = E.insertWithId e cId c (entities w)}-+-- | Lookup a component in an entity.+--+-- @since 9.0 lookup :: forall a. (Component a) => EntityID -> World -> Maybe a lookup e w = E.lookup e $ entities w --- | Insert a component into an entity.+-- | Remove a component from an entity.+--+-- @since 9.0 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 9.0 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 -> (Map ComponentID Dynamic, World)+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
@@ -11,16 +11,32 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +-- |+-- Module      : Aztecs.ECS.World.Archetype+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.ECS.World.Archetype   ( Archetype (..),     empty,+    singleton,     lookupComponent,+    lookupComponents,+    lookupComponentsAsc,+    lookupComponentsAscMaybe,     lookupStorage,     member,     remove,     removeStorages,     insertComponent,+    insertComponents,     insertAscList,+    zipWith,+    zipWith_,+    zipWithM,   ) where @@ -30,77 +46,205 @@ import Aztecs.ECS.World.Storage.Dynamic import qualified Aztecs.ECS.World.Storage.Dynamic as S import Control.DeepSeq+import Control.Monad.Writer hiding (zipWithM) import Data.Dynamic import Data.Foldable-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics+import Prelude hiding (map, zipWith) +-- | Archetype of entities and components.+-- An archetype is guranteed to contain one of each stored component per entity.+--+-- @since 9.0 data Archetype = Archetype-  { storages :: !(Map ComponentID DynamicStorage),+  { -- | Component storages.+    --+    -- @since 9.0+    storages :: !(IntMap DynamicStorage),+    -- | Entities stored in this archetype.+    --+    -- @since 9.0     entities :: !(Set EntityID)   }   deriving (Show, Generic, NFData) +-- | Empty archetype.+--+-- @since 9.0 empty :: Archetype-empty = Archetype {storages = Map.empty, entities = Set.empty}+empty = Archetype {storages = IntMap.empty, entities = Set.empty} +-- | Archetype with a single entity.+--+-- @since 9.0+singleton :: EntityID -> Archetype+singleton e = Archetype {storages = IntMap.empty, entities = Set.singleton e}++-- | Lookup a component `Storage` by its `ComponentID`.+--+-- @since 9.0+{-# INLINE lookupStorage #-} lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a) lookupStorage cId w = do-  dynS <- Map.lookup cId (storages w)-  fromDynamic (storageDyn dynS)+  !dynS <- IntMap.lookup (unComponentId cId) $ storages w+  fromDynamic $ storageDyn dynS -lookupComponents :: forall a. (Component a) => ComponentID -> Archetype -> Map EntityID a-lookupComponents cId arch = case lookupStorage @a cId arch of-  Just s -> Map.fromAscList . zip (Set.toList $ entities arch) $ S.toAscList s+-- | Lookup a component by its `EntityID` and `ComponentID`.+--+-- @since 9.0+{-# INLINE lookupComponent #-}+lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a+lookupComponent e cId w = lookupComponents cId w Map.!? e++-- | Lookup all components by their `ComponentID`.+--+-- @since 9.0+{-# INLINE lookupComponents #-}+lookupComponents :: (Component a) => ComponentID -> Archetype -> Map EntityID a+lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of+  Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) as   Nothing -> Map.empty -insertComponent :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype+-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.+--+-- @since 9.0+{-# INLINE lookupComponentsAsc #-}+lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> [a]+lookupComponentsAsc cId = fromMaybe [] . lookupComponentsAscMaybe cId++-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.+--+-- @since 9.0+{-# INLINE lookupComponentsAscMaybe #-}+lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe [a]+lookupComponentsAscMaybe cId arch = S.toAscList <$> lookupStorage @a cId arch++-- | Insert a component into the archetype.+-- This assumes the archetype contains one of each stored component per entity.+--+-- @since 9.0+insertComponent ::+  forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype insertComponent e cId c arch =   let !storage =         S.fromAscList @a @(StorageT a) . Map.elems . Map.insert e c $ lookupComponents cId arch-   in arch {storages = Map.insert cId (dynStorage @a storage) (storages 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 9.0 member :: ComponentID -> Archetype -> Bool-member cId arch = Map.member cId (storages arch)+member cId = IntMap.member (unComponentId cId) . storages -lookupComponent :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a-lookupComponent e cId w = lookupComponents cId w Map.!? e+-- | Zip a list of components with a function and a component storage.+--+-- @since 9.0+{-# INLINE zipWith #-}+zipWith ::+  forall a c. (Component c) => [a] -> (a -> c -> c) -> ComponentID -> Archetype -> ([c], Archetype)+zipWith as f cId arch =+  let go maybeDyn = case maybeDyn of+        Just dyn -> case fromDynamic $ storageDyn dyn of+          Just s -> do+            let !(cs', s') = S.zipWith @c @(StorageT c) f as s+            tell cs'+            return $ Just $ dyn {storageDyn = toDyn s'}+          Nothing -> return maybeDyn+        Nothing -> return Nothing+      !(storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch+   in (cs, arch {storages = storages'}) +-- | Zip a list of components with a monadic function and a component storage.+--+-- @since 9.0+zipWithM ::+  forall m a c. (Monad m, Component c) => [a] -> (a -> c -> m c) -> ComponentID -> Archetype -> m ([c], Archetype)+zipWithM as f cId arch = do+  let go maybeDyn = case maybeDyn of+        Just dyn -> case fromDynamic $ storageDyn dyn of+          Just s -> do+            (cs', s') <- lift $ S.zipWithM @c @(StorageT c) f as s+            tell cs'+            return $ Just $ dyn {storageDyn = toDyn s'}+          Nothing -> return maybeDyn+        Nothing -> return Nothing+  (storages', cs) <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch+  return (cs, arch {storages = storages'})++-- | Zip a list of components with a function and a component storage.+--+-- @since 9.0+{-# INLINE zipWith_ #-}+zipWith_ ::+  forall a c. (Component c) => [a] -> (a -> c -> c) -> ComponentID -> Archetype -> Archetype+zipWith_ as f cId arch =+  let go maybeDyn = case maybeDyn 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 -> maybeDyn+        Nothing -> Nothing+      !storages' = IntMap.alter go (unComponentId cId) $ storages arch+   in (arch {storages = storages'})+ -- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`.+--+-- @since 9.0+{-# INLINE insertAscList #-} insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype insertAscList cId as arch =   let !storage = dynStorage @a $ S.fromAscList @a @(StorageT a) as-   in arch {storages = Map.insert cId storage (storages arch)}+   in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch} -remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)+-- | Remove an entity from an archetype, returning its components.+--+-- @since 9.0+remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype) remove e arch =-  foldl'-    ( \(dynAcc, archAcc) (cId, dynS) ->+  let go (dynAcc, archAcc) (cId, dynS) =         let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS             !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs             dynS' = S.fromAscListDyn (Map.elems cs') dynS             !dynAcc' = case dynA of-              Just d -> Map.insert cId d dynAcc+              Just d -> IntMap.insert cId d dynAcc               Nothing -> dynAcc-         in (dynAcc', archAcc {storages = Map.insert cId dynS' $ storages archAcc})-    )-    (Map.empty, arch)-    (Map.toList $ storages arch)+         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' -removeStorages :: EntityID -> Archetype -> (Map ComponentID DynamicStorage, Archetype)+-- | Remove an entity from an archetype, returning its component storages.+--+-- @since 9.0+removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype) removeStorages e arch =-  foldl'-    ( \(dynAcc, archAcc) (cId, dynS) ->+  let go (dynAcc, archAcc) (cId, dynS) =         let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS             !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs             dynS' = S.fromAscListDyn (Map.elems cs') dynS             !dynAcc' = case dynA of-              Just d -> Map.insert cId (S.singletonDyn d dynS') dynAcc+              Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc               Nothing -> dynAcc-         in (dynAcc', archAcc {storages = Map.insert cId dynS' $ storages archAcc})-    )-    (Map.empty, arch)-    (Map.toList $ storages arch)+         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 9.0+insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype+insertComponents e cs arch =+  let f archAcc (itemCId, dyn) =+        let storages' = IntMap.adjust go itemCId (storages archAcc)+            es = Set.toList $ entities archAcc+            go s =+              let ecs = Map.elems . Map.insert e dyn . Map.fromAscList . zip es $ toAscListDyn s+               in fromAscListDyn ecs s+         in archAcc {storages = storages', entities = Set.insert e $ entities archAcc}+   in foldl' f arch (IntMap.toList cs)
src/Aztecs/ECS/World/Archetypes.hs view
@@ -11,6 +11,14 @@ {-# 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 (..),@@ -28,57 +36,74 @@   ) where -import Aztecs.ECS.Component (Component (..), ComponentID)-import Aztecs.ECS.Entity (EntityID (..))-import Aztecs.ECS.World.Archetype-  ( Archetype (..),-    insertComponent,-    removeStorages,-  )+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.Storage.Dynamic (fromAscListDyn, toAscListDyn)+import Aztecs.ECS.World.Bundle.Dynamic+import Aztecs.ECS.World.Storage.Dynamic import Control.DeepSeq (NFData (..))-import Data.Dynamic (fromDynamic)+import Data.Dynamic import Data.Foldable (foldl')+import qualified Data.IntMap.Strict as IntMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe)+import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set-import GHC.Generics (Generic)+import GHC.Generics import Prelude hiding (all, lookup, map)  -- | `Archetype` ID.-newtype ArchetypeID = ArchetypeID {unArchetypeId :: Int}+--+-- @since 9.0+newtype ArchetypeID = ArchetypeID+  { -- | Unique integer identifier.+    --+    -- @since 9.0+    unArchetypeId :: Int+  }   deriving newtype (Eq, Ord, Show, NFData)  -- | Node in `Archetypes`.+--+-- @since 9.0 data Node = Node   { -- | Unique set of `ComponentID`s of this `Node`.+    --+    -- @since 9.0     nodeComponentIds :: !(Set ComponentID),     -- | `Archetype` of this `Node`.-    nodeArchetype :: !Archetype,-    -- | Edges to other `Archetype`s by adding a `ComponentID`.-    nodeAdd :: !(Map ComponentID ArchetypeID),-    -- | Edges to other `Archetype`s by removing a `ComponentID`.-    nodeRemove :: !(Map ComponentID ArchetypeID)+    --+    -- @since 9.0+    nodeArchetype :: !Archetype   }   deriving (Show, Generic, NFData) --- | `Archetype` graph.+-- | `Archetype` map. data Archetypes = Archetypes-  { -- | Archetype nodes in the graph.+  { -- | Archetype nodes in the map.+    --+    -- @since 9.0     nodes :: !(Map ArchetypeID Node),     -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.+    --+    -- @since 9.0     archetypeIds :: !(Map (Set ComponentID) ArchetypeID),     -- | Next unique `ArchetypeID`.+    --+    -- @since 9.0     nextArchetypeId :: !ArchetypeID,     -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.+    --+    -- @since 9.0     componentIds :: !(Map ComponentID (Set ArchetypeID))   }   deriving (Show, Generic, NFData)  -- | Empty `Archetypes`.+--+-- @since 9.0 empty :: Archetypes empty =   Archetypes@@ -89,6 +114,8 @@     }  -- | Insert an archetype by its set of `ComponentID`s.+--+-- @since 9.0 insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes) insertArchetype cIds n arches =   let aId = nextArchetypeId arches@@ -101,20 +128,30 @@           }       ) +-- | Adjust an `Archetype` by its `ArchetypeID`.+--+-- @since 9.0 adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes-adjustArchetype aId f arches = arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}+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 9.0 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 9.0 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 9.0 map :: Set ComponentID -> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes) map cIds f arches =   let go (acc, archAcc) aId =@@ -124,57 +161,58 @@          in (a : acc, archAcc {nodes = nodes'})    in foldl' go ([], arches) $ findArchetypeIds cIds arches +-- | Lookup an `ArchetypeID` by its set of `ComponentID`s.+--+-- @since 9.0 lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches) +-- | Lookup an `Archetype` by its `ArchetypeID`.+--+-- @since 9.0 lookup :: ArchetypeID -> Archetypes -> Maybe Node lookup aId arches = Map.lookup aId (nodes arches)  -- | Insert a component into an entity with its `ComponentID`.+--+-- @since 9.0 insert ::-  (Component a) =>   EntityID ->   ArchetypeID ->-  ComponentID ->-  a ->+  Set ComponentID ->+  DynamicBundle ->   Archetypes ->   (Maybe ArchetypeID, Archetypes)-insert e aId cId c arches = case lookup aId arches of+insert e aId cIds b arches = case lookup aId arches of   Just node ->-    if Set.member cId (nodeComponentIds node)+    if cIds == nodeComponentIds node       then-        let go n = n {nodeArchetype = insertComponent e cId c (nodeArchetype n)}-         in (Nothing, arches {nodes = Map.adjust go aId (nodes arches)})-      else case lookupArchetypeId (Set.insert cId (nodeComponentIds node)) arches of+        let go n = n {nodeArchetype = runDynamicBundle b e $ nodeArchetype n}+         in (Nothing, arches {nodes = Map.adjust go aId $ nodes arches})+      else case lookupArchetypeId cIds arches of         Just nextAId ->-          let !(cs, arch') = A.remove e (nodeArchetype node)+          let !(cs, arch') = A.remove e $ nodeArchetype node               node' = node {nodeArchetype = arch'}               !arches' = arches {nodes = Map.insert aId node' (nodes arches)}-              f archAcc (itemCId, dyn) =-                let storages' = Map.adjust go itemCId (storages archAcc)-                    go s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s-                 in archAcc {storages = storages'}               adjustNode nextNode =-                let nextArch = foldl' f (nodeArchetype nextNode) (Map.toList cs)-                 in nextNode {nodeArchetype = insertComponent e cId c nextArch}+                let !nextArch = A.insertComponents e cs $ nodeArchetype nextNode+                 in nextNode {nodeArchetype = runDynamicBundle b e nextArch}            in (Just nextAId, arches' {nodes = Map.adjust adjustNode nextAId (nodes arches')})         Nothing ->-          let !(s, arch') = removeStorages e (nodeArchetype node)+          let !(s, arch') = A.removeStorages e $ nodeArchetype node               !n =                 Node-                  { nodeComponentIds = Set.insert cId (nodeComponentIds node),-                    nodeArchetype = insertComponent e cId c (Archetype {storages = s, entities = Set.singleton e}),-                    nodeAdd = Map.empty,-                    nodeRemove = Map.singleton cId aId+                  { nodeComponentIds = cIds,+                    nodeArchetype = runDynamicBundle b e (Archetype {storages = s, entities = Set.singleton e})                   }-              cIds = Set.insert cId (nodeComponentIds node)               !(nextAId, arches') = insertArchetype cIds n arches-           in let node' =-                    node {nodeArchetype = arch', nodeAdd = Map.insert cId nextAId (nodeAdd node)}-                  nodes' = Map.insert aId node' (nodes arches')+           in let nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes arches')                in (Just nextAId, arches' {nodes = nodes'})   Nothing -> (Nothing, arches) +-- | Remove a component from an entity with its `ComponentID`.+--+-- @since 9.0 remove ::   (Component a) =>   EntityID ->@@ -187,27 +225,25 @@     Just nextAId ->       let !(cs, arch') = A.remove e (nodeArchetype node)           !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}-          (a, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) cId cs+          (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs           go' archAcc (itemCId, dyn) =             let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s-             in archAcc {storages = Map.adjust adjustStorage itemCId (storages archAcc)}+             in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)}           go nextNode =-            nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (Map.toList cs')}+            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') = removeStorages e (nodeArchetype node)-          (a, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) cId cs+      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},-                nodeAdd = Map.empty,-                nodeRemove = Map.singleton cId aId+                nodeArchetype = Archetype {storages = cs', entities = Set.singleton e}               }           !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches-          node' = node {nodeArchetype = arch', nodeAdd = Map.insert cId nextAId (nodeAdd node)}+          node' = node {nodeArchetype = arch'}           removeDyn s =             let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') $ toAscListDyn s              in (res, fromAscListDyn $ Map.elems dyns)
src/Aztecs/ECS/World/Bundle.hs view
@@ -3,9 +3,18 @@ {-# 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 (..),@@ -14,37 +23,50 @@   ) where -import Aztecs.ECS.Component (Component (..), ComponentID)-import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.World.Archetype (Archetype)+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 (Components)+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.-newtype Bundle = Bundle {unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)}+--+-- @since 9.0+newtype Bundle = Bundle+  { -- | Unwrap the bundle.+    --+    -- @since 9.0+    unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)+  } +-- | @since 9.0 instance Monoid Bundle where-  mempty = Bundle $ \cs -> (Set.empty, cs, mempty)+  mempty = Bundle (Set.empty,,mempty) +-- | @since 9.0 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 9.0 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 9.0 instance MonoidDynamicBundle Bundle where-  dynBundle cId c = Bundle $ \cs -> (Set.singleton cId, cs, dynBundle cId c)+  dynBundle cId c = Bundle (Set.singleton cId,,dynBundle cId c)  -- | Insert a bundle of components into an archetype.+--+-- @since 9.0 runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype) runBundle b cs eId arch =   let !(_, cs', d) = unBundle b cs
src/Aztecs/ECS/World/Bundle/Class.hs view
@@ -1,11 +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 (Component (..))+import Aztecs.ECS.Component  -- | Monoid bundle of components.+--+-- @since 9.0 class (Monoid a) => MonoidBundle a where   -- | Add a component to the bundle.+  --+  -- @since 9.0   bundle :: forall c. (Component c) => c -> a
src/Aztecs/ECS/World/Bundle/Dynamic.hs view
@@ -1,21 +1,30 @@-module Aztecs.ECS.World.Bundle.Dynamic-  ( DynamicBundle (..),-    MonoidDynamicBundle (..),-  )-where+-- |+-- 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 (EntityID)-import Aztecs.ECS.World.Archetype (Archetype, insertComponent)-import Aztecs.ECS.World.Bundle.Dynamic.Class (MonoidDynamicBundle (..))+import Aztecs.ECS.Entity+import Aztecs.ECS.World.Archetype+import Aztecs.ECS.World.Bundle.Dynamic.Class  -- | Dynamic bundle of components.+--+-- @since 9.0 newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype} +-- | @since 9.0 instance Semigroup DynamicBundle where   DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch) +-- | @since 9.0 instance Monoid DynamicBundle where   mempty = DynamicBundle $ \_ arch -> arch +-- | @since 9.0 instance MonoidDynamicBundle DynamicBundle where   dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch
src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs view
@@ -1,9 +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 (Component (..))-import Aztecs.ECS.World.Components (ComponentID)+import Aztecs.ECS.Component  -- | Monoid bundle of dynamic components.+--+-- @since 9.0 class MonoidDynamicBundle a where   -- | Add a component to the bundle by its `ComponentID`.+  --+  -- @since 9.0   dynBundle :: (Component c) => ComponentID -> c -> a
src/Aztecs/ECS/World/Components.hs view
@@ -5,6 +5,14 @@ {-# 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 (..),@@ -15,22 +23,32 @@   ) where -import Aztecs.ECS.Component (Component, ComponentID (..))-import Control.DeepSeq (NFData)+import Aztecs.ECS.Component+import Control.DeepSeq import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Typeable (Proxy (..), TypeRep, Typeable, typeOf)-import GHC.Generics (Generic)+import Data.Typeable+import GHC.Generics import Prelude hiding (lookup)  -- | Component ID map.+--+-- @since 9.0 data Components = Components-  { componentIds :: !(Map TypeRep ComponentID),+  { -- | Map of component types to identifiers.+    --+    -- @since 9.0+    componentIds :: !(Map TypeRep ComponentID),+    -- | Next unique component identifier.+    --+    -- @since 9.0     nextComponentId :: !ComponentID   }   deriving (Show, Generic, NFData)  -- | Empty `Components`.+--+-- @since 9.0 empty :: Components empty =   Components@@ -39,16 +57,22 @@     }  -- | Lookup a component ID by type.+--+-- @since 9.0 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 9.0 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 9.0 insert' :: forall c. (Component c) => Components -> (ComponentID, Components) insert' cs =   let !cId = nextComponentId cs
src/Aztecs/ECS/World/Entities.hs view
@@ -5,15 +5,21 @@ {-# 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,-    spawnComponent,-    spawnWithId,     spawnWithArchetypeId,     insert,-    insertWithId,+    insertDyn,     lookup,     remove,     removeWithId,@@ -32,23 +38,38 @@ import qualified Aztecs.ECS.World.Components as CS import Control.DeepSeq import Data.Dynamic+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe+import Data.Set (Set) import qualified Data.Set as Set-import Data.Typeable import GHC.Generics import Prelude hiding (lookup)  -- | World of entities and their components.+--+-- @since 9.0 data Entities = Entities-  { archetypes :: !Archetypes,+  { -- | Archetypes.+    --+    -- @since 9.0+    archetypes :: !Archetypes,+    -- | Components.+    --+    -- @since 9.0     components :: !Components,+    -- | Entities and their archetype identifiers.+    --+    -- @since 9.0     entities :: !(Map EntityID ArchetypeID)   }   deriving (Show, Generic, NFData)  -- | Empty `World`.+--+-- @since 9.0 empty :: Entities empty =   Entities@@ -57,6 +78,9 @@       entities = mempty     } +-- | Spawn a `Bundle`.+--+-- @since 9.0 spawn :: EntityID -> Bundle -> Entities -> Entities spawn eId b w =   let (cIds, components', dynB) = unBundle b (components w)@@ -78,103 +102,67 @@                 entities = Map.insert eId aId (entities w)               }         Nothing ->-          let arch' = runDynamicBundle dynB eId A.empty {A.entities = Set.singleton eId}-              (aId, arches) =-                AS.insertArchetype-                  cIds-                  ( Node-                      { nodeComponentIds = cIds,-                        nodeArchetype = arch',-                        nodeAdd = Map.empty,-                        nodeRemove = Map.empty-                      }-                  )-                  (archetypes w)+          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 an entity with a component.-spawnComponent :: forall a. (Component a) => EntityID -> a -> Entities -> Entities-spawnComponent e c w = case Map.lookup (typeOf (Proxy @a)) (componentIds (components w)) of-  Just cId -> spawnWithId e cId c w-  Nothing ->-    let (cId, cs) = CS.insert @a (components w) in spawnWithId e cId c w {components = cs}---- | Spawn an entity with a component and its `ComponentID`.-spawnWithId ::-  forall a.-  (Component a) =>-  EntityID ->-  ComponentID ->-  a ->-  Entities ->-  Entities-spawnWithId e cId c w = case AS.lookupArchetypeId (Set.singleton cId) (archetypes w) of-  Just aId -> spawnWithArchetypeId e aId cId c w-  Nothing ->-    let !(aId, arches) =-          AS.insertArchetype-            (Set.singleton cId)-            ( Node-                { nodeComponentIds = Set.singleton cId,-                  nodeArchetype = A.insertComponent e cId c A.empty,-                  nodeAdd = Map.empty,-                  nodeRemove = Map.empty-                }-            )-            (archetypes w)-     in w {archetypes = arches, entities = Map.insert e aId (entities w)}-+-- | Spawn a `DynamicBundle` with a specified `ArchetypeID`.+--+-- @since 9.0 spawnWithArchetypeId ::-  forall a.-  (Component a) =>   EntityID ->   ArchetypeID ->-  ComponentID ->-  a ->+  DynamicBundle ->   Entities ->   Entities-spawnWithArchetypeId e aId cId c w =-  let f n = n {nodeArchetype = A.insertComponent e cId c (nodeArchetype n)}+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.-insert :: forall a. (Component a) => EntityID -> a -> Entities -> Entities-insert e c w =-  let !(cId, components') = CS.insert @a (components w)-   in insertWithId e cId c w {components = components'}+--+-- @since 9.0+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`.-insertWithId :: (Component a) => EntityID -> ComponentID -> a -> Entities -> Entities-insertWithId e cId c w = case Map.lookup e (entities w) of+--+-- @since 9.0+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 cId c $ archetypes w+    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 (Set.singleton cId) (archetypes w) of-    Just aId -> spawnWithArchetypeId e aId cId c w+  Nothing -> case AS.lookupArchetypeId cIds (archetypes w) of+    Just aId -> spawnWithArchetypeId e aId b w     Nothing ->       let (aId, arches) =             AS.insertArchetype-              (Set.singleton cId)+              cIds               ( Node-                  { nodeComponentIds = Set.singleton cId,-                    nodeArchetype = A.insertComponent e cId c A.empty,-                    nodeAdd = Map.empty,-                    nodeRemove = Map.empty+                  { nodeComponentIds = cIds,+                    nodeArchetype = runDynamicBundle b e $ A.singleton e                   }               )               (archetypes w)        in w {archetypes = arches, entities = Map.insert e aId (entities w)} +-- | Lookup a component in an entity.+--+-- @since 9.0 lookup :: forall a. (Component a) => EntityID -> Entities -> Maybe a lookup e w = do   !cId <- CS.lookup @a $ components w@@ -183,11 +171,16 @@   A.lookupComponent e cId $ nodeArchetype node  -- | Insert a component into an entity.+--+-- @since 9.0 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 9.0 removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> Entities -> (Maybe a, Entities) removeWithId e cId w = case Map.lookup e (entities w) of   Just aId ->@@ -199,7 +192,9 @@   Nothing -> (Nothing, w)  -- | Despawn an entity, returning its components.-despawn :: EntityID -> Entities -> (Map ComponentID Dynamic, Entities)+--+-- @since 9.0+despawn :: EntityID -> Entities -> (IntMap Dynamic, Entities) despawn e w =   let res = do         !aId <- Map.lookup e $ entities w@@ -214,4 +209,4 @@                     entities = Map.delete e (entities w)                   }               )-        Nothing -> (Map.empty, w)+        Nothing -> (IntMap.empty, w)
src/Aztecs/ECS/World/Storage.hs view
@@ -1,23 +1,78 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +-- |+-- Module      : Aztecs.ECS.World.Storage+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.ECS.World.Storage (Storage (..)) where  import Control.DeepSeq+import qualified Control.Monad import Data.Data+import Prelude hiding (zipWith)+import qualified Prelude  -- | Component storage, containing zero or many components of the same type.+--+-- @since 9.0 class (Typeable s, NFData s, Typeable a) => Storage a s where   -- | Storage with a single component.+  --+  -- @since 9.0   singleton :: a -> s    -- | List of all components in the storage in ascending order.+  --+  -- @since 9.0   toAscList :: s -> [a]    -- | Convert a sorted list of components (in ascending order) into a storage.+  --+  -- @since 9.0   fromAscList :: [a] -> s +  -- | Map a function over all components in the storage.+  --+  --+  -- @since 9.0+  map :: (a -> a) -> s -> s++  -- | Map a function with some input over all components in the storage.+  --+  -- @since 9.0+  zipWith :: (i -> a -> a) -> [i] -> s -> ([a], s)++  -- | Map a monadic function with some input over all components in the storage.+  --+  -- @since 9.0+  zipWithM :: (Monad m) => (i -> a -> m a) -> [i] -> s -> m ([a], s)++  -- | Map a function with some input over all components in the storage.+  --+  -- @since 9.0+  zipWith_ :: (i -> a -> a) -> [i] -> s -> s+  zipWith_ f is as = snd $ zipWith f is as++-- | @since 9.0 instance (Typeable a, NFData a) => Storage a [a] where+  {-# INLINE singleton #-}   singleton a = [a]+  {-# INLINE toAscList #-}   toAscList = id+  {-# INLINE fromAscList #-}   fromAscList = id+  {-# INLINE map #-}+  map = fmap+  {-# INLINE zipWith #-}+  zipWith f is as = let as' = Prelude.zipWith f is as in (as', as')+  {-# INLINE zipWith_ #-}+  zipWith_ = Prelude.zipWith+  {-# INLINE zipWithM #-}+  zipWithM f is as = do+    as' <- Control.Monad.zipWithM f is as+    return (as', as')
src/Aztecs/ECS/World/Storage/Dynamic.hs view
@@ -8,6 +8,14 @@ {-# 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,@@ -22,20 +30,44 @@ import Data.Dynamic import Data.Maybe +-- | Dynamic storage of components.+--+-- @since 9.0 data DynamicStorage = DynamicStorage-  { storageDyn :: !Dynamic,+  { -- | Dynamic storage.+    --+    -- @since 9.0+    storageDyn :: !Dynamic,+    -- | Singleton storage.+    --+    -- @since 9.0     singletonDyn' :: !(Dynamic -> Dynamic),+    -- | Convert this storage to an ascending list.+    --+    -- @since 9.0     toAscListDyn' :: !(Dynamic -> [Dynamic]),+    -- | Convert from an ascending list.+    --+    -- @since 9.0     fromAscListDyn' :: !([Dynamic] -> Dynamic),+    -- | Reduce this storage to normal form.+    --+    -- @since 9.0     storageRnf :: !(Dynamic -> ())   } +-- | @since 9.0 instance Show DynamicStorage where   show s = "DynamicStorage " ++ show (storageDyn s) +-- | @since 9.0 instance NFData DynamicStorage where   rnf s = storageRnf s (storageDyn s) +-- | Create a dynamic storage from a storage.+--+-- @since 9.0+{-# INLINE dynStorage #-} dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage dynStorage s =   DynamicStorage@@ -46,11 +78,20 @@       storageRnf = maybe () rnf . fromDynamic @s     } +-- | Singleton dynamic storage.+--+-- @since 9.0 singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} +-- | Convert from an ascending list.+--+-- @since 9.0 fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns} +-- | Convert this storage to an ascending list.+--+-- @since 9.0 toAscListDyn :: DynamicStorage -> [Dynamic] toAscListDyn = toAscListDyn' <*> storageDyn
src/Aztecs/Hierarchy.hs view
@@ -5,6 +5,17 @@ {-# 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 (..),@@ -25,172 +36,226 @@ import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S-import Control.Arrow (returnA)+import Control.Arrow import Control.DeepSeq-import Control.Monad (when)+import Control.Monad import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (mapMaybe)+import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set-import GHC.Generics (Generic)+import GHC.Generics -newtype Parent = Parent {unParent :: EntityID}+-- | Parent component.+--+-- @since 9.0+newtype Parent = Parent+  { -- | Parent entity ID.+    --+    -- @since 9.0+    unParent :: EntityID+  }   deriving (Eq, Ord, Show, Generic, NFData) +-- | @since 9.0 instance Component Parent +-- | Parent internal state component.+--+-- @since 9.0 newtype ParentState = ParentState {unParentState :: EntityID}   deriving (Show, Generic, NFData) +-- | @since 9.0 instance Component ParentState +-- | Children component.+--+-- @since 9.0 newtype Children = Children {unChildren :: Set EntityID}   deriving (Eq, Ord, Show, Semigroup, Monoid, Generic, NFData) +-- | @since 9.0 instance Component Children +-- | Child internal state component. newtype ChildState = ChildState {unChildState :: Set EntityID}   deriving (Show, Generic, NFData) +-- | @since 9.0 instance Component ChildState +-- | Update the parent-child relationships.+--+-- @since 9.0 update ::   ( ArrowQueryReader qr,     ArrowDynamicQueryReader qr,-    ArrowReaderSystem qr arr,-    ArrowQueueSystem b m arr+    MonadReaderSystem qr s,+    MonadAccess b m   ) =>-  arr () ()-update = proc () -> do+  s (m ())+update = do   parents <-     S.all+      ()       ( proc () -> do           entity <- Q.entity -< ()           Parent parent <- Q.fetch -< ()           maybeParentState <- Q.fetchMaybe @_ @ParentState -< ()           returnA -< (entity, parent, maybeParentState)       )-      -<-        ()+   children <-     S.all+      ()       ( proc () -> do           entity <- Q.entity -< ()           Children cs <- Q.fetch -< ()           maybeChildState <- Q.fetchMaybe @_ @ChildState -< ()           returnA -< (entity, cs, maybeChildState)       )-      -<-        ()-  S.queue-    ( \(parents, childRes) -> do++  let go = do         mapM_           ( \(entity, parent, maybeParentState) -> case maybeParentState of               Just (ParentState parentState) -> do                 when (parent /= parentState) $ do-                  A.insert parent $ ParentState parent+                  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 . Children $ 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 . Children $ Set.insert entity parentChildren+                  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 . Children $ Set.insert entity parentChildren+                A.insert parent . bundle . Children $ Set.insert entity parentChildren           )           parents         mapM_-          ( \(entity, children, maybeChildState) -> case maybeChildState of+          ( \(entity, children', maybeChildState) -> case maybeChildState of               Just (ChildState childState) -> do-                when (children /= childState) $ do-                  A.insert entity $ ChildState children-                  let added = Set.difference children childState-                      removed = Set.difference childState children-                  mapM_ (\e -> A.insert e . Parent $ entity) added+                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 $ ChildState children-                mapM_ (\e -> A.insert e . Parent $ entity) children+                A.insert entity . bundle $ ChildState children'+                mapM_ (\e -> A.insert e . bundle . Parent $ entity) children'           )-          childRes-    )-    -<-      (parents, children)+          children+  return go +-- | Hierarchy of entities.+--+-- @since 9.0 data Hierarchy a = Node-  { nodeEntityId :: EntityID,+  { -- | Entity ID.+    --+    -- @since 9.0+    nodeEntityId :: EntityID,+    -- | Entity components.     nodeEntity :: a,+    -- | Child nodes.+    --+    -- @since 9.0     nodeChildren :: [Hierarchy a]   }   deriving (Functor) +-- | @since 9.0 instance Foldable Hierarchy where   foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n) +-- | @since 9.0 instance Traversable Hierarchy where-  traverse f n = Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n)+  traverse f n =+    Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n) +-- | Convert a hierarchy to a list of entity IDs and components.+--+-- @since 9.0 toList :: Hierarchy a -> [(EntityID, a)] toList n = (nodeEntityId n, nodeEntity n) : concatMap toList (nodeChildren n) +-- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator.+--+-- @since 9.0 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 9.0 mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b-mapWithKey f n = Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n))+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 9.0 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 9.0 hierarchy ::-  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>+  (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>   EntityID ->+  i ->   q i a ->-  arr i (Maybe (Hierarchy a))-hierarchy e q = proc i -> do+  s (Maybe (Hierarchy a))+hierarchy e i q = do   children <-     S.all-      ( proc i -> do+      ()+      ( proc () -> do           entity <- Q.entity -< ()           Children cs <- Q.fetch -< ()           a <- q -< i           returnA -< (entity, (cs, a))       )-      -<-        i   let childMap = Map.fromList children-  returnA -< hierarchy' e childMap+  return $ hierarchy' e childMap --- | Build all hierarchies of parents to children with the given query.+-- | Build all hierarchies of parents to children, joined with the given query.+--+-- @since 9.0 hierarchies ::-  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>+  (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>+  i ->   q i a ->-  arr i [Hierarchy a]-hierarchies q = proc i -> do+  s [Hierarchy a]+hierarchies i q = do   children <-     S.all-      ( proc i -> do+      ()+      ( proc () -> do           entity <- Q.entity -< ()           Children cs <- Q.fetch -< ()           a <- q -< i           returnA -< (entity, (cs, a))       )-      -<-        i+   let childMap = Map.fromList children-  roots <- S.filter Q.entity $ with @Children <> without @Parent -< ()-  returnA -< mapMaybe (`hierarchy'` childMap) roots+  roots <- S.filter () Q.entity $ with @Children <> without @Parent+  return $ mapMaybe (`hierarchy'` childMap) roots +-- | Build a hierarchy of parents to children.+--+-- @since 9.0 hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a) hierarchy' e childMap = case Map.lookup e childMap of   Just (cs, a) ->
src/Aztecs/Input.hs view
@@ -1,6 +1,14 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +-- |+-- Module      : Aztecs.Input+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Input   ( Key (..),     InputMotion (..),@@ -27,6 +35,9 @@ import Linear (V2 (..)) import Linear.Affine (Point (..)) +-- | Keyboard key.+--+-- @since 9.0 data Key   = KeyA   | KeyB@@ -126,42 +137,66 @@   deriving (Show, Eq, Ord, Enum, Bounded, Generic, NFData)  -- | Keyboard input component.+--+-- @since 9.0 data KeyboardInput = KeyboardInput   { -- | Keyboard events that occured this frame.+    --+    -- @since 9.0     keyboardEvents :: !(Map Key InputMotion),     -- | Keys that are currently pressed.+    --+    -- @since 9.0     keyboardPressed :: !(Set Key)   }   deriving (Show, Generic, NFData) +-- | @since 9.0 instance Component KeyboardInput +-- | Empty keyboard input.+--+-- @since 9.0 keyboardInput :: KeyboardInput keyboardInput = KeyboardInput Map.empty Set.empty +-- | Input motion kind.+--+-- @since 9.0 data InputMotion = Pressed | Released   deriving (Show, Eq, Generic, NFData)  -- | @True@ if this key is currently pressed.+--+-- @since 9.0 isKeyPressed :: Key -> KeyboardInput -> Bool isKeyPressed key kb = Set.member key $ keyboardPressed kb  -- | Check for a key event that occured this frame.+--+-- @since 9.0 keyEvent :: Key -> KeyboardInput -> Maybe InputMotion keyEvent key kb = Map.lookup key $ keyboardEvents kb  -- | @True@ if this key was pressed this frame.+--+-- @since 9.0 wasKeyPressed :: Key -> KeyboardInput -> Bool wasKeyPressed key kb = case keyEvent key kb of   Just Pressed -> True   _ -> False  -- | @True@ if this key was released this frame.+--+-- @since 9.0 wasKeyReleased :: Key -> KeyboardInput -> Bool wasKeyReleased key kb = case keyEvent key kb of   Just Released -> True   _ -> False +-- | Handle a keyboard event.+--+-- @since 9.0 handleKeyboardEvent :: Key -> InputMotion -> KeyboardInput -> KeyboardInput handleKeyboardEvent key motion kb =   KeyboardInput@@ -171,6 +206,9 @@         Released -> Set.delete key $ keyboardPressed kb     } +-- | Mouse button kind.+--+-- @since 9.0 data MouseButton   = ButtonLeft   | ButtonMiddle@@ -182,21 +220,36 @@   deriving (Eq, Ord, Show, Generic, NFData)  -- | Mouse input component.+--+-- @since 9.0 data MouseInput = MouseInput   { -- | Mouse position in screen-space.+    --+    -- @since 9.0     mousePosition :: !(Point V2 Int),     -- | Mouse offset since last frame.+    --+    -- @since 9.0     mouseOffset :: !(V2 Int),     -- | Mouse button states.+    --+    -- @since 9.0     mouseButtons :: !(Map MouseButton InputMotion)   }   deriving (Show, Generic, NFData) +-- | @since 9.0 instance Component MouseInput +-- | Empty mouse input.+--+-- @since 9.0 mouseInput :: MouseInput mouseInput = MouseInput (P 0) (V2 0 0) Map.empty +-- | Handle a mouse motion event.+--+-- @since 9.0 handleMouseMotion :: V2 Int -> MouseInput -> MouseInput handleMouseMotion delta mouse =   mouse
src/Aztecs/Time.hs view
@@ -1,15 +1,30 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- |+-- Module      : Aztecs.Time+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Time (Time (..)) where  import Aztecs.ECS import Control.DeepSeq-import Data.Word (Word32)+import Data.Word import GHC.Generics  -- | Time component.-newtype Time = Time {elapsedMS :: Word32}+--+-- @since 9.0+newtype Time = Time+  { -- | Elapsed time (in milliseconds).+    --+    -- @since 9.0+    elapsedMS :: Word32+  }   deriving (Eq, Ord, Num, Show, Generic, NFData)  instance Component Time
src/Aztecs/Transform.hs view
@@ -7,6 +7,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +-- |+-- Module      : Aztecs.Transform+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Transform   ( -- * Transform     Transform (..),@@ -33,71 +41,125 @@ 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 Aztecs.Hierarchy (Hierarchy, hierarchies, mapWithAccum, toList)-import Control.Arrow (Arrow (..), (>>>)) import Control.DeepSeq-import GHC.Generics (Generic)-import Linear (V2 (..))+import GHC.Generics+import Linear  -- | Transform component.+--+-- @since 9.0 data Transform v r = Transform-  { transformTranslation :: !v,+  { -- | Translation.+    --+    -- @since 9.0+    transformTranslation :: !v,+    -- | Rotation.+    --+    -- @since 9.0     transformRotation :: !r,+    -- | Scale.+    --+    -- @since 9.0     transformScale :: !v   }   deriving (Eq, Show, Generic, NFData) +-- | @since 9.0 instance (Num v, Num r) => Semigroup (Transform v r) where   Transform t1 r1 s1 <> Transform t2 r2 s2 = Transform (t1 + t2) (r1 + r2) (s1 + s2) +-- | @since 9.0 instance (Num v, Num r) => Monoid (Transform v r) where   mempty = Transform 0 0 0  -- | 2D transform component.+--+-- @since 9.0 type Transform2D = Transform (V2 Int) Int  -- | Empty transform.+--+-- @since 9.0 transform2d :: Transform2D transform2d = Transform (V2 0 0) 0 (V2 1 1) +-- | @since 9.0 instance Component (Transform (V2 Int) Int)  -- | Size component.+--+-- @since 9.0 newtype Size v = Size {unSize :: v}   deriving (Generic, NFData) +-- | @since 9.0 type Size2D = Size (V2 Int) +-- | Empty size.+--+-- @since 9.0 size2D :: Size (V2 Integer) size2D = Size (V2 0 0) +-- | @since 9.0 instance Component (Size (V2 Int)) +-- | Propagate a hierarchy of transform components.+--+-- @since 9.0 propagateHierarchy :: (Component a, Monoid a) => Hierarchy a -> Hierarchy a propagateHierarchy = mapWithAccum (\_ t acc -> let t' = t <> acc in (t', t')) mempty  -- | Propagate and update all hierarchies of transform components.+--+-- @since 9.0 update ::-  forall q arr b m a.+  forall q s b m a.   ( ArrowQueryReader q,     ArrowDynamicQueryReader q,-    ArrowReaderSystem q arr,-    ArrowQueueSystem b m arr,+    MonadReaderSystem q s,     Component a,-    Monoid a+    Monoid a,+    MonadAccess b m   ) =>-  arr () ()-update = propagate @_ @_ @a >>> S.queue (mapM_ $ mapM_ (uncurry A.insert) . toList)+  s (m ())+update = mapM_ (\(e, a) -> A.insert e $ bundle a) . concatMap toList <$> propagate @_ @_ @a  -- | Propagate and update all hierarchies of transform components.-update2d :: (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr, ArrowQueueSystem b m arr) => arr () ()-update2d = propagate @_ @_ @Transform2D >>> S.queue (mapM_ $ mapM_ (uncurry A.insert) . toList)+--+-- @since 9.0+update2d ::+  ( ArrowQueryReader q,+    ArrowDynamicQueryReader q,+    MonadReaderSystem q s,+    MonadAccess b m+  ) =>+  s (m ())+update2d = update @_ @_ @_ @_ @Transform2D +-- | Propagate all hierarchies of transform components.+--+-- @since 9.0 propagate ::-  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr, Component a, Monoid a) =>-  arr () [Hierarchy a]-propagate = hierarchies Q.fetch >>> arr (map propagateHierarchy)+  ( ArrowQueryReader q,+    ArrowDynamicQueryReader q,+    MonadReaderSystem q s,+    Component a,+    Monoid a+  ) =>+  s [Hierarchy a]+propagate = do+  hs <- hierarchies () Q.fetch+  return $ map propagateHierarchy hs -propagate2d :: (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) => arr () [Hierarchy Transform2D]+-- | Propagate all hierarchies of `Transform2D` components.+--+-- @since 9.0+propagate2d ::+  ( ArrowQueryReader q,+    ArrowDynamicQueryReader q,+    MonadReaderSystem q s+  ) =>+  s [Hierarchy Transform2D] propagate2d = propagate
src/Aztecs/Window.hs view
@@ -1,17 +1,30 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +-- |+-- Module      : Aztecs.Window+-- Copyright   : (c) Matt Hunzinger, 2025+-- License     : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  : matt@hunzinger.me+-- Stability   : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.Window (Window (..)) where  import Aztecs.ECS-import Control.DeepSeq (NFData)-import GHC.Generics (Generic)+import Control.DeepSeq+import GHC.Generics  -- | Window component.-data Window = Window+--+-- @since 9.0+newtype Window = Window   { -- | Window title.-    windowTitle :: !String+    --+    -- @since 9.0+    windowTitle :: String   }   deriving (Show, Generic, NFData) +-- | @since 9.0 instance Component Window
test/Main.hs view
@@ -13,13 +13,11 @@ import Aztecs import Aztecs.ECS.Component (ComponentID (ComponentID)) import qualified Aztecs.ECS.Query as Q-import qualified Aztecs.ECS.System as S import qualified Aztecs.ECS.World as W-import Aztecs.Hierarchy (Children (..), Parent (..))-import qualified Aztecs.Hierarchy as Hierarchy-import Control.Arrow (Arrow (..), returnA, (&&&))+import Control.Arrow import Control.DeepSeq-import qualified Data.Set as Set+import Data.Functor.Identity (Identity (runIdentity))+import Data.Word import GHC.Generics import Test.Hspec import Test.QuickCheck@@ -38,18 +36,30 @@  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-  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-  describe "Aztecs.ECS.Schedule" $ do-    it "queries entities" $ property prop_scheduleQueryEntity-    it "updates components" prop_scheduleUpdate +{-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 = do+  res <- fst $ Q.all () (Q.fetch @_ @X) $ W.entities W.empty+  res `shouldMatchList` []+ -- | Query all components from a list of `ComponentID`s. queryComponentIds ::   forall q a.@@ -75,35 +85,60 @@             (e, wAcc') = W.spawn b wAcc          in ((e, cs) : acc, wAcc')       (es, w) = foldr spawn ([], W.empty) xs-      go (e, cs) =+      go (e, cs) = do         let q = queryComponentIds $ map snd cs-            (res, _) = Q.all () q $ W.entities w-         in res `shouldContain` [(e, map fst cs)]+        res <- fst $ Q.all () q $ W.entities w+        return $ res `shouldContain` [(e, map fst cs)]    in mapM_ go es  prop_queryTypedComponent :: [X] -> Expectation-prop_queryTypedComponent xs =+prop_queryTypedComponent xs = do   let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs-      (res, _) = Q.all () Q.fetch $ W.entities w-   in res `shouldMatchList` xs+  res <- fst $ Q.all () Q.fetch $ W.entities w+  res `shouldMatchList` xs  prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation-prop_queryTwoTypedComponents xys =+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-   in res `shouldMatchList` xys+  res <- fst $ Q.all () (Q.fetch &&& Q.fetch) $ W.entities w+  res `shouldMatchList` xys  prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation-prop_queryThreeTypedComponents xyzs =+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-   in res `shouldMatchList` xyzs+  res <- fst $ Q.all () q $ W.entities w+  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.fetch >>> arr (\(X x) -> X $ x + 1) >>> Q.set+      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@@ -121,7 +156,9 @@   (_, _, 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')@@ -151,3 +188,4 @@             ()       let shouldQuit = (lastShouldQuit || x > 1)   returnA -< shouldQuit+-}