aztecs 0.6.0 → 0.7.0

raw patch · 50 files changed

+1557/−953 lines, 50 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• aztecs.cabal +35/−11
• src/Aztecs.hs +7/−3
• src/Aztecs/Asset.hs +6/−136
• src/Aztecs/Asset/AssetLoader.hs +59/−0
• src/Aztecs/Asset/AssetLoader/Class.hs +19/−0
• src/Aztecs/Asset/AssetServer.hs +114/−0
• src/Aztecs/Asset/Class.hs +10/−0
• src/Aztecs/Camera.hs +7/−3
• src/Aztecs/ECS.hs +32/−7
• src/Aztecs/ECS/Access.hs +6/−2
• src/Aztecs/ECS/Access/Class.hs +7/−7
• src/Aztecs/ECS/Query.hs +27/−26
• src/Aztecs/ECS/Query/Class.hs +1/−0
• src/Aztecs/ECS/Query/Dynamic.hs +32/−38
• src/Aztecs/ECS/Query/Dynamic/Reader.hs +18/−11
• src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs +2/−2
• src/Aztecs/ECS/Query/Reader.hs +21/−37
• src/Aztecs/ECS/Query/Reader/Class.hs +1/−4
• src/Aztecs/ECS/Schedule.hs +73/−48
• src/Aztecs/ECS/Schedule/Access.hs +27/−0
• src/Aztecs/ECS/Schedule/Access/Class.hs +11/−0
• src/Aztecs/ECS/Schedule/Class.hs +10/−0
• src/Aztecs/ECS/Schedule/Dynamic.hs +44/−0
• src/Aztecs/ECS/Schedule/Dynamic/Reader.hs +45/−0
• src/Aztecs/ECS/Schedule/Reader.hs +56/−0
• src/Aztecs/ECS/Schedule/Reader/Class.hs +10/−0
• src/Aztecs/ECS/System.hs +30/−15
• src/Aztecs/ECS/System/Class.hs +0/−4
• src/Aztecs/ECS/System/Dynamic.hs +72/−22
• src/Aztecs/ECS/System/Dynamic/Class.hs +7/−66
• src/Aztecs/ECS/System/Dynamic/Reader.hs +41/−31
• src/Aztecs/ECS/System/Dynamic/Reader/Class.hs +6/−5
• src/Aztecs/ECS/System/Queue.hs +31/−0
• src/Aztecs/ECS/System/Queue/Class.hs +10/−0
• src/Aztecs/ECS/System/Reader.hs +20/−24
• src/Aztecs/ECS/View.hs +10/−10
• src/Aztecs/ECS/World.hs +29/−175
• src/Aztecs/ECS/World/Archetype.hs +16/−132
• src/Aztecs/ECS/World/Archetypes.hs +42/−95
• src/Aztecs/ECS/World/Bundle.hs +52/−0
• src/Aztecs/ECS/World/Bundle/Class.hs +11/−0
• src/Aztecs/ECS/World/Bundle/Dynamic.hs +21/−0
• src/Aztecs/ECS/World/Bundle/Dynamic/Class.hs +9/−0
• src/Aztecs/ECS/World/Entities.hs +215/−0
• src/Aztecs/ECS/World/Storage.hs +3/−3
• src/Aztecs/ECS/World/Storage/Dynamic.hs +73/−0
• src/Aztecs/Hierarchy.hs +45/−16
• src/Aztecs/Time.hs +2/−4
• src/Aztecs/Transform.hs +87/−10
• test/Main.hs +45/−6

@@ -1,23 +1,27 @@ cabal-version: 2.4 name:          aztecs-version:       0.6.0+version:       0.7.0 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me author:        Matt Hunzinger-synopsis:      A type-safe and friendly Entity-Component-System (ECS) for Haskell-description:   The Entity-Component-System (ECS) pattern is commonly used in video game develop to represent world objects.-               .-               ECS follows the principal of composition over inheritence. Each type of-               object (e.g. sword, monster, etc), in the game has a unique EntityId. Each-               entity has various Components associated with it (material, weight, damage, etc).-               Systems act on entities which have the required Components.-homepage:      https://github.com/matthunz/aztecs+homepage:      https://github.com/aztecs-hs/aztecs+synopsis:+    A modular game engine and Entity-Component-System (ECS) for Haskell.++description:+    A modular game engine and Entity-Component-System (ECS) for Haskell.+    An ECS is a modern approach to organizing your application state as a database,+    providing patterns for data-oriented design and parallel processing.+    Aztecs provides side-effect free components and systems,+    as well as backends for rendering and input (such as `aztecs-sdl`),+    allowing you to structure your game as simple function of `Input -> World -> World`.+ category:      Game Engine  source-repository head     type:     git-    location: https://github.com/matthunz/aztecs.git+    location: https://github.com/aztecs-hs/aztecs.git  library     exposed-modules:@@ -36,27 +40,47 @@         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         Aztecs.ECS.World.Archetype         Aztecs.ECS.World.Archetypes+        Aztecs.ECS.World.Bundle+        Aztecs.ECS.World.Bundle.Class+        Aztecs.ECS.World.Bundle.Dynamic+        Aztecs.ECS.World.Bundle.Dynamic.Class         Aztecs.ECS.World.Components+        Aztecs.ECS.World.Entities         Aztecs.ECS.World.Storage+        Aztecs.ECS.World.Storage.Dynamic         Aztecs.Asset+        Aztecs.Asset.AssetLoader+        Aztecs.Asset.AssetLoader.Class+        Aztecs.Asset.AssetServer+        Aztecs.Asset.Class         Aztecs.Camera         Aztecs.Hierarchy         Aztecs.Input         Aztecs.Time         Aztecs.Transform         Aztecs.Window+     hs-source-dirs:   src     default-language: Haskell2010     ghc-options:      -Wall@@ -66,7 +90,7 @@         deepseq >=1,         linear >=1,         mtl >=2,-        parallel >=3,+        parallel >=3  test-suite aztecs-test     type:             exitcode-stdio-1.0

@@ -55,8 +55,6 @@     load,     Camera (..),     CameraTarget (..),-    Transform (..),-    transform,     Key (..),     KeyboardInput (..),     isKeyPressed,@@ -64,6 +62,12 @@     wasKeyReleased,     MouseInput (..),     Time (..),+    Transform (..),+    Transform2D,+    transform2d,+    Size (..),+    Size2D,+    size2D,     Window (..),   ) where@@ -80,5 +84,5 @@     wasKeyReleased,   ) import Aztecs.Time-import Aztecs.Transform (Transform (..), transform)+import Aztecs.Transform import Aztecs.Window

@@ -1,154 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}  module Aztecs.Asset   ( AssetId (..),     AssetServer (..),-    empty,+    MonadAssetLoader (..),     Asset (..),     Handle (..),-    MonadAssetLoader (..),-    AssetLoader,-    AssetLoaderT (..),-    load,+    lookupAsset,     setup,-    loadQuery,     loadAssets,-    lookupAsset,+    load,   ) where -import Aztecs.ECS-import qualified Aztecs.ECS.Access as A-import Aztecs.ECS.Query (ArrowQuery)-import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Reader (QueryReader)-import Aztecs.ECS.System (ArrowSystem)-import qualified Aztecs.ECS.System as S-import Control.Arrow (returnA)-import Control.Concurrent (forkIO)-import Control.DeepSeq-import Control.Monad.Identity (Identity)-import Control.Monad.State.Strict (MonadState (..), StateT, runState)-import Data.Data (Typeable)-import Data.Foldable (foldrM)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import GHC.Generics (Generic)--newtype AssetId = AssetId {unAssetId :: Int}-  deriving (Eq, Ord, Show)--data AssetServer a = AssetServer-  { assetServerAssets :: !(Map AssetId a),-    loadingAssets :: !(Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))),-    nextAssetId :: !AssetId-  }-  deriving (Generic)--instance (Typeable a) => Component (AssetServer a)--instance NFData (AssetServer a) where-  rnf = rwhnf--empty :: AssetServer a-empty =-  AssetServer-    { assetServerAssets = Map.empty,-      loadingAssets = Map.empty,-      nextAssetId = AssetId 0-    }--class (Typeable a) => Asset a where-  type AssetConfig a--  loadAsset :: FilePath -> AssetConfig a -> IO a--newtype Handle a = Handle {handleId :: AssetId}-  deriving (Eq, Ord, Show)--instance NFData (Handle a) where-  rnf = rwhnf--class MonadAssetLoader a m | m -> a where-  asset :: FilePath -> AssetConfig a -> m (Handle a)--type AssetLoader a o = AssetLoaderT a Identity o--newtype AssetLoaderT a m o = AssetLoaderT {unAssetLoader :: StateT (AssetServer a) m o}-  deriving newtype (Functor, Applicative, Monad)--instance (Monad m, Asset a) => MonadAssetLoader a (AssetLoaderT a m) where-  asset path cfg = AssetLoaderT $ do-    server <- get-    let assetId = nextAssetId server-        go = do-          v <- newIORef Nothing-          _ <- forkIO $ do-            a <- loadAsset path cfg-            writeIORef v (Just a)-          return v-    put $-      server-        { loadingAssets = Map.insert assetId (Left go) (loadingAssets server),-          nextAssetId = AssetId (unAssetId assetId + 1)-        }-    return $ Handle assetId--loadQuery :: (Asset a, ArrowQuery arr) => AssetLoader a o -> arr () o-loadQuery a = proc () -> do-  assetServer <- Q.fetch -< ()-  let (o, assetServer') = runState (unAssetLoader a) assetServer-  Q.set -< assetServer'-  returnA -< o--load :: (ArrowSystem Query arr, Asset a) => AssetLoader a o -> arr () o-load a = S.mapSingle $ loadQuery a--lookupAsset :: Handle a -> AssetServer a -> Maybe a-lookupAsset h server = Map.lookup (handleId h) (assetServerAssets server)--loadAssets :: forall a. (Typeable a) => Schedule IO () ()-loadAssets = proc () -> do-  server <- reader $ S.single (Q.fetch @QueryReader @(AssetServer a)) -< ()-  server' <--    task-      ( \server ->-          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 :: forall a. (Typeable a) => System () ()-setup = S.queue . const . A.spawn_ . bundle $ empty @a+import Aztecs.Asset.AssetLoader+import Aztecs.Asset.AssetServer+import Aztecs.Asset.Class

@@ -0,0 +1,59 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.Asset.AssetLoader+  ( MonadAssetLoader (..),+    AssetLoader,+    AssetLoaderT (..),+    load,+    loadQuery,+  )+where++import Aztecs.Asset.AssetLoader.Class+import Aztecs.Asset.AssetServer (AssetId (..), AssetServer (..), Handle (..))+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 qualified Data.Map.Strict as Map++type AssetLoader a o = AssetLoaderT a Identity o++newtype AssetLoaderT a m o = AssetLoaderT {unAssetLoader :: StateT (AssetServer a) m o}+  deriving newtype (Functor, Applicative, Monad)++instance (Monad m, Asset a) => MonadAssetLoader a (AssetLoaderT a m) where+  asset path cfg = AssetLoaderT $ do+    server <- get+    let assetId = nextAssetId server+        go = do+          v <- newIORef Nothing+          _ <- forkIO $ do+            a <- loadAsset path cfg+            writeIORef v (Just a)+          return v+    put $+      server+        { loadingAssets = Map.insert assetId (Left go) (loadingAssets server),+          nextAssetId = AssetId (unAssetId assetId + 1)+        }+    return $ Handle assetId++loadQuery :: (Asset a, ArrowQuery arr) => AssetLoader a o -> arr () o+loadQuery a = proc () -> do+  assetServer <- Q.fetch -< ()+  let (o, assetServer') = runState (unAssetLoader a) assetServer+  Q.set -< assetServer'+  returnA -< o++load :: (ArrowQuery q, ArrowSystem q arr, Asset a) => AssetLoader a o -> arr () o+load a = S.mapSingle $ loadQuery a

@@ -0,0 +1,19 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.Asset.AssetLoader.Class+  ( MonadAssetLoader (..),+  )+where++import Aztecs.Asset.AssetServer (Handle)+import Aztecs.Asset.Class++class MonadAssetLoader a m | m -> a where+  asset :: FilePath -> AssetConfig a -> m (Handle a)

@@ -0,0 +1,114 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.Asset.AssetServer+  ( AssetId (..),+    AssetServer (..),+    assetServer,+    Handle (..),+    setup,+    loadAssets,+    lookupAsset,+  )+where++import Aztecs.ECS+import qualified Aztecs.ECS.Access as A+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.System as S+import Control.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 Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import GHC.Generics (Generic)++newtype AssetId = AssetId {unAssetId :: Int}+  deriving (Eq, Ord, Show)++data AssetServer a = AssetServer+  { assetServerAssets :: !(Map AssetId a),+    loadingAssets :: !(Map AssetId (Either (IO (IORef (Maybe a))) (IORef (Maybe a)))),+    nextAssetId :: !AssetId+  }+  deriving (Generic)++instance (Typeable a) => Component (AssetServer a)++instance NFData (AssetServer a) where+  rnf = rwhnf++assetServer :: AssetServer a+assetServer =+  AssetServer+    { assetServerAssets = Map.empty,+      loadingAssets = Map.empty,+      nextAssetId = AssetId 0+    }++newtype Handle a = Handle {handleId :: AssetId}+  deriving (Eq, Ord, Show)++instance NFData (Handle a) where+  rnf = rwhnf++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 :: forall a. (Typeable a) => System () ()+setup = S.queue . const . A.spawn_ . bundle $ assetServer @a

@@ -0,0 +1,10 @@+{-# LANGUAGE TypeFamilies #-}++module Aztecs.Asset.Class (Asset (..)) where++import Data.Data (Typeable)++class (Typeable a) => Asset a where+  type AssetConfig a++  loadAsset :: FilePath -> AssetConfig a -> IO a

@@ -12,9 +12,7 @@  import Aztecs.ECS import qualified Aztecs.ECS.Access as A-import Aztecs.ECS.Query.Reader (ArrowQueryReader) import qualified Aztecs.ECS.Query.Reader as Q-import Aztecs.ECS.System (ArrowReaderSystem, ArrowSystem) import qualified Aztecs.ECS.System as S import Aztecs.Window (Window) import Control.Arrow (Arrow (..))@@ -43,7 +41,13 @@ instance Component CameraTarget  -- | Add `CameraTarget` components to entities with a new `Draw` component.-addCameraTargets :: (ArrowQueryReader qr, ArrowReaderSystem qr arr, ArrowSystem q arr) => arr () ()+addCameraTargets ::+  ( ArrowQueryReader qr,+    ArrowDynamicQueryReader qr,+    ArrowReaderSystem qr arr,+    ArrowQueueSystem b m arr+  ) =>+  arr () () addCameraTargets = proc () -> do   windows <- S.all (Q.entity &&& Q.fetch @_ @Window) -< ()   newCameras <- S.filter (Q.entity &&& Q.fetch @_ @Camera) (without @CameraTarget) -< ()

@@ -53,21 +53,33 @@   ( Access,     runAccessT,     Bundle,-    bundle,+    MonoidBundle (..),+    DynamicBundle,+    MonoidDynamicBundle (..),     Component (..),     EntityID,     Query,+    ArrowQueryReader,+    ArrowQuery,+    ArrowDynamicQueryReader,+    ArrowDynamicQuery,     QueryFilter,     with,     without,     System,+    ArrowReaderSystem,+    ArrowSystem,+    ArrowQueueSystem,     Schedule,+    ArrowReaderSchedule,+    ArrowSchedule,+    ArrowAccessSchedule,     reader,     system,+    delay,     forever,     forever_,     access,-    task,     runSchedule,     runSchedule_,     World,@@ -77,18 +89,31 @@ import Aztecs.ECS.Access (Access, runAccessT) import Aztecs.ECS.Component (Component (..)) import Aztecs.ECS.Entity (EntityID)-import Aztecs.ECS.Query (Query, QueryFilter, with, without)+import Aztecs.ECS.Query+  ( ArrowDynamicQuery,+    ArrowDynamicQueryReader,+    ArrowQuery,+    ArrowQueryReader,+    Query,+    QueryFilter,+    with,+    without,+  ) import Aztecs.ECS.Schedule-  ( Schedule,+  ( ArrowAccessSchedule,+    ArrowReaderSchedule,+    ArrowSchedule,+    Schedule,     access,+    delay,     forever,     forever_,     reader,     runSchedule,     runSchedule_,     system,-    task,   )-import Aztecs.ECS.System (System)+import Aztecs.ECS.System (ArrowQueueSystem, ArrowReaderSystem, ArrowSystem, System) import Aztecs.ECS.World (World)-import Aztecs.ECS.World.Archetype (Bundle, bundle)+import Aztecs.ECS.World.Bundle (Bundle, MonoidBundle (..))+import Aztecs.ECS.World.Bundle.Dynamic (DynamicBundle, MonoidDynamicBundle (..))

@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}  module Aztecs.ECS.Access   ( Access,@@ -12,6 +14,8 @@ import Aztecs.ECS.Access.Class (MonadAccess (..)) 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 (..))@@ -21,13 +25,13 @@  -- | Access into the `World`. newtype AccessT m a = AccessT {unAccessT :: StateT World m a}-  deriving (Functor, Applicative, Monad, MonadIO)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO)  -- | Run an `Access` on a `World`, returning the output and updated `World`. runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World) runAccessT a = runStateT $ unAccessT a -instance (Monad m) => MonadAccess (AccessT m) where+instance (Monad m) => MonadAccess Bundle (AccessT m) where   spawn b = AccessT $ do     !w <- get     let !(e, w') = W.spawn b w

@@ -1,32 +1,32 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}  module Aztecs.ECS.Access.Class (MonadAccess (..)) where  import Aztecs.ECS.Component (Component (..)) import Aztecs.ECS.Entity (EntityID (..))-import Aztecs.ECS.World.Archetype (Bundle (..))-import Data.Data (Typeable)+import Aztecs.ECS.World.Bundle (MonoidBundle (..)) import Prelude hiding (all, lookup, map)  -- | Monadic access to a `World`.-class (Monad m) => MonadAccess m where+class (MonoidBundle b, Monad m) => MonadAccess b m | m -> b where   -- | Spawn an entity with a component.-  spawn :: Bundle -> m EntityID+  spawn :: b -> m EntityID    -- | Spawn an entity with a component.-  spawn_ :: Bundle -> m ()+  spawn_ :: b -> m ()   spawn_ c = do     _ <- spawn c     return ()    -- | Insert a component into an entity.-  insert :: (Component a, Typeable (StorageT a)) => EntityID -> a -> m ()+  insert :: (Component a) => EntityID -> a -> m ()    -- | Lookup a component on an entity.   lookup :: (Component a) => EntityID -> m (Maybe a)    -- | Remove a component from an entity.-  remove :: (Component a, Typeable (StorageT a)) => EntityID -> m (Maybe a)+  remove :: (Component a) => EntityID -> m (Maybe a)    -- | Despawn an entity.   despawn :: EntityID -> m ()

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -28,18 +29,18 @@  import Aztecs.ECS.Component import Aztecs.ECS.Query.Class (ArrowQuery (..))-import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))+import Aztecs.ECS.Query.Dynamic (DynamicQuery (..), fromDynReader) import Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..)) import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..))-import Aztecs.ECS.Query.Reader (QueryFilter (..), with, without)+import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReader (..), with, without) import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..))-import Aztecs.ECS.World (World (..)) 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.Components (Components) import qualified Aztecs.ECS.World.Components as CS-import Control.Arrow (Arrow (..))+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Arrow (Arrow (..), ArrowChoice (..)) import Control.Category (Category (..)) import Data.Set (Set) import qualified Data.Set as Set@@ -48,24 +49,21 @@ -- | Query for matching entities. -- -- === Do notation:--- > move :: (Monad m) => Query m () Position+-- > move :: (ArrowQuery arr) => arr () Position -- > move = proc () -> do -- >   Velocity v <- Q.fetch -< () -- >   Position p <- Q.fetch -< () -- >   Q.set -< Position $ p + v -- -- === Arrow combinators:--- > move :: (Monad m) => Query m () Position+-- > move :: (ArrowQuery arr) => arr () Position -- > move = Q.fetch &&& Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set -- -- === Applicative combinators:--- > move :: (Monad m) => Query m () Position+-- > 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)}--instance Functor (Query i) where-  fmap f (Query q) = Query $ \cs -> let (cIds, cs', qS) = q cs in (cIds, cs', fmap f qS)+newtype Query i o = Query {runQuery :: Components -> (ReadsWrites, Components, DynamicQuery i o)}+  deriving (Functor)  instance Applicative (Query i) where   pure a = Query (mempty,,pure a)@@ -85,21 +83,17 @@   arr f = Query (mempty,,arr f)   first (Query f) = Query $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', first qS) +instance ArrowChoice Query where+  left (Query f) = Query $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', left qS)+ instance ArrowQueryReader Query where-  entity = Query (mempty,,entityDyn)-  fetch :: forall a. (Component a) => Query () a-  fetch = Query $ \cs ->-    let (cId, cs') = CS.insert @a cs-     in (ReadsWrites (Set.singleton cId) Set.empty, cs', fetchDyn cId)-  fetchMaybe :: forall a. (Component a) => Query () (Maybe a)-  fetchMaybe = Query $ \cs ->-    let (cId, cs') = CS.insert @a cs-     in (ReadsWrites (Set.singleton cId) Set.empty, cs', fetchMaybeDyn cId)+  fetch = fromReader fetch+  fetchMaybe = fromReader fetchMaybe  instance ArrowDynamicQueryReader Query where-  entityDyn = Query (mempty,,entityDyn)-  fetchDyn cId = Query (ReadsWrites (Set.singleton cId) Set.empty,,fetchDyn cId)-  fetchMaybeDyn cId = Query (ReadsWrites (Set.singleton cId) Set.empty,,fetchMaybeDyn cId)+  entity = fromReader entity+  fetchDyn = fromReader . fetchDyn+  fetchMaybeDyn = fromReader . fetchMaybeDyn  instance ArrowDynamicQuery Query where   setDyn cId = Query (ReadsWrites Set.empty (Set.singleton cId),,setDyn cId)@@ -110,6 +104,11 @@     let (cId, cs') = CS.insert @a cs      in (ReadsWrites Set.empty (Set.singleton cId), cs', setDyn cId) +fromReader :: QueryReader i o -> Query i o+fromReader (QueryReader f) = Query $ \cs ->+  let (cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ)++-- | Reads and writes of a `Query`. data ReadsWrites = ReadsWrites   { reads :: !(Set ComponentID),     writes :: !(Set ComponentID)@@ -122,17 +121,19 @@ instance Monoid ReadsWrites where   mempty = ReadsWrites mempty mempty +-- | `True` if the reads and writes of two `Query`s overlap. disjoint :: ReadsWrites -> ReadsWrites -> Bool disjoint a b =   Set.disjoint (reads a) (writes b)     || Set.disjoint (reads b) (writes a)     || Set.disjoint (writes b) (writes a) -all :: Query () a -> World -> ([a], World)+-- | Match all entities.+all :: Query () a -> Entities -> ([a], Entities) all q w =   let (rws, cs', dynQ) = runQuery q (components w)       as =         fmap           (\n -> fst $ dynQueryAll dynQ (repeat ()) (A.entities $ nodeArchetype n) (nodeArchetype n))-          (AS.lookup (reads rws <> writes rws) (archetypes w))+          (AS.find (reads rws <> writes rws) (archetypes w))    in (concat as, w {components = cs'})

@@ -3,6 +3,7 @@ import Aztecs.ECS.Component import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader) +-- | Arrow for queries that can update entities. class (ArrowQueryReader arr) => ArrowQuery arr where   -- | Set a `Component` by its type.   set :: (Component a) => arr a a

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}  module Aztecs.ECS.Query.Dynamic@@ -6,6 +7,7 @@     DynamicQuery (..),     ArrowDynamicQueryReader (..),     ArrowDynamicQuery (..),+    fromDynReader,      -- * Dynamic query filters     DynamicQueryFilter (..),@@ -14,64 +16,56 @@  import Aztecs.ECS.Entity (EntityID) import Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryFilter (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryFilter (..), DynamicQueryReader (..)) import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) import Aztecs.ECS.World.Archetype (Archetype) import qualified Aztecs.ECS.World.Archetype as A-import Control.Arrow (Arrow (..))+import Control.Arrow (Arrow (..), ArrowChoice (..)) import Control.Category (Category (..))-import Prelude hiding (all, any, id, lookup, map, mapM, reads, (.))+import Data.Either (partitionEithers)+import Prelude hiding ((.))  -- | Dynamic query for components by ID. newtype DynamicQuery i o   = DynamicQuery {dynQueryAll :: [i] -> [EntityID] -> Archetype -> ([o], Archetype)}--instance Functor (DynamicQuery i) where-  fmap f q =-    DynamicQuery $ \i es arch ->-      let (a, arch') = dynQueryAll q i es arch-       in (fmap f a, arch')+  deriving (Functor)  instance Applicative (DynamicQuery i) where   pure a = DynamicQuery $ \_ es arch -> (replicate (length es) a, arch) -  f <*> g =-    DynamicQuery-      { dynQueryAll = \i es arch ->-          let (as, arch') = dynQueryAll g i es arch-              (fs, arch'') = dynQueryAll f i es arch'-           in (zipWith ($) fs as, arch'')-      }+  f <*> g = DynamicQuery $ \i es arch ->+    let (as, arch') = dynQueryAll g i es arch+        (fs, arch'') = dynQueryAll f i es arch'+     in (zipWith ($) fs as, arch'')  instance Category DynamicQuery where   id = DynamicQuery $ \as _ arch -> (as, arch) -  f . g =-    DynamicQuery-      { dynQueryAll = \i es arch ->-          let (as, arch') = dynQueryAll g i es arch-           in dynQueryAll f as es arch'-      }+  f . g = DynamicQuery $ \i es arch ->+    let (as, arch') = dynQueryAll g i es arch in dynQueryAll f as es arch'  instance Arrow DynamicQuery where   arr f = DynamicQuery $ \bs _ arch -> (fmap f bs, arch)-  first f =-    DynamicQuery-      { dynQueryAll = \bds es arch ->-          let (bs, ds) = unzip bds-              (cs, arch') = dynQueryAll f bs es arch-           in (zip cs ds, arch')-      }--instance ArrowDynamicQueryReader DynamicQuery where-  entityDyn = DynamicQuery $ \_ es arch -> (es, arch)+  first f = DynamicQuery $ \bds es arch ->+    let (bs, ds) = unzip bds+        (cs, arch') = dynQueryAll f bs es arch+     in (zip cs ds, arch') -  fetchDyn cId =-    DynamicQuery $ \_ _ arch -> let !as = A.all cId arch in (fmap snd as, arch)+instance ArrowChoice DynamicQuery where+  left f = DynamicQuery $ \eds es arch ->+    let (es', ds) = partitionEithers eds+        (cs, arch') = dynQueryAll f es' es arch+     in (fmap Left cs ++ fmap Right ds, arch') -  fetchMaybeDyn cId =-    DynamicQuery $ \_ _ arch -> let as = A.allMaybe cId arch in (fmap snd as, arch)+instance ArrowDynamicQueryReader DynamicQuery where+  entity = fromDynReader entity+  fetchDyn = fromDynReader . fetchDyn+  fetchMaybeDyn = fromDynReader . fetchMaybeDyn  instance ArrowDynamicQuery DynamicQuery where-  setDyn cId =-    DynamicQuery $ \is _ arch -> let !arch' = A.withAscList cId is arch in (is, arch')+  setDyn cId = DynamicQuery $ \is es arch ->+    let !arch' = A.insertAscList cId (zip es is) arch in (is, arch')++fromDynReader :: DynamicQueryReader i o -> DynamicQuery i o+fromDynReader q = DynamicQuery $ \is es arch ->+  let os = dynQueryReaderAll q is es arch in (os, arch)

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}  module Aztecs.ECS.Query.Dynamic.Reader@@ -16,17 +17,16 @@ import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) import Aztecs.ECS.World.Archetype (Archetype) import qualified Aztecs.ECS.World.Archetype as A-import Control.Arrow (Arrow (..))-import Control.Category (Category (..))+import qualified Aztecs.ECS.World.Storage as S+import Control.Arrow+import Control.Category+import Data.Either (partitionEithers) import Data.Set (Set)-import Prelude hiding (all, any, id, lookup, map, mapM, reads, (.))  -- | Dynamic query for components by ID. newtype DynamicQueryReader i o   = DynamicQueryReader {dynQueryReaderAll :: [i] -> [EntityID] -> Archetype -> [o]}--instance Functor (DynamicQueryReader i) where-  fmap f q = DynamicQueryReader $ \i es arch -> f <$> dynQueryReaderAll q i es arch+  deriving (Functor)  instance Applicative (DynamicQueryReader i) where   pure a = DynamicQueryReader $ \_ es _ -> replicate (length es) a@@ -49,12 +49,19 @@         cs = dynQueryReaderAll f bs es arch      in zip cs ds +instance ArrowChoice DynamicQueryReader where+  left f = DynamicQueryReader $ \eds es arch ->+    let (es', ds) = partitionEithers eds+        cs = dynQueryReaderAll f es' es arch+     in fmap Left cs ++ fmap Right ds+ instance ArrowDynamicQueryReader DynamicQueryReader where-  entityDyn = DynamicQueryReader $ \_ es _ -> es-  fetchDyn cId =-    DynamicQueryReader $ \_ _ arch -> let !as = A.all cId arch in fmap snd as-  fetchMaybeDyn cId =-    DynamicQueryReader $ \_ _ arch -> let as = A.allMaybe cId arch in fmap snd as+  entity = DynamicQueryReader $ \_ es _ -> es+  fetchDyn cId = DynamicQueryReader $ \_ _ arch ->+    let !as = maybe [] S.toList (A.lookupStorage cId arch) in fmap snd as+  fetchMaybeDyn cId = DynamicQueryReader $ \_ es arch -> case A.lookupStorage cId arch of+    Just s -> let !as = S.toList s in fmap Just $ snd <$> as+    Nothing -> map (const Nothing) es  data DynamicQueryFilter = DynamicQueryFilter   { filterWith :: !(Set ComponentID),

@@ -5,8 +5,8 @@ import Control.Arrow (Arrow (..), (>>>))  class (Arrow arr) => ArrowDynamicQueryReader arr where-  -- | Fetch the `EntityID` belonging to this entity.-  entityDyn :: arr () EntityID+  -- | Fetch the currently matched `EntityID`.+  entity :: arr () EntityID    -- | Fetch a `Component` by its `ComponentID`.   fetchDyn :: (Component a) => ComponentID -> arr () a

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -26,67 +27,50 @@ import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..)) import Aztecs.ECS.World.Components (Components) import qualified Aztecs.ECS.World.Components as CS-import Control.Arrow (Arrow (..))+import Control.Arrow (Arrow (..), ArrowChoice (..)) import Control.Category (Category (..)) import Data.Set (Set) import qualified Data.Set as Set import Prelude hiding (id, (.)) --- | Query for matching entities.------ === Do notation:--- > move :: (Monad m) => Query m () Position--- > move = proc () -> do--- >   Velocity v <- Q.fetch -< ()--- >   Position p <- Q.fetch -< ()--- >   Q.set -< Position $ p + v------ === Arrow combinators:--- > move :: (Monad m) => Query m () Position--- > move = Q.fetch &&& Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set------ === Applicative combinators:--- > move :: (Monad m) => Query m () Position--- > move = (,) <$> Q.fetch <*> Q.fetch >>> arr (\(Position p, Velocity v) -> Position $ p + v) >>> Q.set+-- | Query to read from entities. newtype QueryReader i o-  = Query {runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReader i o)}--instance Functor (QueryReader i) where-  fmap f (Query q) = Query $ \cs -> let (cIds, cs', qS) = q cs in (cIds, cs', fmap f qS)+  = QueryReader {runQueryReader :: Components -> (Set ComponentID, Components, DynamicQueryReader i o)}+  deriving (Functor)  instance Applicative (QueryReader i) where-  pure a = Query $ \cs -> (mempty, cs, pure a)-  (Query f) <*> (Query g) = Query $ \cs ->+  pure a = QueryReader $ \cs -> (mempty, cs, pure a)+  (QueryReader f) <*> (QueryReader g) = QueryReader $ \cs ->     let (cIdsG, cs', aQS) = g cs         (cIdsF, cs'', bQS) = f cs'      in (cIdsG <> cIdsF, cs'', bQS <*> aQS)  instance Category QueryReader where-  id = Query $ \cs -> (mempty, cs, id)-  (Query f) . (Query g) = Query $ \cs ->+  id = QueryReader $ \cs -> (mempty, cs, id)+  (QueryReader f) . (QueryReader g) = QueryReader $ \cs ->     let (cIdsG, cs', aQS) = g cs         (cIdsF, cs'', bQS) = f cs'      in (cIdsG <> cIdsF, cs'', bQS . aQS)  instance Arrow QueryReader where-  arr f = Query $ \cs -> (mempty, cs, arr f)-  first (Query f) = Query $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', first qS)+  arr f = QueryReader $ \cs -> (mempty, cs, arr f)+  first (QueryReader f) = QueryReader $ \comps -> let (cIds, comps', qS) = f comps 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)+ instance ArrowQueryReader QueryReader where-  entity = Query $ \cs -> (mempty, cs, entityDyn)   fetch :: forall a. (Component a) => QueryReader () a-  fetch = Query $ \cs ->-    let (cId, cs') = CS.insert @a cs-     in (Set.singleton cId, cs', fetchDyn cId)+  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)-  fetchMaybe = Query $ \cs ->-    let (cId, cs') = CS.insert @a cs-     in (Set.singleton cId, cs', fetchMaybeDyn cId)+  fetchMaybe = QueryReader $ \cs ->+    let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', fetchMaybeDyn cId)  instance ArrowDynamicQueryReader QueryReader where-  entityDyn = Query $ \cs -> (mempty, cs, entityDyn)-  fetchDyn cId = Query $ \cs -> (Set.singleton cId, cs, fetchDyn cId)-  fetchMaybeDyn cId = Query $ \cs -> (Set.singleton cId, cs, fetchMaybeDyn cId)+  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)  -- | Filter for a `Query`. newtype QueryFilter = QueryFilter {runQueryFilter :: Components -> (DynamicQueryFilter, Components)}

@@ -1,13 +1,10 @@ module Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..)) where  import Aztecs.ECS.Component-import Aztecs.ECS.Entity (EntityID) import Control.Arrow (Arrow (..), (>>>)) +-- | Arrow for queries that can read from entities. class (Arrow arr) => ArrowQueryReader arr where-  -- | Fetch the currently matched `EntityID`.-  entity :: arr () EntityID-   -- | Fetch a `Component` by its type.   fetch :: (Component a) => arr () a 

@@ -1,21 +1,27 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.Schedule   ( -- * Schedules-    Schedule (..),-    reader,-    system,+    Schedule,+    ScheduleT (..),+    ArrowReaderSchedule (..),+    ArrowSchedule (..),+    ArrowAccessSchedule (..),+    delay,     forever,     forever_,-    access,-    task,     runSchedule,     runSchedule_,   ) where  import Aztecs.ECS.Access (AccessT (..), runAccessT)+import Aztecs.ECS.Schedule.Access.Class (ArrowAccessSchedule (..))+import Aztecs.ECS.Schedule.Class (ArrowSchedule (..))+import Aztecs.ECS.Schedule.Dynamic (DynamicSchedule, DynamicScheduleT (..))+import Aztecs.ECS.Schedule.Reader.Class (ArrowReaderSchedule (..)) import Aztecs.ECS.System (System (..)) import Aztecs.ECS.System.Dynamic (DynamicSystem (..)) import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..))@@ -23,78 +29,97 @@ 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 Control.Arrow (Arrow (..))+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Arrow (Arrow (..), ArrowLoop (..)) import Control.Category (Category (..)) import Control.DeepSeq import Control.Exception (evaluate)-import Control.Monad ((>=>))+import Control.Monad.Fix import Control.Monad.Identity (Identity (runIdentity)) import Control.Monad.State (MonadState (..)) import Control.Monad.Trans (MonadTrans (..)) import Data.Functor (void)+import Prelude hiding (id, (.)) -newtype Schedule m i o = Schedule {runSchedule' :: Components -> (i -> AccessT m o, Components)}+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 (Schedule m) where-  id = Schedule $ \cs -> (return, cs)+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 (g' >=> f', cs'')+     in (f' . g', cs'') -instance Arrow (Schedule IO) where-  arr f = Schedule $ \cs -> (return Prelude.. f, cs)-  first (Schedule f) = Schedule $ \cs ->-    let (g, cs') = f cs in (\(b, d) -> (,) <$> g b <*> return d, 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') -runSchedule :: (Monad m) => Schedule m i o -> World -> i -> m (o, World)-runSchedule s w i = do-  let (f, cs) = runSchedule' s (components w)-  (o, w') <- runAccessT (f i) w {components = cs}-  return (o, w')+instance (MonadFix m) => ArrowLoop (ScheduleT m) where+  loop (Schedule f) = Schedule $ \cs -> let (f', cs') = f cs in (loop f', cs') -runSchedule_ :: (Monad m) => Schedule m () () -> m ()-runSchedule_ s = void (runSchedule s W.empty ())+instance (Monad m) => ArrowAccessSchedule Bundle (AccessT m) (Schedule m) where+  access f = Schedule $ \cs -> (accessDyn f, cs) -reader :: (Monad m) => ReaderSystem i o -> Schedule m i o-reader t = Schedule $ \cs ->-  let (dynT, _, cs') = runReaderSystem t cs-      go i = AccessT $ do-        w <- get-        return $ runReaderSystemDyn dynT w i-   in (go, cs')+instance (Monad m) => ArrowReaderSchedule ReaderSystem (Schedule m) where+  reader s = Schedule $ \cs ->+    let (dynS, _, cs') = runReaderSystem s cs+        go dynSAcc i = AccessT $ do+          w <- get+          let (o, a, dynSAcc') = runReaderSystemDyn dynSAcc (W.entities w) i+              ((), w') = runIdentity $ runAccessT a w+          put w'+          return (o, DynamicSchedule $ go dynSAcc')+     in (DynamicSchedule $ go dynS, cs') -system :: (Monad m) => System i o -> Schedule m i o-system t = Schedule $ \cs ->-  let (dynT, _, cs') = runSystem t cs-      go i = AccessT $ do-        w <- get-        let (o, v, a) = runSystemDyn dynT w i-            ((), w') = runIdentity $ runAccessT a $ V.unview v w-        put w'-        return o-   in (go, cs')+instance (Monad m) => ArrowSchedule System (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') = runIdentity $ runAccessT a w {W.entities = V.unview v (W.entities w)}+          put w'+          return (o, DynamicSchedule $ go dynSAcc')+     in (DynamicSchedule $ go dynS, cs') -access :: (Monad m) => (i -> AccessT m o) -> Schedule m i o-access f = Schedule $ \cs -> (f, cs)+delay :: (Monad m) => a -> Schedule m a a+delay d = Schedule $ \cs -> (delayDyn d, cs) -task :: (Monad m) => (i -> m o) -> Schedule m i o-task f = Schedule $ \cs -> (AccessT Prelude.. lift Prelude.. f, 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 loop wAcc = do-              (o, wAcc') <- lift $ runAccessT (g i) wAcc+        let go' gAcc wAcc = do+              ((o, g'), wAcc') <- lift $ runAccessT (runScheduleDyn gAcc i) wAcc               lift $ evaluate $ rnf wAcc'               lift $ f o-              loop wAcc'-        loop w-   in (go, cs')+              go' g' wAcc'+        go' g w+   in (DynamicSchedule go, cs')  forever_ :: Schedule IO i o -> Schedule IO i () forever_ s = forever s (const $ pure ())

@@ -0,0 +1,27 @@+{-# 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

@@ -0,0 +1,11 @@+{-# 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

@@ -0,0 +1,10 @@+{-# 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

@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecursiveDo #-}++module Aztecs.ECS.Schedule.Dynamic+  ( DynamicSchedule,+    DynamicScheduleT (..),+  )+where++import Aztecs.ECS.Access+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')

@@ -0,0 +1,45 @@+{-# 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')

@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.ECS.Schedule.Reader+  ( ReaderScheduleT (..),+  )+where++import Aztecs.ECS.Access (AccessT (..), runAccessT)+import Aztecs.ECS.Schedule.Dynamic.Reader (DynamicReaderScheduleT (..))+import Aztecs.ECS.Schedule.Reader.Class+import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..))+import Aztecs.ECS.System.Reader (ReaderSystem (..))+import Aztecs.ECS.World (World (..))+import Aztecs.ECS.World.Components (Components)+import Control.Arrow+import Control.Category+import Control.Monad.Fix+import Control.Monad.Identity (Identity (runIdentity))+import Control.Monad.State (MonadState (..))+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 ReaderSystem (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') = runIdentity $ runAccessT a w+          put w'+          return (o, DynamicReaderSchedule $ go dynSAcc')+     in (DynamicReaderSchedule $ go dynS, cs')

@@ -0,0 +1,10 @@+{-# 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

@@ -4,29 +4,34 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System-  ( -- * Systems-    System (..),+  ( System (..),     ArrowReaderSystem (..),     ArrowSystem (..),+    ArrowQueueSystem (..),+    fromReader,   ) where +import Aztecs.ECS.Access (Access) import Aztecs.ECS.Query (Query (..), QueryFilter (..), ReadsWrites (..)) import qualified Aztecs.ECS.Query as Q import Aztecs.ECS.Query.Reader (QueryReader (..), filterWith, filterWithout)-import Aztecs.ECS.System.Class (ArrowSystem (..), filterMap, map, mapSingle, map_, queue)-import Aztecs.ECS.System.Dynamic (DynamicSystem (..), raceDyn)+import Aztecs.ECS.System.Class (ArrowSystem (..))+import Aztecs.ECS.System.Dynamic (DynamicSystem (..), fromDynReaderSystem, raceDyn) import Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..)) import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))+import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))+import Aztecs.ECS.System.Reader (ReaderSystem (..)) import Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..), all, filter, single) 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 (Components)-import Control.Arrow (Arrow (..))-import Control.Category (Category (..))+import Control.Arrow+import Control.Category import qualified Data.Foldable as F-import Prelude hiding (all, filter, map, (.))-import qualified Prelude hiding (filter, map)+import Prelude hiding (all, filter, id, map, (.))+import qualified Prelude hiding (filter, id, map)  -- | System to process entities. newtype System i o = System@@ -36,24 +41,28 @@   deriving (Functor)  instance Category System where-  id = System $ \cs -> (DynamicSystem $ \_ i -> (i, mempty, pure ()), mempty, cs)+  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 Arrow System where-  arr f = System $ \cs -> (DynamicSystem $ \_ i -> (f i, mempty, pure ()), mempty, cs)+  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'-     in ( if Q.disjoint rwsA rwsB then dynF &&& dynG else raceDyn dynF dynG,-          rwsA <> rwsB,-          cs''-        )+        dynS = if Q.disjoint rwsA rwsB then dynF &&& dynG else raceDyn dynF dynG+     in (dynS, rwsA <> rwsB, cs'') +instance ArrowChoice System where+  left (System f) = System $ \cs -> let (f', rwsF, cs') = f cs in (left f', rwsF, cs')++instance ArrowLoop System where+  loop (System f) = System $ \cs -> let (f', rwsF, cs') = f cs in (loop f', rwsF, cs')+ instance ArrowReaderSystem QueryReader System where   all q = System $ \cs ->     let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, ReadsWrites rs mempty, cs')@@ -82,4 +91,10 @@   mapSingleMaybe q = System $ \cs ->     let !(rws, cs', dynQ) = runQuery q cs      in (mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')-  queue f = System $ \cs -> (queueDyn f, mempty, cs)++instance ArrowQueueSystem Bundle Access System where+  queue f = System $ \cs -> (queue f, mempty, cs)++fromReader :: ReaderSystem i o -> System i o+fromReader (ReaderSystem f) = System $ \cs ->+  let (f', rs, cs') = f cs in (fromDynReaderSystem f', ReadsWrites rs mempty, cs')

@@ -2,7 +2,6 @@  module Aztecs.ECS.System.Class (ArrowSystem (..)) where -import Aztecs.ECS.Access (Access) import Aztecs.ECS.Query.Reader (QueryFilter (..)) import Control.Arrow (Arrow (..), (>>>)) import Prelude hiding (map)@@ -23,6 +22,3 @@   mapSingle :: q i a -> arr i a    mapSingleMaybe :: q i a -> arr i (Maybe a)--  -- | Queue an `Access` to happen after this system schedule.-  queue :: (i -> Access ()) -> arr i ()

@@ -1,50 +1,100 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Aztecs.ECS.System.Dynamic (DynamicSystem (..), raceDyn) where+module Aztecs.ECS.System.Dynamic+  ( DynamicSystem (..),+    ArrowDynamicReaderSystem (..),+    ArrowDynamicSystem (..),+    ArrowQueueSystem (..),+    raceDyn,+    fromDynReaderSystem,+  )+where  import Aztecs.ECS.Access (Access)+import Aztecs.ECS.Query.Dynamic (DynamicQuery)+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader) import Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..))+import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..)) import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))-import Aztecs.ECS.View (View, filterView, readAllDyn, view)-import Aztecs.ECS.World (World (..))-import Control.Arrow (Arrow (..))-import Control.Category (Category (..))+import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))+import Aztecs.ECS.View (View)+import qualified Aztecs.ECS.View as V+import Aztecs.ECS.World.Bundle (Bundle)+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Arrow+import Control.Category import Control.Parallel (par)+import Data.Maybe (fromMaybe)+import Prelude hiding (id, (.))  newtype DynamicSystem i o = DynamicSystem   { -- | Run a dynamic system,     -- producing some output, an updated `View` into the `World`, and any queued `Access`.-    runSystemDyn :: World -> (i -> (o, View, Access ()))+    runSystemDyn :: Entities -> i -> (o, View, Access (), DynamicSystem i o)   }   deriving (Functor)  instance Category DynamicSystem where-  id = DynamicSystem $ \_ i -> (i, mempty, pure ())+  id = DynamicSystem $ \_ i -> (i, mempty, pure (), id)   DynamicSystem f . DynamicSystem g = DynamicSystem $ \w i ->-    let (b, gView, gAccess) = g w i-        (a, fView, fAccess) = f w b-     in (a, gView <> fView, gAccess >> fAccess)+    let (b, gView, gAccess, g') = g w i+        (a, fView, fAccess, f') = f w b+     in (a, gView <> fView, gAccess >> fAccess, f' . g')  instance Arrow DynamicSystem where-  arr f = DynamicSystem $ \_ i -> (f i, mempty, pure ())-  first (DynamicSystem f) = DynamicSystem $ \w (i, x) -> let (a, v, access) = f w i in ((a, x), v, access)+  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 ArrowDynamicReaderSystem DynamicSystem where-  allDyn cIds q = DynamicSystem $ \w i ->-    let v = view cIds $ archetypes w in (readAllDyn i q v, v, pure ())-  filterDyn cIds q f = DynamicSystem $ \w i ->-    let v = filterView cIds f $ archetypes w in (readAllDyn i q v, v, pure ())+instance ArrowChoice DynamicSystem 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 ArrowDynamicSystem DynamicSystem where-  runArrowSystemDyn = DynamicSystem+instance ArrowLoop DynamicSystem where+  loop (DynamicSystem f) = DynamicSystem $ \w b ->+    let ((c, d), v, access, f') = f w (b, d) in (c, v, access, loop f') +instance ArrowDynamicReaderSystem DynamicQueryReader DynamicSystem where+  allDyn cIds q = fromDynReaderSystem $ allDyn cIds q+  filterDyn cIds qf q = fromDynReaderSystem $ filterDyn cIds qf q++instance ArrowDynamicSystem DynamicQuery DynamicSystem 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 ArrowQueueSystem Bundle Access DynamicSystem where+  queue f = DynamicSystem $ \_ i -> ((), mempty, f i, queue f)+ raceDyn :: DynamicSystem i a -> DynamicSystem i b -> DynamicSystem 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) = fa-      (b, v', gAccess) = gbPar-   in ((a, b), v <> v', fAccess >> gAccess)+      (a, v, fAccess, f') = fa+      (b, v', gAccess, g') = gbPar+   in ((a, b), v <> v', fAccess >> gAccess, raceDyn f' g')++fromDynReaderSystem :: DynamicReaderSystem i o -> DynamicSystem i o+fromDynReaderSystem (DynamicReaderSystem f) = DynamicSystem $ \w i ->+  let (o, access, f') = f w i in (o, mempty, access, fromDynReaderSystem f')

@@ -1,80 +1,21 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FunctionalDependencies #-} -module Aztecs.ECS.System.Dynamic.Class-  ( ArrowDynamicSystem (..),-    DynamicSystem,-    mapDyn',-    mapSingleDyn',-    mapSingleMaybeDyn',-    filterMapDyn',-    queueDyn',-  )-where+module Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..)) where -import Aztecs.ECS.Access (Access) import Aztecs.ECS.Component (ComponentID)-import Aztecs.ECS.Query.Dynamic (DynamicQuery)-import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))-import Aztecs.ECS.View (View)-import qualified Aztecs.ECS.View as V-import Aztecs.ECS.World (World (..)) import Aztecs.ECS.World.Archetypes (Node (..))-import Data.Maybe (fromMaybe) import Data.Set (Set) -type DynamicSystem i o = World -> i -> (o, View, Access ())--class (ArrowDynamicReaderSystem arr) => ArrowDynamicSystem arr where-  runArrowSystemDyn :: DynamicSystem i o -> arr i o-+class ArrowDynamicSystem q arr | arr -> q where   -- | Map all matching entities, storing the updated entities.-  mapDyn :: Set ComponentID -> DynamicQuery i o -> arr i [o]-  mapDyn cIds q = runArrowSystemDyn $ mapDyn' cIds q+  mapDyn :: Set ComponentID -> q i o -> arr i [o] -  mapSingleDyn :: Set ComponentID -> DynamicQuery i o -> arr i o-  mapSingleDyn cIds q = runArrowSystemDyn $ mapSingleDyn' cIds q+  mapSingleDyn :: Set ComponentID -> q i o -> arr i o -  mapSingleMaybeDyn :: Set ComponentID -> DynamicQuery i o -> arr i (Maybe o)-  mapSingleMaybeDyn cIds q = runArrowSystemDyn $ mapSingleMaybeDyn' cIds q+  mapSingleMaybeDyn :: Set ComponentID -> q i o -> arr i (Maybe o)    filterMapDyn ::     Set ComponentID ->-    DynamicQuery i o ->+    q i o ->     (Node -> Bool) ->     arr i [o]-  filterMapDyn cIds q f = runArrowSystemDyn $ filterMapDyn' cIds q f--  queueDyn :: (i -> Access ()) -> arr i ()-  queueDyn f = runArrowSystemDyn $ \_ i -> ((), mempty, f i)---- | Map all matching entities, storing the updated entities.-mapDyn' :: Set ComponentID -> DynamicQuery i o -> DynamicSystem i [o]-mapDyn' cIds q w =-  let !v = V.view cIds $ archetypes w-   in \i -> let (o, v') = V.allDyn i q v in (o, v', pure ())--mapSingleDyn' :: Set ComponentID -> DynamicQuery i o -> DynamicSystem i o-mapSingleDyn' cIds q w i =-  let !(maybeO, v, access) = mapSingleMaybeDyn' cIds q w i-      !o = fromMaybe (error "Expected a single matching entity.") maybeO-   in (o, v, access)---- | Map all matching entities, storing the updated entities.-mapSingleMaybeDyn' :: Set ComponentID -> DynamicQuery i o -> DynamicSystem i (Maybe o)-mapSingleMaybeDyn' cIds q w i =-  let !res = V.viewSingle cIds $ archetypes w-   in case res of-        Just v -> let (o, v') = V.singleDyn i q v in (o, v', pure ())-        Nothing -> (Nothing, mempty, pure ())--filterMapDyn' ::-  Set ComponentID ->-  DynamicQuery i o ->-  (Node -> Bool) ->-  DynamicSystem i [o]-filterMapDyn' cIds q f w =-  let !v = V.filterView cIds f $ archetypes w-   in \i -> let (o, v') = V.allDyn i q v in (o, v', pure ())--queueDyn' :: (i -> Access ()) -> DynamicSystem i ()-queueDyn' f _ i = ((), mempty, f i)

@@ -1,60 +1,70 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System.Dynamic.Reader-  ( -- * Dynamic Systems-    DynamicReaderSystem (..),+  ( DynamicReaderSystem (..),     ArrowDynamicReaderSystem (..),+    ArrowQueueSystem (..),     raceDyn,   ) where -import Aztecs.ECS.Component (ComponentID)+import Aztecs.ECS.Access (Access) import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader) import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))+import Aztecs.ECS.System.Queue (ArrowQueueSystem (..)) import qualified Aztecs.ECS.View as V-import Aztecs.ECS.World (World (..))-import Aztecs.ECS.World.Archetypes (Node)-import Control.Arrow (Arrow (..))-import Control.Category (Category (..))+import Aztecs.ECS.World.Bundle (Bundle)+import Aztecs.ECS.World.Entities (Entities (..))+import Control.Arrow+import Control.Category import Control.Parallel (par)-import Data.Set (Set)+import Prelude hiding (id, (.))  newtype DynamicReaderSystem i o = DynamicReaderSystem   { -- | Run a dynamic system producing some output-    runReaderSystemDyn :: World -> i -> o+    runReaderSystemDyn :: Entities -> i -> (o, Access (), DynamicReaderSystem i o)   }   deriving (Functor)  instance Category DynamicReaderSystem where-  id = DynamicReaderSystem $ \_ i -> i-  DynamicReaderSystem f . DynamicReaderSystem g = DynamicReaderSystem $ \w i -> let b = g w i in f w b+  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 Arrow DynamicReaderSystem where-  arr f = DynamicReaderSystem $ \_ i -> f i-  first (DynamicReaderSystem f) = DynamicReaderSystem $ \w (i, x) -> let a = f w i in (a, x)+  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 ArrowDynamicReaderSystem DynamicReaderSystem where-  allDyn cIds q = DynamicReaderSystem $ allDyn' cIds q-  filterDyn cIds q f = DynamicReaderSystem $ filterDyn' cIds q f+instance ArrowChoice DynamicReaderSystem 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 ArrowLoop DynamicReaderSystem where+  loop (DynamicReaderSystem f) = DynamicReaderSystem $ \w b ->+    let ((c, d), access, f') = f w (b, d) in (c, access, loop f')++instance ArrowDynamicReaderSystem DynamicQueryReader DynamicReaderSystem where+  allDyn cIds q = DynamicReaderSystem $ \w i ->+    let !v = V.view cIds $ archetypes w in (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 ArrowQueueSystem Bundle Access DynamicReaderSystem where+  queue f = DynamicReaderSystem $ \_ i -> let !a = f i in ((), a, queue f)+ raceDyn :: DynamicReaderSystem i a -> DynamicReaderSystem i b -> DynamicReaderSystem 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 = fa-      b = gbPar-   in (a, b)--allDyn' :: Set ComponentID -> DynamicQueryReader i o -> World -> i -> [o]-allDyn' cIds q w = let !v = V.view cIds $ archetypes w in \i -> V.readAllDyn i q v--filterDyn' ::-  Set ComponentID ->-  DynamicQueryReader i o ->-  (Node -> Bool) ->-  World ->-  i ->-  [o]-filterDyn' cIds q f w = let !v = V.filterView cIds f $ archetypes w in \i -> V.readAllDyn i q v+      (a, fAccess, f') = fa+      (b, gAccess, g') = gbPar+   in ((a, b), fAccess >> gAccess, raceDyn f' g')

@@ -1,17 +1,18 @@+{-# LANGUAGE FunctionalDependencies #-}+ module Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..)) where  import Aztecs.ECS.Component (ComponentID)-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader) import Aztecs.ECS.World.Archetypes (Node) import Control.Arrow (Arrow (..), (>>>)) import Data.Set (Set) -class (Arrow arr) => ArrowDynamicReaderSystem arr where-  allDyn :: Set ComponentID -> DynamicQueryReader i o -> arr i [o]+class (Arrow arr) => ArrowDynamicReaderSystem q arr | arr -> q where+  allDyn :: Set ComponentID -> q i o -> arr i [o] -  filterDyn :: Set ComponentID -> DynamicQueryReader i o -> (Node -> Bool) -> arr i [o]+  filterDyn :: Set ComponentID -> q i o -> (Node -> Bool) -> arr i [o] -  singleDyn :: Set ComponentID -> DynamicQueryReader () a -> arr () a+  singleDyn :: Set ComponentID -> q () a -> arr () a   singleDyn cIds q =     allDyn cIds q       >>> arr

@@ -0,0 +1,31 @@+{-# 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)

@@ -0,0 +1,10 @@+{-# 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 ()

@@ -4,39 +4,27 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System.Reader-  ( -- * Systems-    ReaderSystem (..),-    queue,--    -- ** Queries--    -- *** Reading-    all,-    filter,-    single,--    -- *** Writing-    map,-    map_,-    filterMap,-    mapSingle,+  ( ReaderSystem (..),+    ArrowReaderSystem (..),+    ArrowQueueSystem (..),   ) where +import Aztecs.ECS.Access (Access) import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System.Class (filterMap, map, mapSingle, map_, queue) import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem, raceDyn) import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))-import Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..), all, filter, single)+import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))+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 (Arrow (..))-import Control.Category (Category (..))+import Control.Arrow+import Control.Category import qualified Data.Foldable as F import Data.Set (Set)-import Prelude hiding (all, filter, id, map, (.))-import qualified Prelude hiding (filter, id, map)+import Prelude hiding (id, (.))  -- | System to process entities. newtype ReaderSystem i o = ReaderSystem@@ -55,13 +43,18 @@ instance Arrow ReaderSystem 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')+    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 ArrowChoice ReaderSystem where+  left (ReaderSystem f) = ReaderSystem $ \cs -> let (f', rwsF, cs') = f cs in (left f', rwsF, cs')++instance ArrowLoop ReaderSystem where+  loop (ReaderSystem f) = ReaderSystem $ \cs -> let (f', rwsF, cs') = f cs in (loop f', rwsF, cs')+ instance ArrowReaderSystem QueryReader ReaderSystem where   all q = ReaderSystem $ \cs ->     let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, rs, cs')@@ -72,3 +65,6 @@           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 ArrowQueueSystem Bundle Access ReaderSystem where+  queue f = ReaderSystem $ \cs -> (queue f, mempty, cs)

@@ -19,12 +19,12 @@  import Aztecs.ECS.Query.Dynamic (DynamicQuery (..)) import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))-import Aztecs.ECS.World (World)-import qualified Aztecs.ECS.World as W import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..)) import qualified Aztecs.ECS.World.Archetypes as AS import Aztecs.ECS.World.Components (ComponentID)+import Aztecs.ECS.World.Entities (Entities)+import qualified Aztecs.ECS.World.Entities as E import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set)@@ -39,10 +39,10 @@  -- | View into all archetypes containing the provided component IDs. view :: Set ComponentID -> Archetypes -> View-view cIds as = View $ AS.lookup cIds as+view cIds as = View $ AS.find cIds as  viewSingle :: Set ComponentID -> Archetypes -> Maybe View-viewSingle cIds as = case Map.toList $ AS.lookup cIds as of+viewSingle cIds as = case Map.toList $ AS.find cIds as of   [a] -> Just . View $ Map.singleton (fst a) (snd a)   _ -> Nothing @@ -52,16 +52,16 @@   (Node -> Bool) ->   Archetypes ->   View-filterView cIds f as = View $ Map.filter f (AS.lookup cIds as)+filterView cIds f as = View $ Map.filter f (AS.find cIds as)  -- | "Un-view" a `View` back into a `World`.-unview :: View -> World -> World-unview v w =-  w-    { W.archetypes =+unview :: View -> Entities -> Entities+unview v es =+  es+    { E.archetypes =         foldl'           (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)})-          (W.archetypes w)+          (E.archetypes es)           (Map.toList $ viewArchetypes v)     } 

@@ -6,13 +6,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  module Aztecs.ECS.World   ( World (..),     empty,     spawn,-    spawnComponent,-    spawnWithId,     spawnWithArchetypeId,     spawnEmpty,     insert,@@ -25,24 +24,15 @@ where  import Aztecs.ECS.Component-  ( Component (..),-    ComponentID,-  )-import Aztecs.ECS.Entity (EntityID (..))-import Aztecs.ECS.World.Archetype (Bundle (..), DynamicBundle (..))-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..))-import qualified Aztecs.ECS.World.Archetypes as AS-import Aztecs.ECS.World.Components (Components (..))-import qualified Aztecs.ECS.World.Components as CS-import Control.DeepSeq (NFData)-import Data.Dynamic (Dynamic)+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 qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import qualified Data.Set as Set-import Data.Typeable (Proxy (..), Typeable, typeOf)-import GHC.Generics (Generic)+import GHC.Generics import Prelude hiding (lookup)  #if !MIN_VERSION_base(4,20,0)@@ -51,9 +41,7 @@  -- | World of entities and their components. data World = World-  { archetypes :: !Archetypes,-    components :: !Components,-    entities :: !(Map EntityID ArchetypeID),+  { entities :: Entities,     nextEntityId :: !EntityID   }   deriving (Show, Generic, NFData)@@ -62,184 +50,50 @@ empty :: World empty =   World-    { archetypes = AS.empty,-      components = CS.empty,-      entities = mempty,+    { entities = E.empty,       nextEntityId = EntityID 0     }  spawn :: Bundle -> World -> (EntityID, World) spawn b w =-  let (eId, w') = spawnEmpty w-      (cIds, components', dynB) = unBundle b (components w')-   in case AS.lookupArchetypeId cIds (archetypes w') of-        Just aId -> fromMaybe (eId, w') $ do-          node <- AS.lookupNode aId (archetypes w')-          let arch' = runDynamicBundle dynB eId (nodeArchetype node)-          return-            ( eId,-              w'-                { archetypes = (archetypes w') {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},-                  components = components',-                  entities = Map.insert eId aId (entities w')-                }-            )-        Nothing ->-          let arch' = runDynamicBundle dynB eId A.empty-              (aId, arches) =-                AS.insertArchetype-                  cIds-                  ( Node-                      { nodeComponentIds = cIds,-                        nodeArchetype = arch',-                        nodeAdd = Map.empty,-                        nodeRemove = Map.empty-                      }-                  )-                  (archetypes w')-           in ( eId,-                w'-                  { archetypes = arches,-                    entities = Map.insert eId aId (entities w'),-                    components = components'-                  }-              )---- | Spawn an entity with a component.-spawnComponent :: forall a. (Component a, Typeable (StorageT a)) => a -> World -> (EntityID, World)-spawnComponent c w = case Map.lookup (typeOf (Proxy @a)) (componentIds (components w)) of-  Just cId -> spawnWithId cId c w-  Nothing ->-    let (cId, cs) = CS.insert @a (components w)-     in spawnWithId cId c w {components = cs}+  let e = nextEntityId w+   in (e, w {entities = E.spawn e b $ entities w, nextEntityId = EntityID $ unEntityId e + 1})  -- | Spawn an empty entity. 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`.-spawnWithId ::-  forall a.-  (Component a, Typeable (StorageT a)) =>-  ComponentID ->-  a ->-  World ->-  (EntityID, World)-spawnWithId cId c w =-  let !(e, w') = spawnEmpty w-   in case AS.lookupArchetypeId (Set.singleton cId) (archetypes w) of-        Just aId -> (e, 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 (e, w' {archetypes = arches, entities = Map.insert e aId (entities w)})+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, Typeable (StorageT a)) =>-  a ->-  ComponentID ->-  ArchetypeID ->-  World ->-  (EntityID, World)-spawnWithArchetypeId c cId aId w =-  let !(e, w') = spawnEmpty w-   in (e, spawnWithArchetypeId' e aId cId c w')--spawnWithArchetypeId' ::-  forall a.-  (Component a, Typeable (StorageT a)) =>-  EntityID ->+  (Component a) =>   ArchetypeID ->   ComponentID ->   a ->   World ->-  World-spawnWithArchetypeId' e aId cId c w =-  let f n = n {nodeArchetype = A.insertComponent e cId c (nodeArchetype n)}-   in w-        { archetypes = (archetypes w) {AS.nodes = Map.adjust f aId (AS.nodes $ archetypes w)},-          entities = Map.insert e aId (entities w)-        }+  (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, Typeable (StorageT a)) => EntityID -> a -> World -> World-insert e c w =-  let !(cId, components') = CS.insert @a (components w)-   in insertWithId e cId c w {components = components'}+insert :: forall a. (Component a) => EntityID -> a -> 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, Typeable (StorageT a)) => EntityID -> ComponentID -> a -> World -> World-insertWithId e cId c w = case Map.lookup e (entities w) of-  Just aId ->-    let (maybeNextAId, arches) = AS.insert e aId cId c $ 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 ->-      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)}+insertWithId :: (Component a) => EntityID -> ComponentID -> a -> World -> World+insertWithId e cId c w = w {entities = E.insertWithId e cId c (entities w)}  lookup :: forall a. (Component a) => EntityID -> World -> Maybe a-lookup e w = do-  !cId <- CS.lookup @a (components w)-  !aId <- Map.lookup e (entities w)-  !node <- AS.lookupNode aId (archetypes w)-  A.lookupComponent e cId (nodeArchetype node)+lookup e w = E.lookup e $ entities w  -- | Insert a component into an entity.-remove :: forall a. (Component a, Typeable (StorageT a)) => EntityID -> World -> (Maybe a, World)-remove e w =-  let !(cId, components') = CS.insert @a (components w)-   in removeWithId @a e cId w {components = components'}+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}) -removeWithId :: forall a. (Component a, Typeable (StorageT a)) => EntityID -> ComponentID -> World -> (Maybe a, World)-removeWithId e cId w = case Map.lookup e (entities w) of-  Just aId ->-    let (res, as) = AS.remove @a e aId cId $ archetypes w-        (maybeA, es) = case res of-          Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w))-          Nothing -> (Nothing, entities w)-     in (maybeA, w {archetypes = as, entities = es})-  Nothing -> (Nothing, w)+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 e w =-  let res = do-        !aId <- Map.lookup e (entities w)-        !node <- AS.lookupNode aId (archetypes w)-        return (aId, node)-   in case res of-        Just (aId, node) ->-          let !(dynAcc, arch') = A.remove e (nodeArchetype node)-           in ( dynAcc,-                w-                  { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},-                    entities = Map.delete e (entities w)-                  }-              )-        Nothing -> (Map.empty, w)+despawn e w = let (a, es) = E.despawn e (entities w) in (a, w {entities = es})

@@ -15,8 +15,6 @@ module Aztecs.ECS.World.Archetype   ( Archetype (..),     empty,-    all,-    allMaybe,     entities,     lookupComponent,     lookupStorage,@@ -25,76 +23,24 @@     removeStorages,     insertComponent,     insertAscList,-    withAscList,-    Bundle (..),-    bundle,-    runBundle,-    DynamicBundle (..),-    dynBundle,-    AnyStorage (..),-    anyStorage,   ) where -import Aztecs.ECS.Component (Component (..), ComponentID)-import Aztecs.ECS.Entity (EntityID (..))-import Aztecs.ECS.World.Components (Components)-import qualified Aztecs.ECS.World.Components as CS+import Aztecs.ECS.Component+import Aztecs.ECS.Entity import qualified Aztecs.ECS.World.Storage as S+import Aztecs.ECS.World.Storage.Dynamic import Control.DeepSeq-import Data.Bifunctor (Bifunctor (..))-import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)+import Data.Dynamic import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Generics (Generic)-import Prelude hiding (all, lookup)+import GHC.Generics  #if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') #endif -data AnyStorage = AnyStorage-  { storageDyn :: !Dynamic,-    insertDyn :: !(Int -> Dynamic -> Dynamic -> Dynamic),-    removeDyn :: !(Int -> Dynamic -> (Maybe Dynamic, Dynamic)),-    removeAny :: !(Int -> Dynamic -> (Maybe AnyStorage, Dynamic)),-    entitiesDyn :: !(Dynamic -> [Int]),-    storageRnf :: !(Dynamic -> ())-  }--instance Show AnyStorage where-  show s = "AnyStorage " ++ show (storageDyn s)--instance NFData AnyStorage where-  rnf s = storageRnf s (storageDyn s)--anyStorage :: forall s a. (S.Storage s a) => s a -> AnyStorage-anyStorage s =-  AnyStorage-    { storageDyn = toDyn s,-      insertDyn = \i cDyn sDyn ->-        fromMaybe sDyn $ do-          !s' <- fromDynamic @(s a) sDyn-          !c <- fromDynamic cDyn-          return . toDyn $ S.insert i c s',-      removeDyn = \i dyn -> case fromDynamic @(s a) dyn of-        Just s' -> let !(a, b) = S.remove i s' in (fmap toDyn a, toDyn b)-        Nothing -> (Nothing, dyn),-      removeAny = \i dyn -> case fromDynamic @(s a) dyn of-        Just s' -> let !(a, b) = S.remove i s' in (fmap (anyStorage . S.singleton @s i) a, toDyn b)-        Nothing -> (Nothing, dyn),-      entitiesDyn = \dyn -> case fromDynamic @(s a) dyn of-        Just s' -> map fst $ S.all s'-        Nothing -> [],-      storageRnf = \dyn -> case fromDynamic @(s a) dyn of-        Just s' -> rnf s'-        Nothing -> ()-    }--newtype Archetype = Archetype {storages :: Map ComponentID AnyStorage}+newtype Archetype = Archetype {storages :: Map ComponentID DynamicStorage}   deriving (Show, Generic, NFData)  empty :: Archetype@@ -110,109 +56,47 @@   let !storage = case lookupStorage cId arch of         Just s -> S.insert (unEntityId e) c s         Nothing -> S.singleton @(StorageT a) @a (unEntityId e) c-   in arch {storages = Map.insert cId (anyStorage storage) (storages arch)}--all :: (Component a) => ComponentID -> Archetype -> [(EntityID, a)]-all cId arch = fromMaybe [] $ do-  s <- lookupStorage cId arch-  return . map (first EntityID) $ S.all s+   in arch {storages = Map.insert cId (dynStorage storage) (storages arch)}  member :: ComponentID -> Archetype -> Bool member cId arch = Map.member cId (storages arch) -allMaybe :: (Component a) => ComponentID -> Archetype -> [(EntityID, Maybe a)]-allMaybe cId arch = case lookupStorage cId arch of-  Just s -> map (\(i, a) -> (EntityID i, Just a)) $ S.all s-  Nothing -> case Map.toList $ storages arch of-    [] -> []-    (_, s) : _ -> map (\i -> (EntityID i, Nothing)) $ entitiesDyn s (storageDyn s)- entities :: Archetype -> [EntityID] entities arch = case Map.toList $ storages arch of   [] -> []-  (_, s) : _ -> map (\i -> (EntityID i)) $ entitiesDyn s (storageDyn s)+  (_, s) : _ -> map (\i -> (EntityID i)) $ entitiesDyn s  lookupComponent :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a lookupComponent e cId w = lookupStorage cId w >>= S.lookup (unEntityId e) +-- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`. insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype insertAscList cId as arch =-  let !storages' =-        Map.insert-          cId-          (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as))-          (storages arch)-   in arch {storages = storages'}--withAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype-withAscList cId as arch =-  let !storages' =-        Map.adjust-          ( \s ->-              (anyStorage $ S.fromAscList @(StorageT a) (zip (entitiesDyn s (storageDyn s)) as))-          )-          cId-          (storages arch)-   in arch {storages = storages'}+  let !storage = dynStorage $ S.fromAscList @(StorageT a) (map (\(e, a) -> (unEntityId e, a)) as)+   in arch {storages = Map.insert cId storage (storages arch)}  remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype) remove e arch =   foldl'     ( \(dynAcc, archAcc) (cId, s) ->-        let !(dynA, dynS) = removeDyn s (unEntityId e) (storageDyn s)+        let !(dynA, dynS) = removeDyn (unEntityId e) s             !dynAcc' = case dynA of               Just d -> Map.insert cId d dynAcc               Nothing -> dynAcc-         in ( dynAcc',-              archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}-            )+         in (dynAcc', archAcc {storages = Map.insert cId dynS $ storages archAcc})     )     (Map.empty, arch)     (Map.toList $ storages arch) -removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)+removeStorages :: EntityID -> Archetype -> (Map ComponentID DynamicStorage, Archetype) removeStorages e arch =   foldl'     ( \(dynAcc, archAcc) (cId, s) ->-        let (dynA, dynS) = removeAny s (unEntityId e) (storageDyn s)+        let (dynA, dynS) = removeAny (unEntityId e) s             dynAcc' = case dynA of               Just d -> Map.insert cId d dynAcc               Nothing -> dynAcc-         in ( dynAcc',-              archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}-            )+         in (dynAcc', archAcc {storages = Map.insert cId dynS $ storages archAcc})     )     (Map.empty, arch)     (Map.toList $ storages arch)--newtype Bundle = Bundle {unBundle :: Components -> (Set ComponentID, Components, DynamicBundle)}--instance Monoid Bundle where-  mempty = Bundle $ \cs -> (Set.empty, cs, mempty)--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)--bundle :: forall a. (Component a, Typeable (StorageT a)) => a -> Bundle-bundle a = Bundle $ \cs ->-  let (cId, cs') = CS.insert @a cs in (Set.singleton cId, cs', dynBundle cId a)--newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}--instance Semigroup DynamicBundle where-  DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch)--instance Monoid DynamicBundle where-  mempty = DynamicBundle $ \_ arch -> arch--dynBundle :: (Component a, Typeable (StorageT a)) => ComponentID -> a -> DynamicBundle-dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch--runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype)-runBundle b cs eId arch =-  let !(_, cs', d) = unBundle b cs-      !arch' = runDynamicBundle d eId arch-   in (cs', arch')

@@ -20,8 +20,8 @@     insertArchetype,     lookupArchetypeId,     findArchetypeIds,-    lookupNode,     lookup,+    find,     map,     adjustArchetype,     insert,@@ -32,14 +32,13 @@ import Aztecs.ECS.Component (Component (..), ComponentID) import Aztecs.ECS.Entity (EntityID (..)) import Aztecs.ECS.World.Archetype-  ( AnyStorage (..),-    Archetype (..),+  ( Archetype (..),     insertComponent,     removeStorages,   ) import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Storage.Dynamic (insertDyn, removeDyn) import Control.DeepSeq (NFData (..))-import Data.Data (Typeable) import Data.Dynamic (fromDynamic) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -116,73 +115,53 @@   [] -> Set.empty  -- | Lookup `Archetype`s containing a set of `ComponentID`s.-lookup :: Set ComponentID -> Archetypes -> Map ArchetypeID Node-lookup cIds arches =-  Map.fromSet-    (\aId -> nodes arches Map.! aId)-    (findArchetypeIds cIds arches)+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. map :: Set ComponentID -> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes) map cIds f arches =-  foldl'-    ( \(acc, archAcc) aId ->+  let go (acc, archAcc) aId =         let !node = nodes archAcc Map.! aId             !(a, arch') = f (nodeArchetype node)-         in (a : acc, archAcc {nodes = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc)})-    )-    ([], arches)-    (findArchetypeIds cIds arches)+            nodes' = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc)+         in (a : acc, archAcc {nodes = nodes'})+   in foldl' go ([], arches) $ findArchetypeIds cIds arches  lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID lookupArchetypeId cIds arches = Map.lookup cIds (archetypeIds arches) -lookupNode :: ArchetypeID -> Archetypes -> Maybe Node-lookupNode aId arches = Map.lookup aId (nodes arches)+lookup :: ArchetypeID -> Archetypes -> Maybe Node+lookup aId arches = Map.lookup aId (nodes arches)  -- | Insert a component into an entity with its `ComponentID`. insert ::-  (Component a, Typeable (StorageT a)) =>+  (Component a) =>   EntityID ->   ArchetypeID ->   ComponentID ->   a ->   Archetypes ->   (Maybe ArchetypeID, Archetypes)-insert e aId cId c arches = case lookupNode aId arches of+insert e aId cId c arches = case lookup aId arches of   Just node ->     if Set.member cId (nodeComponentIds node)-      then (Nothing, arches {nodes = Map.adjust (\n -> n {nodeArchetype = insertComponent e cId c (nodeArchetype n)}) aId (nodes arches)})+      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         Just nextAId ->           let !(cs, arch') = A.remove e (nodeArchetype node)-              !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}+              node' = node {nodeArchetype = arch'}+              !arches' = arches {nodes = Map.insert aId node' (nodes arches)}               f archAcc (itemCId, dyn) =-                archAcc-                  { storages =-                      Map.adjust-                        (\s -> s {storageDyn = insertDyn s (unEntityId e) dyn (storageDyn s)})-                        itemCId-                        (storages archAcc)-                  }-           in ( Just nextAId,-                arches'-                  { nodes =-                      Map.adjust-                        ( \nextNode ->-                            nextNode-                              { nodeArchetype =-                                  insertComponent e cId c $-                                    foldl'-                                      f-                                      (nodeArchetype nextNode)-                                      (Map.toList cs)-                              }-                        )-                        nextAId-                        (nodes $ arches')-                  }-              )+                let go s = insertDyn (unEntityId e) dyn s+                    storages' = Map.adjust go itemCId (storages archAcc)+                 in archAcc {storages = storages'}+              adjustNode nextNode =+                let nextArch = foldl' f (nodeArchetype nextNode) (Map.toList cs)+                 in nextNode {nodeArchetype = insertComponent e cId c nextArch}+           in (Just nextAId, arches' {nodes = Map.adjust adjustNode nextAId (nodes $ arches')})         Nothing ->           let !(s, arch') = removeStorages e (nodeArchetype node)               !n =@@ -192,58 +171,34 @@                     nodeAdd = Map.empty,                     nodeRemove = Map.singleton cId aId                   }-              !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches-           in ( Just nextAId,-                arches'-                  { nodes =-                      Map.insert-                        aId-                        node-                          { nodeArchetype = arch',-                            nodeAdd = Map.insert cId nextAId (nodeAdd node)-                          }-                        (nodes arches')-                  }-              )+              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 (Just nextAId, arches' {nodes = nodes'})   Nothing -> (Nothing, arches)  remove ::-  (Component a, Typeable (StorageT a)) =>+  (Component a) =>   EntityID ->   ArchetypeID ->   ComponentID ->   Archetypes ->   (Maybe (a, ArchetypeID), Archetypes)-remove e aId cId arches = case lookupNode aId arches of+remove e aId cId arches = case lookup aId arches of   Just node -> case lookupArchetypeId (Set.delete cId (nodeComponentIds node)) arches of     Just nextAId ->       let !(cs, arch') = A.remove e (nodeArchetype node)           !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}-          f archAcc (itemCId, dyn) =-            archAcc-              { storages =-                  Map.adjust-                    (\s -> s {storageDyn = insertDyn s (unEntityId e) dyn (storageDyn s)})-                    itemCId-                    (storages archAcc)-              }           (a, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) cId cs+          go' archAcc (itemCId, dyn) =+            let adjustStorage s = insertDyn (unEntityId e) dyn s+             in archAcc {storages = Map.adjust adjustStorage itemCId (storages archAcc)}+          go nextNode =+            nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (Map.toList cs')}        in ( (,nextAId) <$> (a >>= fromDynamic),-            arches'-              { nodes =-                  Map.adjust-                    ( \nextNode ->-                        nextNode-                          { nodeArchetype =-                              foldl'-                                f-                                (nodeArchetype nextNode)-                                (Map.toList cs')-                          }-                    )-                    nextAId-                    (nodes $ arches')-              }+            arches' {nodes = Map.adjust go nextAId (nodes $ arches')}           )     Nothing ->       let !(cs, arch') = removeStorages e (nodeArchetype node)@@ -256,16 +211,8 @@                 nodeRemove = Map.singleton cId aId               }           !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches-       in ( (,nextAId) <$> (a >>= (\a' -> (fst $ A.removeDyn a' (unEntityId e) (A.storageDyn a')) >>= fromDynamic)),-            arches'-              { nodes =-                  Map.insert-                    aId-                    node-                      { nodeArchetype = arch',-                        nodeAdd = Map.insert cId nextAId (nodeAdd node)-                      }-                    (nodes arches')-              }+          node' = node {nodeArchetype = arch', nodeAdd = Map.insert cId nextAId (nodeAdd node)}+       in ( (,nextAId) <$> (a >>= (\a' -> (fst $ removeDyn (unEntityId e) a') >>= fromDynamic)),+            arches' {nodes = Map.insert aId node' (nodes arches')}           )   Nothing -> (Nothing, arches)

@@ -0,0 +1,52 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.World.Bundle+  ( Bundle (..),+    MonoidBundle (..),+    MonoidDynamicBundle (..),+    runBundle,+  )+where++import Aztecs.ECS.Component (Component (..), ComponentID)+import Aztecs.ECS.Entity (EntityID)+import Aztecs.ECS.World.Archetype (Archetype)+import Aztecs.ECS.World.Bundle.Class+import Aztecs.ECS.World.Bundle.Dynamic+import Aztecs.ECS.World.Components (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)}++instance Monoid Bundle where+  mempty = Bundle $ \cs -> (Set.empty, cs, mempty)++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)++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)++instance MonoidDynamicBundle Bundle where+  dynBundle cId c = Bundle $ \cs -> (Set.singleton cId, cs, dynBundle cId c)++-- | Insert a bundle of components into an archetype.+runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype)+runBundle b cs eId arch =+  let !(_, cs', d) = unBundle b cs+      !arch' = runDynamicBundle d eId arch+   in (cs', arch')

@@ -0,0 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Aztecs.ECS.World.Bundle.Class (MonoidBundle (..)) where++import Aztecs.ECS.Component (Component (..))++-- | Monoid bundle of components.+class (Monoid a) => MonoidBundle a where+  -- | Add a component to the bundle.+  bundle :: forall c. (Component c) => c -> a

@@ -0,0 +1,21 @@+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 (..))++-- | Dynamic bundle of components.+newtype DynamicBundle = DynamicBundle {runDynamicBundle :: EntityID -> Archetype -> Archetype}++instance Semigroup DynamicBundle where+  DynamicBundle d1 <> DynamicBundle d2 = DynamicBundle $ \eId arch -> d2 eId (d1 eId arch)++instance Monoid DynamicBundle where+  mempty = DynamicBundle $ \_ arch -> arch++instance MonoidDynamicBundle DynamicBundle where+  dynBundle cId a = DynamicBundle $ \eId arch -> insertComponent eId cId a arch

@@ -0,0 +1,9 @@+module Aztecs.ECS.World.Bundle.Dynamic.Class (MonoidDynamicBundle (..)) where++import Aztecs.ECS.Component (Component (..))+import Aztecs.ECS.World.Components (ComponentID)++-- | Monoid bundle of dynamic components.+class MonoidDynamicBundle a where+  -- | Add a component to the bundle by its `ComponentID`.+  dynBundle :: (Component c) => ComponentID -> c -> a

@@ -0,0 +1,215 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.World.Entities+  ( Entities (..),+    empty,+    spawn,+    spawnComponent,+    spawnWithId,+    spawnWithArchetypeId,+    insert,+    insertWithId,+    lookup,+    remove,+    removeWithId,+    despawn,+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..))+import qualified Aztecs.ECS.World.Archetypes as AS+import Aztecs.ECS.World.Bundle+import Aztecs.ECS.World.Bundle.Dynamic+import Aztecs.ECS.World.Components (Components (..))+import qualified Aztecs.ECS.World.Components as CS+import Control.DeepSeq+import Data.Dynamic+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.Typeable+import GHC.Generics+import Prelude hiding (lookup)++#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif++-- | World of entities and their components.+data Entities = Entities+  { archetypes :: !Archetypes,+    components :: !Components,+    entities :: !(Map EntityID ArchetypeID)+  }+  deriving (Show, Generic, NFData)++-- | Empty `World`.+empty :: Entities+empty =+  Entities+    { archetypes = AS.empty,+      components = CS.empty,+      entities = mempty+    }++spawn :: EntityID -> Bundle -> Entities -> Entities+spawn eId b w =+  let (cIds, components', dynB) = unBundle b (components w)+   in case AS.lookupArchetypeId cIds (archetypes w) of+        Just aId -> fromMaybe w $ do+          node <- AS.lookup aId $ archetypes w+          let arch' = runDynamicBundle dynB eId (nodeArchetype node)+          return+            w+              { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},+                components = components',+                entities = Map.insert eId aId (entities w)+              }+        Nothing ->+          let arch' = runDynamicBundle dynB eId A.empty+              (aId, arches) =+                AS.insertArchetype+                  cIds+                  ( Node+                      { nodeComponentIds = cIds,+                        nodeArchetype = arch',+                        nodeAdd = Map.empty,+                        nodeRemove = Map.empty+                      }+                  )+                  (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)}++spawnWithArchetypeId ::+  forall a.+  (Component a) =>+  EntityID ->+  ArchetypeID ->+  ComponentID ->+  a ->+  Entities ->+  Entities+spawnWithArchetypeId e aId cId c w =+  let f n = n {nodeArchetype = A.insertComponent e cId c (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'}++-- | 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+  Just aId ->+    let (maybeNextAId, arches) = AS.insert e aId cId c $ 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 ->+      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)}++lookup :: forall a. (Component a) => EntityID -> Entities -> Maybe a+lookup e w = do+  !cId <- CS.lookup @a $ components w+  !aId <- Map.lookup e $ entities w+  !node <- AS.lookup aId $ archetypes w+  A.lookupComponent e cId $ nodeArchetype node++-- | Insert a component into an entity.+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'}++removeWithId :: forall a. (Component a) => EntityID -> ComponentID -> Entities -> (Maybe a, Entities)+removeWithId e cId w = case Map.lookup e (entities w) of+  Just aId ->+    let (res, as) = AS.remove @a e aId cId $ archetypes w+        (maybeA, es) = case res of+          Just (a, nextAId) -> (Just a, Map.insert e nextAId (entities w))+          Nothing -> (Nothing, entities w)+     in (maybeA, w {archetypes = as, entities = es})+  Nothing -> (Nothing, w)++-- | Despawn an entity, returning its components.+despawn :: EntityID -> Entities -> (Map ComponentID Dynamic, Entities)+despawn e w =+  let res = do+        !aId <- Map.lookup e $ entities w+        !node <- AS.lookup aId $ archetypes w+        return (aId, node)+   in case res of+        Just (aId, node) ->+          let !(dynAcc, arch') = A.remove e (nodeArchetype node)+           in ( dynAcc,+                w+                  { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},+                    entities = Map.delete e (entities w)+                  }+              )+        Nothing -> (Map.empty, w)

@@ -14,8 +14,8 @@   -- | Storage with a single component.   singleton :: Int -> a -> s a -  -- | All components in the storage.-  all :: s a -> [(Int, a)]+  -- | List of all components in the storage.+  toList :: s a -> [(Int, a)]    -- | Insert a component into the storage.   insert :: Int -> a -> s a -> s a@@ -31,7 +31,7 @@  instance (Typeable a, NFData a) => Storage IntMap a where   singleton = IntMap.singleton-  all = IntMap.toList+  toList = IntMap.toList   insert = IntMap.insert   lookup = IntMap.lookup   fromAscList = IntMap.fromAscList

@@ -0,0 +1,73 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.World.Storage.Dynamic+  ( DynamicStorage (..),+    dynStorage,+    insertDyn,+    removeDyn,+    removeAny,+    entitiesDyn,+  )+where++import qualified Aztecs.ECS.World.Storage as S+import Control.DeepSeq+import Data.Dynamic+import Data.Maybe++data DynamicStorage = DynamicStorage+  { storageDyn :: !Dynamic,+    insertDyn' :: !(Int -> Dynamic -> Dynamic -> Dynamic),+    removeDyn' :: !(Int -> Dynamic -> (Maybe Dynamic, Dynamic)),+    removeAny' :: !(Int -> Dynamic -> (Maybe DynamicStorage, Dynamic)),+    entitiesDyn' :: !(Dynamic -> [Int]),+    storageRnf :: !(Dynamic -> ())+  }++instance Show DynamicStorage where+  show s = "DynamicStorage " ++ show (storageDyn s)++instance NFData DynamicStorage where+  rnf s = storageRnf s (storageDyn s)++dynStorage :: forall s a. (S.Storage s a) => s a -> DynamicStorage+dynStorage s =+  DynamicStorage+    { storageDyn = toDyn s,+      insertDyn' = \i cDyn sDyn ->+        fromMaybe sDyn $ do+          !s' <- fromDynamic @(s a) sDyn+          !c <- fromDynamic cDyn+          return . toDyn $ S.insert i c s',+      removeDyn' = \i dyn -> case fromDynamic @(s a) dyn of+        Just s' -> let !(a, b) = S.remove i s' in (fmap toDyn a, toDyn b)+        Nothing -> (Nothing, dyn),+      removeAny' = \i dyn -> case fromDynamic @(s a) dyn of+        Just s' -> let !(a, b) = S.remove i s' in (fmap (dynStorage . S.singleton @s i) a, toDyn b)+        Nothing -> (Nothing, dyn),+      entitiesDyn' = \dyn -> case fromDynamic @(s a) dyn of+        Just s' -> map fst $ S.toList s'+        Nothing -> [],+      storageRnf = \dyn -> maybe () rnf (fromDynamic @(s a) dyn)+    }++insertDyn :: Int -> Dynamic -> DynamicStorage -> DynamicStorage+insertDyn i c s = s {storageDyn = insertDyn' s i c (storageDyn s)}++removeDyn :: Int -> DynamicStorage -> (Maybe Dynamic, DynamicStorage)+removeDyn i s = let (a, s') = removeDyn' s i (storageDyn s) in (a, s {storageDyn = s'})++removeAny :: Int -> DynamicStorage -> (Maybe DynamicStorage, DynamicStorage)+removeAny i s = let (a, s') = removeAny' s i (storageDyn s) in (a, s {storageDyn = s'})++entitiesDyn :: DynamicStorage -> [Int]+entitiesDyn s = entitiesDyn' s (storageDyn s)

@@ -1,5 +1,7 @@ {-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -8,6 +10,10 @@     Children (..),     update,     Hierarchy (..),+    toList,+    foldWithKey,+    mapWithKey,+    mapWithAccum,     hierarchy,     hierarchies,     ParentState (..),@@ -15,18 +21,16 @@   ) where -import Aztecs+import Aztecs.ECS import qualified Aztecs.ECS.Access as A-import Aztecs.ECS.Query (ArrowQuery) import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Reader (ArrowQueryReader)-import Aztecs.ECS.System (ArrowReaderSystem, ArrowSystem) import qualified Aztecs.ECS.System as S import Control.Arrow (returnA) import Control.DeepSeq import Control.Monad (when) import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic)@@ -52,7 +56,11 @@ instance Component ChildState  update ::-  (ArrowQueryReader qr, ArrowQuery q, ArrowReaderSystem qr arr, ArrowSystem q arr) =>+  ( ArrowQueryReader qr,+    ArrowDynamicQueryReader qr,+    ArrowReaderSystem qr arr,+    ArrowQueueSystem b m arr+  ) =>   arr () () update = proc () -> do   parents <-@@ -106,8 +114,9 @@                 when (children /= childState) $ do                   A.insert entity $ ChildState children                   let added = Set.difference children childState-                  -- TODO removed = Set.difference childState children+                      removed = Set.difference childState children                   mapM_ (\e -> A.insert e . Parent $ entity) added+                  mapM_ (A.remove @_ @_ @Parent) removed               Nothing -> do                 A.insert entity $ ChildState children                 mapM_ (\e -> A.insert e . Parent $ entity) children@@ -122,12 +131,32 @@     nodeEntity :: a,     nodeChildren :: [Hierarchy a]   }+  deriving (Functor) +instance Foldable Hierarchy where+  foldMap f n = f (nodeEntity n) <> foldMap (foldMap f) (nodeChildren n)++instance Traversable Hierarchy where+  traverse f n = Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n)++toList :: Hierarchy a -> [(EntityID, a)]+toList n = (nodeEntityId n, nodeEntity n) : concatMap toList (nodeChildren n)++foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b+foldWithKey f n b = f (nodeEntityId n) (nodeEntity n) (foldr (foldWithKey f) b (nodeChildren n))++mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b+mapWithKey f n = Node (nodeEntityId n) (f (nodeEntityId n) (nodeEntity n)) (map (mapWithKey f) (nodeChildren n))++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))+ hierarchy ::-  (ArrowQueryReader q, ArrowReaderSystem q arr) =>+  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>   EntityID ->   q i a ->-  arr i [Hierarchy a]+  arr i (Maybe (Hierarchy a)) hierarchy e q = proc i -> do   children <-     S.all@@ -144,9 +173,9 @@  -- | Build all hierarchies of parents to children with the given query. hierarchies ::-  (ArrowQueryReader q, ArrowReaderSystem q arr) =>+  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>   q i a ->-  arr i [[Hierarchy a]]+  arr i [Hierarchy a] hierarchies q = proc i -> do   children <-     S.all@@ -160,16 +189,16 @@         i   let childMap = Map.fromList children   roots <- S.filter Q.entity $ with @Children <> without @Parent -< ()-  returnA -< map (`hierarchy'` childMap) roots+  returnA -< mapMaybe (`hierarchy'` childMap) roots -hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> [Hierarchy a]+hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a) hierarchy' e childMap = case Map.lookup e childMap of   Just (cs, a) ->-    let bs = concatMap (`hierarchy'` childMap) (Set.toList cs)-     in [ Node+    let bs = mapMaybe (`hierarchy'` childMap) (Set.toList cs)+     in Just+          Node             { nodeEntityId = e,               nodeEntity = a,               nodeChildren = bs             }-        ]-  Nothing -> []+  Nothing -> Nothing

@@ -8,10 +8,8 @@ import Data.Word (Word32) import GHC.Generics +-- | Time component. newtype Time = Time {elapsedMS :: Word32}-  deriving (Eq, Ord, Num, Show, Generic)+  deriving (Eq, Ord, Num, Show, Generic, NFData)  instance Component Time--instance NFData Time where-  rnf = rwhnf

@@ -1,26 +1,103 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -module Aztecs.Transform where+module Aztecs.Transform+  ( -- * Transform+    Transform (..), +    -- ** 2D+    Transform2D,+    transform2d,++    -- * Size+    Size (..),++    -- ** 2D+    Size2D,+    size2D,++    -- * Systems+    update,+    update2d,+    propagate,+    propagate2d,+  )+where+ import Aztecs.ECS+import qualified Aztecs.ECS.Access as A+import qualified Aztecs.ECS.Query as Q+import 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 (..)) -data Transform = Transform-  { transformPosition :: !(V2 Int),-    transformRotation :: !Float,-    transformScale :: !(V2 Int)+-- | Transform component.+data Transform v r = Transform+  { transformTranslation :: !v,+    transformRotation :: !r,+    transformScale :: !v   }   deriving (Eq, Show, Generic, NFData) -transform :: Transform-transform = Transform (V2 0 0) 0 (V2 1 1)+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) -instance Component Transform+instance (Num v, Num r) => Monoid (Transform v r) where+  mempty = Transform 0 0 0 -newtype Size = Size {unSize :: V2 Int}+-- | 2D transform component.+type Transform2D = Transform (V2 Int) Int++-- | Empty transform.+transform2d :: Transform2D+transform2d = Transform (V2 0 0) 0 (V2 1 1)++instance Component (Transform (V2 Int) Int)++-- | Size component.+newtype Size v = Size {unSize :: v}   deriving (Generic, NFData) -instance Component Size+type Size2D = Size (V2 Int)++size2D :: Size (V2 Integer)+size2D = Size (V2 0 0)++instance Component (Size (V2 Int))++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.+update ::+  forall q arr b m a.+  ( ArrowQueryReader q,+    ArrowDynamicQueryReader q,+    ArrowReaderSystem q arr,+    ArrowQueueSystem b m arr,+    Component a,+    Monoid a+  ) =>+  arr () ()+update = propagate @_ @_ @a >>> S.queue (mapM_ $ mapM_ (uncurry A.insert) . toList)++-- | 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)++propagate ::+  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr, Component a, Monoid a) =>+  arr () [Hierarchy a]+propagate = hierarchies Q.fetch >>> arr (map propagateHierarchy)++propagate2d :: (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) => arr () [Hierarchy Transform2D]+propagate2d = propagate

@@ -1,15 +1,18 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}  module Main (main) where  import Aztecs 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 ((&&&))+import Control.Arrow (returnA, (&&&)) import Control.DeepSeq import qualified Data.Set as Set import GHC.Generics@@ -36,17 +39,20 @@     it "queries three components" $ property prop_queryThreeComponents   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 "increments components" prop_quit  prop_queryOneComponent :: [X] -> Expectation prop_queryOneComponent xs =   let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs-      (res, _) = Q.all Q.fetch w+      (res, _) = Q.all Q.fetch $ W.entities w    in res `shouldMatchList` xs  prop_queryTwoComponents :: [(X, Y)] -> Expectation prop_queryTwoComponents xys =   let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys-      (res, _) = Q.all (Q.fetch &&& Q.fetch) w+      (res, _) = Q.all (Q.fetch &&& Q.fetch) $ W.entities w    in res `shouldMatchList` xys  prop_queryThreeComponents :: [(X, Y, Z)] -> Expectation@@ -57,13 +63,46 @@         y <- Q.fetch         z <- Q.fetch         pure (x, y, z)-      (res, _) = Q.all q w+      (res, _) = Q.all q $ W.entities w    in res `shouldMatchList` xyzs  prop_addParents :: Expectation prop_addParents = do   let (_, w) = W.spawnEmpty W.empty       (e, w') = W.spawn (bundle . Children $ Set.singleton e) w-  (_, w'') <- runSchedule (system Hierarchy.update) w' ()-  let (res, _) = Q.all Q.fetch w''+  (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()+  let (res, _) = Q.all Q.fetch $ W.entities w''   res `shouldMatchList` [Parent e]++prop_removeParents :: Expectation+prop_removeParents = do+  let (_, w) = W.spawnEmpty W.empty+      (e, w') = W.spawn (bundle . Children $ Set.singleton e) w+  (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()+  let w''' = W.insert e (Children Set.empty) w''+  (_, _, w'''') <- runSchedule (system Hierarchy.update) w''' ()+  let (res, _) = Q.all (Q.fetch @_ @Parent) $ W.entities w''''+  res `shouldMatchList` []++prop_quit :: Expectation+prop_quit = do+  let (_, w) = W.spawn (bundle $ X 1) W.empty+  (_, _, w') <- runSchedule quit w ()+  (x, _, _) <- runSchedule quit w' ()+  x `shouldBe` True++quit :: Schedule IO () Bool+quit = proc () -> do+  rec lastShouldQuit <- delay False -< shouldQuit+      x <-+        system $+          S.mapSingle+            ( proc () -> do+                X x <- Q.fetch -< ()+                Q.set -< X $ x + 1+                returnA -< x+            )+          -<+            ()+      let shouldQuit = (lastShouldQuit || x > 1)+  returnA -< shouldQuit