aztecs 0.5.0.1 → 0.6.0

raw patch · 53 files changed

+2933/−1642 lines, 53 filesdep +deepseqdep +lineardep +paralleldep −parallel-iodep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, linear, parallel

Dependencies removed: parallel-io

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• aztecs.cabal +44/−32
• bench/Iter.hs +20/−14
• examples/ECS.hs +0/−36
• src/Aztecs.hs +84/−0
• src/Aztecs/Asset.hs +154/−0
• src/Aztecs/Camera.hs +56/−0
• src/Aztecs/ECS.hs +94/−0
• src/Aztecs/ECS/Access.hs +51/−0
• src/Aztecs/ECS/Access/Class.hs +32/−0
• src/Aztecs/ECS/Component.hs +24/−0
• src/Aztecs/ECS/Entity.hs +11/−0
• src/Aztecs/ECS/Query.hs +138/−0
• src/Aztecs/ECS/Query/Class.hs +8/−0
• src/Aztecs/ECS/Query/Dynamic.hs +77/−0
• src/Aztecs/ECS/Query/Dynamic/Class.hs +7/−0
• src/Aztecs/ECS/Query/Dynamic/Reader.hs +69/−0
• src/Aztecs/ECS/Query/Dynamic/Reader/Class.hs +16/−0
• src/Aztecs/ECS/Query/Reader.hs +114/−0
• src/Aztecs/ECS/Query/Reader/Class.hs +16/−0
• src/Aztecs/ECS/Schedule.hs +100/−0
• src/Aztecs/ECS/System.hs +85/−0
• src/Aztecs/ECS/System/Class.hs +28/−0
• src/Aztecs/ECS/System/Dynamic.hs +50/−0
• src/Aztecs/ECS/System/Dynamic/Class.hs +80/−0
• src/Aztecs/ECS/System/Dynamic/Reader.hs +60/−0
• src/Aztecs/ECS/System/Dynamic/Reader/Class.hs +21/−0
• src/Aztecs/ECS/System/Reader.hs +74/−0
• src/Aztecs/ECS/System/Reader/Class.hs +26/−0
• src/Aztecs/ECS/View.hs +96/−0
• src/Aztecs/ECS/World.hs +245/−0
• src/Aztecs/ECS/World/Archetype.hs +218/−0
• src/Aztecs/ECS/World/Archetypes.hs +271/−0
• src/Aztecs/ECS/World/Components.hs +60/−0
• src/Aztecs/ECS/World/Storage.hs +38/−0
• src/Aztecs/Hierarchy.hs +175/−0
• src/Aztecs/Input.hs +205/−0
• src/Aztecs/Time.hs +17/−0
• src/Aztecs/Transform.hs +26/−0
• src/Aztecs/Window.hs +17/−0
• src/Data/Aztecs.hs +0/−81
• src/Data/Aztecs/Access.hs +0/−69
• src/Data/Aztecs/Component.hs +0/−20
• src/Data/Aztecs/Entity.hs +0/−5
• src/Data/Aztecs/Query.hs +0/−318
• src/Data/Aztecs/Schedule.hs +0/−70
• src/Data/Aztecs/Storage.hs +0/−37
• src/Data/Aztecs/System.hs +0/−214
• src/Data/Aztecs/View.hs +0/−70
• src/Data/Aztecs/World.hs +0/−279
• src/Data/Aztecs/World/Archetype.hs +0/−207
• src/Data/Aztecs/World/Archetypes.hs +0/−123
• src/Data/Aztecs/World/Components.hs +0/−56
• test/Main.hs +26/−11

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          aztecs-version:       0.5.0.1+version:       0.6.0 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me@@ -19,45 +19,54 @@     type:     git     location: https://github.com/matthunz/aztecs.git -flag examples-  description:       Build examples-  default:           False-  manual:            True- library     exposed-modules:-        Data.Aztecs-        Data.Aztecs.Access-        Data.Aztecs.Component-        Data.Aztecs.Entity-        Data.Aztecs.Query-        Data.Aztecs.Schedule-        Data.Aztecs.Storage-        Data.Aztecs.System-        Data.Aztecs.View-        Data.Aztecs.World-        Data.Aztecs.World.Archetype-        Data.Aztecs.World.Archetypes-        Data.Aztecs.World.Components+        Aztecs+        Aztecs.ECS+        Aztecs.ECS.Access+        Aztecs.ECS.Access.Class+        Aztecs.ECS.Component+        Aztecs.ECS.Entity+        Aztecs.ECS.Query+        Aztecs.ECS.Query.Class+        Aztecs.ECS.Query.Dynamic+        Aztecs.ECS.Query.Dynamic.Class+        Aztecs.ECS.Query.Dynamic.Reader+        Aztecs.ECS.Query.Dynamic.Reader.Class+        Aztecs.ECS.Query.Reader+        Aztecs.ECS.Query.Reader.Class+        Aztecs.ECS.Schedule+        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.Reader+        Aztecs.ECS.System.Reader.Class+        Aztecs.ECS.View+        Aztecs.ECS.World+        Aztecs.ECS.World.Archetype+        Aztecs.ECS.World.Archetypes+        Aztecs.ECS.World.Components+        Aztecs.ECS.World.Storage+        Aztecs.Asset+        Aztecs.Camera+        Aztecs.Hierarchy+        Aztecs.Input+        Aztecs.Time+        Aztecs.Transform+        Aztecs.Window     hs-source-dirs:   src     default-language: Haskell2010     ghc-options:      -Wall     build-depends:         base >=4.6 && <5,         containers >=0.6,+        deepseq >=1,+        linear >=1,         mtl >=2,-        parallel-io >=0.3.5--executable ecs-    main-is:          ECS.hs-    hs-source-dirs:   examples-    default-language: Haskell2010-    ghc-options:      -Wall-    if flag(examples)-        build-depends: base, aztecs-    else-        buildable: False-+        parallel >=3,  test-suite aztecs-test     type:             exitcode-stdio-1.0@@ -68,6 +77,8 @@     build-depends:         base >=4.6 && <5,         aztecs,+        containers >=0.6,+        deepseq >=1,         hspec >=2,         QuickCheck >=2 @@ -80,4 +91,5 @@     build-depends:         base >=4.6 && <5,         aztecs,-        criterion >=1+        criterion >=1,+        deepseq >=1

@@ -1,31 +1,37 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +import Aztecs.ECS+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.System as S+import qualified Aztecs.ECS.World as W+import Control.DeepSeq+import Control.Monad (void) import Criterion.Main-import Data.Aztecs-import qualified Data.Aztecs.Query as Q-import qualified Data.Aztecs.System as S-import qualified Data.Aztecs.World as W+import GHC.Generics (Generic) -newtype Position = Position Int deriving (Show)+newtype Position = Position Int deriving (Show, Generic, NFData)  instance Component Position -newtype Velocity = Velocity Int deriving (Show)+newtype Velocity = Velocity Int deriving (Show, Generic, NFData)  instance Component Velocity  run :: World -> IO () run w = do   let s =-        const ()-          <$> S.map-            ( proc () -> do-                Velocity v <- Q.fetch -< ()-                Position p <- Q.fetch -< ()-                Q.set -< Position $ p + v-            )-  !_ <- S.runSystemWithWorld s w+        void+          ( S.map+              ( proc () -> do+                  Velocity v <- Q.fetch -< ()+                  Position p <- Q.fetch -< ()+                  Q.set -< Position $ p + v+              )+          )+  !_ <- runSchedule (system s) w ()   return ()  main :: IO ()

@@ -1,36 +0,0 @@-{-# LANGUAGE Arrows #-}--module Main where--import Control.Arrow ((>>>))-import Data.Aztecs-import qualified Data.Aztecs.Access as A-import qualified Data.Aztecs.Query as Q-import qualified Data.Aztecs.System as S--newtype Position = Position Int deriving (Show)--instance Component Position--newtype Velocity = Velocity Int deriving (Show)--instance Component Velocity--setup :: System () ()-setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)--move :: System () ()-move =-  S.map-    ( proc () -> do-        Velocity v <- Q.fetch -< ()-        Position p <- Q.fetch -< ()-        Q.set -< Position $ p + v-    )-    >>> S.task print--app :: Schedule IO () ()-app = schedule setup >>> forever (schedule move)--main :: IO ()-main = runSchedule_ $ app

@@ -0,0 +1,84 @@+-- | Aztecs is a type-safe and friendly ECS for games and more.+--+-- An ECS is a modern approach to organizing your application state as a database,+-- providing patterns for data-oriented design and parallel processing.+--+-- The ECS architecture is composed of three main concepts:+--+-- === Entities+-- An entity is an object comprised of zero or more components.+-- In Aztecs, entities are represented by their `EntityID`, a unique identifier.+--+-- === Components+-- A `Component` holds the data for a particular aspect of an entity.+-- For example, a zombie entity might have a @Health@ and a @Transform@ component.+--+-- > newtype Position = Position Int deriving (Show)+-- > instance Component Position+-- >+-- > newtype Velocity = Velocity Int deriving (Show)+-- > instance Component Velocity+--+-- === Systems+-- A `System` is a pipeline that processes entities and their components.+-- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.+--+-- Systems can access game state in two ways:+--+-- ==== Access+-- An `Access` can be queued for full access to the `World`, after a system is complete.+-- `Access` allows for spawning, inserting, and removing components.+--+-- > setup :: System  () ()+-- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)+--+-- ==== Queries+-- A `Query` can read and write matching components.+--+-- > move :: System  () ()+-- > move =+-- >  S.map+-- >    ( proc () -> do+-- >        Velocity v <- Q.fetch -< ()+-- >        Position p <- Q.fetch -< ()+-- >        Q.set -< Position $ p + v+-- >    )+-- >    >>> S.run print+--+-- Finally, systems can be run on a `World` to produce a result.+--+-- > main :: IO ()+-- > main = runSystem_ $ setup >>> S.forever move+module Aztecs+  ( module Aztecs.ECS,+    asset,+    load,+    Camera (..),+    CameraTarget (..),+    Transform (..),+    transform,+    Key (..),+    KeyboardInput (..),+    isKeyPressed,+    wasKeyPressed,+    wasKeyReleased,+    MouseInput (..),+    Time (..),+    Window (..),+  )+where++import Aztecs.Asset (asset, load)+import Aztecs.Camera+import Aztecs.ECS+import Aztecs.Input+  ( Key (..),+    KeyboardInput (..),+    MouseInput (..),+    isKeyPressed,+    wasKeyPressed,+    wasKeyReleased,+  )+import Aztecs.Time+import Aztecs.Transform (Transform (..), transform)+import Aztecs.Window

@@ -0,0 +1,154 @@+{-# 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,+    Asset (..),+    Handle (..),+    MonadAssetLoader (..),+    AssetLoader,+    AssetLoaderT (..),+    load,+    setup,+    loadQuery,+    loadAssets,+    lookupAsset,+  )+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

@@ -0,0 +1,56 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.Camera+  ( Camera (..),+    CameraTarget (..),+    addCameraTargets,+  )+where++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 (..))+import Control.DeepSeq+import GHC.Generics (Generic)+import Linear (V2 (..))++-- | Camera component.+data Camera = Camera+  { -- | Camera viewport size.+    cameraViewport :: !(V2 Int),+    -- | Camera scale factor.+    cameraScale :: !(V2 Float)+  }+  deriving (Show, Generic, NFData)++instance Component Camera++-- | Camera target component.+newtype CameraTarget = CameraTarget+  { -- | This camera's target window.+    cameraTargetWindow :: EntityID+  }+  deriving (Eq, Show, Generic, NFData)++instance Component CameraTarget++-- | Add `CameraTarget` components to entities with a new `Draw` component.+addCameraTargets :: (ArrowQueryReader qr, ArrowReaderSystem qr arr, ArrowSystem q arr) => arr () ()+addCameraTargets = proc () -> do+  windows <- S.all (Q.entity &&& Q.fetch @_ @Window) -< ()+  newCameras <- S.filter (Q.entity &&& Q.fetch @_ @Camera) (without @CameraTarget) -< ()+  S.queue+    ( \(newCameras, windows) -> case windows of+        (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ CameraTarget windowEId) newCameras+        _ -> return ()+    )+    -<+      (newCameras, windows)

@@ -0,0 +1,94 @@+-- | Aztecs is a type-safe and friendly ECS for games and more.+--+-- An ECS is a modern approach to organizing your application state as a database,+-- providing patterns for data-oriented design and parallel processing.+--+-- The ECS architecture is composed of three main concepts:+--+-- === Entities+-- An entity is an object comprised of zero or more components.+-- In Aztecs, entities are represented by their `EntityID`, a unique identifier.+--+-- === Components+-- A `Component` holds the data for a particular aspect of an entity.+-- For example, a zombie entity might have a @Health@ and a @Transform@ component.+--+-- > newtype Position = Position Int deriving (Show)+-- > instance Component Position+-- >+-- > newtype Velocity = Velocity Int deriving (Show)+-- > instance Component Velocity+--+-- === Systems+-- A `System` is a pipeline that processes entities and their components.+-- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.+--+-- Systems can access game state in two ways:+--+-- ==== Access+-- An `Access` can be queued for full access to the `World`, after a system is complete.+-- `Access` allows for spawning, inserting, and removing components.+--+-- > setup :: System  () ()+-- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)+--+-- ==== Queries+-- A `Query` can read and write matching components.+--+-- > move :: System  () ()+-- > move =+-- >  S.map+-- >    ( proc () -> do+-- >        Velocity v <- Q.fetch -< ()+-- >        Position p <- Q.fetch -< ()+-- >        Q.set -< Position $ p + v+-- >    )+-- >    >>> S.run print+--+-- Finally, systems can be run on a `World` to produce a result.+--+-- > main :: IO ()+-- > main = runSystem_ $ setup >>> S.forever move+module Aztecs.ECS+  ( Access,+    runAccessT,+    Bundle,+    bundle,+    Component (..),+    EntityID,+    Query,+    QueryFilter,+    with,+    without,+    System,+    Schedule,+    reader,+    system,+    forever,+    forever_,+    access,+    task,+    runSchedule,+    runSchedule_,+    World,+  )+where++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.Schedule+  ( Schedule,+    access,+    forever,+    forever_,+    reader,+    runSchedule,+    runSchedule_,+    system,+    task,+  )+import Aztecs.ECS.System (System)+import Aztecs.ECS.World (World)+import Aztecs.ECS.World.Archetype (Bundle, bundle)

@@ -0,0 +1,51 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Aztecs.ECS.Access+  ( Access,+    AccessT (..),+    MonadAccess (..),+    runAccessT,+  )+where++import Aztecs.ECS.Access.Class (MonadAccess (..))+import Aztecs.ECS.World (World (..))+import qualified Aztecs.ECS.World as W+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Identity (Identity)+import Control.Monad.State.Strict (MonadState (..), StateT (..))+import Prelude hiding (all, lookup, map)++type Access = AccessT Identity++-- | Access into the `World`.+newtype AccessT m a = AccessT {unAccessT :: StateT World m a}+  deriving (Functor, Applicative, Monad, 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+  spawn b = AccessT $ do+    !w <- get+    let !(e, w') = W.spawn b w+    put w'+    return e+  insert e c = AccessT $ do+    !w <- get+    let !w' = W.insert e c w+    put w'+  lookup e = AccessT $ do+    !w <- get+    return $ W.lookup e w+  remove e = AccessT $ do+    !w <- get+    let !(a, w') = W.remove e w+    put w'+    return a+  despawn e = AccessT $ do+    !w <- get+    let !(_, w') = W.despawn e w+    put w'

@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}++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 Prelude hiding (all, lookup, map)++-- | Monadic access to a `World`.+class (Monad m) => MonadAccess m where+  -- | Spawn an entity with a component.+  spawn :: Bundle -> m EntityID++  -- | Spawn an entity with a component.+  spawn_ :: Bundle -> m ()+  spawn_ c = do+    _ <- spawn c+    return ()++  -- | Insert a component into an entity.+  insert :: (Component a, Typeable (StorageT 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)++  -- | Despawn an entity.+  despawn :: EntityID -> m ()

@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.Component (Component (..), ComponentID (..)) where++import Aztecs.ECS.World.Storage (Storage)+import Control.DeepSeq (NFData)+import Data.IntMap.Strict (IntMap)+import Data.Kind (Type)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++-- | Component ID.+newtype ComponentID = ComponentID {unComponentId :: Int}+  deriving (Eq, Ord, Show, Generic, NFData)++-- | Component that can be stored in the `World`.+class (Typeable a, Storage (StorageT a) a) => Component a where+  -- | `Storage` of this component.+  type StorageT a :: Type -> Type++  type StorageT a = IntMap

@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Aztecs.ECS.Entity (EntityID (..)) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)++-- | Entity ID.+newtype EntityID = EntityID {unEntityId :: Int}+  deriving (Eq, Ord, Show, Generic, NFData)

@@ -0,0 +1,138 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.Query+  ( -- * Queries+    Query (..),+    ArrowQueryReader (..),+    ArrowQuery (..),+    ArrowDynamicQueryReader (..),+    ArrowDynamicQuery (..),++    -- ** Running+    all,++    -- * Filters+    QueryFilter (..),+    with,+    without,++    -- * Reads and writes+    ReadsWrites (..),+    disjoint,+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Class (ArrowQuery (..))+import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))+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.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 Control.Category (Category (..))+import Data.Set (Set)+import qualified Data.Set as Set+import Prelude hiding (all, id, reads, (.))++-- | 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+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)++instance Applicative (Query i) where+  pure a = Query (mempty,,pure a)+  (Query f) <*> (Query g) = Query $ \cs ->+    let (cIdsG, cs', aQS) = g cs+        (cIdsF, cs'', bQS) = f cs'+     in (cIdsG <> cIdsF, cs'', bQS <*> aQS)++instance Category Query where+  id = Query (mempty,,id)+  (Query f) . (Query g) = Query $ \cs ->+    let (cIdsG, cs', aQS) = g cs+        (cIdsF, cs'', bQS) = f cs'+     in (cIdsG <> cIdsF, cs'', bQS . aQS)++instance Arrow Query where+  arr f = Query (mempty,,arr f)+  first (Query f) = Query $ \comps -> let (cIds, comps', qS) = f comps in (cIds, comps', first 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)++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)++instance ArrowDynamicQuery Query where+  setDyn cId = Query (ReadsWrites Set.empty (Set.singleton cId),,setDyn cId)++instance ArrowQuery Query where+  set :: forall a. (Component a) => Query a a+  set = Query $ \cs ->+    let (cId, cs') = CS.insert @a cs+     in (ReadsWrites Set.empty (Set.singleton cId), cs', setDyn cId)++data ReadsWrites = ReadsWrites+  { reads :: !(Set ComponentID),+    writes :: !(Set ComponentID)+  }+  deriving (Show)++instance Semigroup ReadsWrites where+  ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2)++instance Monoid ReadsWrites where+  mempty = ReadsWrites mempty mempty++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)+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))+   in (concat as, w {components = cs'})

@@ -0,0 +1,8 @@+module Aztecs.ECS.Query.Class (ArrowQuery (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader)++class (ArrowQueryReader arr) => ArrowQuery arr where+  -- | Set a `Component` by its type.+  set :: (Component a) => arr a a

@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.Query.Dynamic+  ( -- * Dynamic queries+    DynamicQuery (..),+    ArrowDynamicQueryReader (..),+    ArrowDynamicQuery (..),++    -- * Dynamic query filters+    DynamicQueryFilter (..),+  )+where++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.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 Prelude hiding (all, any, id, lookup, map, mapM, reads, (.))++-- | 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')++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'')+      }++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'+      }++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)++  fetchDyn cId =+    DynamicQuery $ \_ _ arch -> let !as = A.all cId arch in (fmap snd as, arch)++  fetchMaybeDyn cId =+    DynamicQuery $ \_ _ arch -> let as = A.allMaybe cId arch in (fmap snd as, arch)++instance ArrowDynamicQuery DynamicQuery where+  setDyn cId =+    DynamicQuery $ \is _ arch -> let !arch' = A.withAscList cId is arch in (is, arch')

@@ -0,0 +1,7 @@+module Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader)++class (ArrowDynamicQueryReader arr) => ArrowDynamicQuery arr where+  setDyn :: (Component a) => ComponentID -> arr a a

@@ -0,0 +1,69 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.Query.Dynamic.Reader+  ( -- * Dynamic queries+    DynamicQueryReader (..),+    ArrowDynamicQueryReader (..),++    -- * Dynamic query filters+    DynamicQueryFilter (..),+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity (EntityID)+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 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++instance Applicative (DynamicQueryReader i) where+  pure a = DynamicQueryReader $ \_ es _ -> replicate (length es) a++  f <*> g =+    DynamicQueryReader $ \i es arch ->+      let as = dynQueryReaderAll g i es arch+          fs = dynQueryReaderAll f i es arch+       in zipWith ($) fs as++instance Category DynamicQueryReader where+  id = DynamicQueryReader $ \as _ _ -> as+  f . g = DynamicQueryReader $ \i es arch ->+    let as = dynQueryReaderAll g i es arch in dynQueryReaderAll f as es arch++instance Arrow DynamicQueryReader where+  arr f = DynamicQueryReader $ \bs _ _ -> fmap f bs+  first f = DynamicQueryReader $ \bds es arch ->+    let (bs, ds) = unzip bds+        cs = dynQueryReaderAll f bs es arch+     in zip cs 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++data DynamicQueryFilter = DynamicQueryFilter+  { filterWith :: !(Set ComponentID),+    filterWithout :: !(Set ComponentID)+  }++instance Semigroup DynamicQueryFilter where+  DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB =+    DynamicQueryFilter (withA <> withB) (withoutA <> withoutB)++instance Monoid DynamicQueryFilter where+  mempty = DynamicQueryFilter mempty mempty

@@ -0,0 +1,16 @@+module Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity (EntityID)+import Control.Arrow (Arrow (..), (>>>))++class (Arrow arr) => ArrowDynamicQueryReader arr where+  -- | Fetch the `EntityID` belonging to this entity.+  entityDyn :: arr () EntityID++  -- | Fetch a `Component` by its `ComponentID`.+  fetchDyn :: (Component a) => ComponentID -> arr () a++  -- | Try to fetch a `Component` by its `ComponentID`.+  fetchMaybeDyn :: (Component a) => ComponentID -> arr () (Maybe a)+  fetchMaybeDyn cId = fetchDyn cId >>> arr Just

@@ -0,0 +1,114 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.Query.Reader+  ( -- * Queries+    QueryReader (..),+    ArrowQueryReader (..),+    ArrowDynamicQueryReader (..),++    -- * Filters+    QueryFilter (..),+    with,+    without,+    DynamicQueryFilter (..),+  )+where++import Aztecs.ECS.Component+import Aztecs.ECS.Query.Dynamic (DynamicQueryFilter (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..))+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.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+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)++instance Applicative (QueryReader i) where+  pure a = Query $ \cs -> (mempty, cs, pure a)+  (Query f) <*> (Query g) = Query $ \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 ->+    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)++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)+  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)++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)++-- | Filter for a `Query`.+newtype QueryFilter = QueryFilter {runQueryFilter :: Components -> (DynamicQueryFilter, Components)}++instance Semigroup QueryFilter where+  a <> b =+    QueryFilter+      ( \cs ->+          let (withA', cs') = runQueryFilter a cs+              (withB', cs'') = runQueryFilter b cs'+           in (withA' <> withB', cs'')+      )++instance Monoid QueryFilter where+  mempty = QueryFilter (mempty,)++-- | Filter for entities containing this component.+with :: forall a. (Component a) => QueryFilter+with = QueryFilter $ \cs ->+  let (cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')++-- | Filter out entities containing this component.+without :: forall a. (Component a) => QueryFilter+without = QueryFilter $ \cs ->+  let (cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')

@@ -0,0 +1,16 @@+module Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..)) where++import Aztecs.ECS.Component+import Aztecs.ECS.Entity (EntityID)+import Control.Arrow (Arrow (..), (>>>))++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++  -- | Fetch a `Component` by its type, returning `Nothing` if it doesn't exist.+  fetchMaybe :: (Component a) => arr () (Maybe a)+  fetchMaybe = fetch >>> arr Just

@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}++module Aztecs.ECS.Schedule+  ( -- * Schedules+    Schedule (..),+    reader,+    system,+    forever,+    forever_,+    access,+    task,+    runSchedule,+    runSchedule_,+  )+where++import Aztecs.ECS.Access (AccessT (..), runAccessT)+import Aztecs.ECS.System (System (..))+import Aztecs.ECS.System.Dynamic (DynamicSystem (..))+import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..))+import Aztecs.ECS.System.Reader (ReaderSystem (..))+import qualified Aztecs.ECS.View as V+import Aztecs.ECS.World (World (..))+import qualified Aztecs.ECS.World as W+import Aztecs.ECS.World.Components (Components)+import Control.Arrow (Arrow (..))+import Control.Category (Category (..))+import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad ((>=>))+import Control.Monad.Identity (Identity (runIdentity))+import Control.Monad.State (MonadState (..))+import Control.Monad.Trans (MonadTrans (..))+import Data.Functor (void)++newtype Schedule m i o = Schedule {runSchedule' :: Components -> (i -> AccessT m o, Components)}+  deriving (Functor)++instance (Monad m) => Category (Schedule m) where+  id = Schedule $ \cs -> (return, cs)+  Schedule f . Schedule g = Schedule $ \cs ->+    let (g', cs') = g cs+        (f', cs'') = f cs'+     in (g' >=> f', 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')++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')++runSchedule_ :: (Monad m) => Schedule m () () -> m ()+runSchedule_ s = void (runSchedule s W.empty ())++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')++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')++access :: (Monad m) => (i -> AccessT m o) -> Schedule m i o+access f = Schedule $ \cs -> (f, cs)++task :: (Monad m) => (i -> m o) -> Schedule m i o+task f = Schedule $ \cs -> (AccessT Prelude.. lift Prelude.. f, cs)++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+              lift $ evaluate $ rnf wAcc'+              lift $ f o+              loop wAcc'+        loop w+   in (go, cs')++forever_ :: Schedule IO i o -> Schedule IO i ()+forever_ s = forever s (const $ pure ())

@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.ECS.System+  ( -- * Systems+    System (..),+    ArrowReaderSystem (..),+    ArrowSystem (..),+  )+where++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.Dynamic.Class (ArrowDynamicSystem (..))+import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))+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.Components (Components)+import Control.Arrow (Arrow (..))+import Control.Category (Category (..))+import qualified Data.Foldable as F+import Prelude hiding (all, filter, map, (.))+import qualified Prelude hiding (filter, map)++-- | System to process entities.+newtype System i o = System+  { -- | Run a system, producing a `DynamicSystem` that can be repeatedly run.+    runSystem :: Components -> (DynamicSystem i o, ReadsWrites, Components)+  }+  deriving (Functor)++instance Category System where+  id = System $ \cs -> (DynamicSystem $ \_ i -> (i, mempty, pure ()), 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)+  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''+        )++instance ArrowReaderSystem QueryReader System where+  all q = System $ \cs ->+    let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, ReadsWrites rs mempty, cs')+  filter q qf = System $ \cs ->+    let !(rs, cs', dynQ) = runQueryReader q cs+        !(dynQf, cs'') = runQueryFilter qf cs'+        qf' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)+     in (filterDyn rs dynQ qf', ReadsWrites rs mempty, cs'')++instance ArrowSystem Query System where+  map q = System $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (mapDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')+  filterMap q qf = System $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+        !(dynQf, cs'') = runQueryFilter qf cs'+        f' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)+     in (filterMapDyn (Q.reads rws <> Q.writes rws) dynQ f', rws, cs'')+  mapSingle q = System $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (mapSingleDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')+  mapSingleMaybe q = System $ \cs ->+    let !(rws, cs', dynQ) = runQuery q cs+     in (mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')+  queue f = System $ \cs -> (queueDyn f, mempty, cs)

@@ -0,0 +1,28 @@+{-# LANGUAGE FunctionalDependencies #-}++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)++class (Arrow arr) => ArrowSystem q arr | arr -> q where+  -- | Query and update all matching entities.+  map :: q i a -> arr i [a]++  -- | Query and update all matching entities, ignoring the results.+  map_ :: q i o -> arr i ()+  map_ q = map q >>> arr (const ())++  -- | Map all matching entities with a `QueryFilter`, storing the updated entities.+  filterMap :: q i a -> QueryFilter -> arr i [a]++  -- | Map a single matching entity, storing the updated components.+  -- If there are zero or multiple matching entities, an error will be thrown.+  mapSingle :: q i a -> arr i a++  mapSingleMaybe :: q i a -> arr i (Maybe a)++  -- | Queue an `Access` to happen after this system schedule.+  queue :: (i -> Access ()) -> arr i ()

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.ECS.System.Dynamic (DynamicSystem (..), raceDyn) where++import Aztecs.ECS.Access (Access)+import Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..))+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 Control.Parallel (par)++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 ()))+  }+  deriving (Functor)++instance Category DynamicSystem where+  id = DynamicSystem $ \_ i -> (i, mempty, pure ())+  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)++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)++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 ArrowDynamicSystem DynamicSystem where+  runArrowSystemDyn = DynamicSystem++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)

@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}++module Aztecs.ECS.System.Dynamic.Class+  ( ArrowDynamicSystem (..),+    DynamicSystem,+    mapDyn',+    mapSingleDyn',+    mapSingleMaybeDyn',+    filterMapDyn',+    queueDyn',+  )+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++  -- | Map all matching entities, storing the updated entities.+  mapDyn :: Set ComponentID -> DynamicQuery i o -> arr i [o]+  mapDyn cIds q = runArrowSystemDyn $ mapDyn' cIds q++  mapSingleDyn :: Set ComponentID -> DynamicQuery i o -> arr i o+  mapSingleDyn cIds q = runArrowSystemDyn $ mapSingleDyn' cIds q++  mapSingleMaybeDyn :: Set ComponentID -> DynamicQuery i o -> arr i (Maybe o)+  mapSingleMaybeDyn cIds q = runArrowSystemDyn $ mapSingleMaybeDyn' cIds q++  filterMapDyn ::+    Set ComponentID ->+    DynamicQuery 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)

@@ -0,0 +1,60 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}++module Aztecs.ECS.System.Dynamic.Reader+  ( -- * Dynamic Systems+    DynamicReaderSystem (..),+    ArrowDynamicReaderSystem (..),+    raceDyn,+  )+where++import Aztecs.ECS.Component (ComponentID)+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader)+import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))+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 Control.Parallel (par)+import Data.Set (Set)++newtype DynamicReaderSystem i o = DynamicReaderSystem+  { -- | Run a dynamic system producing some output+    runReaderSystemDyn :: World -> 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++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)++instance ArrowDynamicReaderSystem DynamicReaderSystem where+  allDyn cIds q = DynamicReaderSystem $ allDyn' cIds q+  filterDyn cIds q f = DynamicReaderSystem $ filterDyn' cIds q 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

@@ -0,0 +1,21 @@+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]++  filterDyn :: Set ComponentID -> DynamicQueryReader i o -> (Node -> Bool) -> arr i [o]++  singleDyn :: Set ComponentID -> DynamicQueryReader () a -> arr () a+  singleDyn cIds q =+    allDyn cIds q+      >>> arr+        ( \as -> case as of+            [a] -> a+            _ -> error "TODO"+        )

@@ -0,0 +1,74 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.ECS.System.Reader+  ( -- * Systems+    ReaderSystem (..),+    queue,++    -- ** Queries++    -- *** Reading+    all,+    filter,+    single,++    -- *** Writing+    map,+    map_,+    filterMap,+    mapSingle,+  )+where++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 qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node (..))+import Aztecs.ECS.World.Components (ComponentID, Components)+import Control.Arrow (Arrow (..))+import Control.Category (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)++-- | System to process entities.+newtype ReaderSystem i o = ReaderSystem+  { -- | Run a system, producing a `DynamicSystem` that can be repeatedly run.+    runReaderSystem :: Components -> (DynamicReaderSystem i o, Set ComponentID, Components)+  }+  deriving (Functor)++instance Category ReaderSystem where+  id = ReaderSystem $ \cs -> (id, mempty, cs)+  ReaderSystem f . ReaderSystem g = ReaderSystem $ \cs ->+    let (f', rwsF, cs') = f cs+        (g', rwsG, cs'') = g cs'+     in (f' . g', rwsF <> rwsG, cs'')++instance 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')+  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 ArrowReaderSystem QueryReader ReaderSystem where+  all q = ReaderSystem $ \cs ->+    let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, rs, cs')+  filter q qf = ReaderSystem $ \cs ->+    let !(rs, cs', dynQ) = runQueryReader q cs+        !(dynQf, cs'') = runQueryFilter qf cs'+        qf' n =+          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)+            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)+     in (filterDyn rs dynQ qf', rs, cs'')

@@ -0,0 +1,26 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FunctionalDependencies #-}++module Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..)) where++import Aztecs.ECS.Query.Reader (QueryFilter (..))+import Control.Arrow (Arrow (..), (>>>))+import Prelude hiding (all, any, filter, id, lookup, map, mapM, reads, (.))++class (Arrow arr) => ArrowReaderSystem q arr | arr -> q where+  -- | Query all matching entities.+  all :: q i a -> arr i [a]++  -- | Query all matching entities with a `QueryFilter`.+  filter :: q () a -> QueryFilter -> arr () [a]++  -- | Query a single matching entity.+  -- If there are zero or multiple matching entities, an error will be thrown.+  single :: q i a -> arr i a+  single q =+    all q+      >>> arr+        ( \as -> case as of+            [a] -> a+            _ -> error "TODO"+        )

@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.ECS.View+  ( View (..),+    view,+    viewSingle,+    filterView,+    unview,+    allDyn,+    singleDyn,+    readAllDyn,+  )+where++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 Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)++#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif++-- | View into a `World`, containing a subset of archetypes.+newtype View = View {viewArchetypes :: Map ArchetypeID Node}+  deriving (Show, Semigroup, Monoid)++-- | View into all archetypes containing the provided component IDs.+view :: Set ComponentID -> Archetypes -> View+view cIds as = View $ AS.lookup cIds as++viewSingle :: Set ComponentID -> Archetypes -> Maybe View+viewSingle cIds as = case Map.toList $ AS.lookup cIds as of+  [a] -> Just . View $ Map.singleton (fst a) (snd a)+  _ -> Nothing++-- | View into all archetypes containing the provided component IDs and matching the provided predicate.+filterView ::+  Set ComponentID ->+  (Node -> Bool) ->+  Archetypes ->+  View+filterView cIds f as = View $ Map.filter f (AS.lookup cIds as)++-- | "Un-view" a `View` back into a `World`.+unview :: View -> World -> World+unview v w =+  w+    { W.archetypes =+        foldl'+          (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)})+          (W.archetypes w)+          (Map.toList $ viewArchetypes v)+    }++-- | Query all matching entities in a `View`.+allDyn :: i -> DynamicQuery i a -> View -> ([a], View)+allDyn i q v =+  let (as, arches) =+        foldl'+          ( \(acc, archAcc) (aId, n) ->+              let (as', arch') = dynQueryAll q (repeat i) (A.entities (nodeArchetype n)) (nodeArchetype n)+               in (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)+          )+          ([], Map.empty)+          (Map.toList $ viewArchetypes v)+   in (as, View arches)++-- | Query all matching entities in a `View`.+singleDyn :: i -> DynamicQuery i a -> View -> (Maybe a, View)+singleDyn i q v = case allDyn i q v of+  -- TODO [a], removing this errors for now+  ((a : _), v') -> (Just a, v')+  _ -> (Nothing, v)++-- | Query all matching entities in a `View`.+readAllDyn :: i -> DynamicQueryReader i a -> View -> [a]+readAllDyn i q v =+  foldl'+    ( \acc n ->+        dynQueryReaderAll q (repeat i) (A.entities (nodeArchetype n)) (nodeArchetype n) ++ acc+    )+    []+    (viewArchetypes v)

@@ -0,0 +1,245 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.ECS.World+  ( World (..),+    empty,+    spawn,+    spawnComponent,+    spawnWithId,+    spawnWithArchetypeId,+    spawnEmpty,+    insert,+    insertWithId,+    lookup,+    remove,+    removeWithId,+    despawn,+  )+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 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 Prelude hiding (lookup)++#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif++-- | World of entities and their components.+data World = World+  { archetypes :: !Archetypes,+    components :: !Components,+    entities :: !(Map EntityID ArchetypeID),+    nextEntityId :: !EntityID+  }+  deriving (Show, Generic, NFData)++-- | Empty `World`.+empty :: World+empty =+  World+    { archetypes = AS.empty,+      components = CS.empty,+      entities = mempty,+      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}++-- | 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)})++-- | 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 ->+  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)+        }++-- | 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 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)}++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)++-- | 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'}++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)++-- | 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)

@@ -0,0 +1,218 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Aztecs.ECS.World.Archetype+  ( Archetype (..),+    empty,+    all,+    allMaybe,+    entities,+    lookupComponent,+    lookupStorage,+    member,+    remove,+    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 qualified Aztecs.ECS.World.Storage as S+import Control.DeepSeq+import Data.Bifunctor (Bifunctor (..))+import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)+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)++#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}+  deriving (Show, Generic, NFData)++empty :: Archetype+empty = Archetype {storages = Map.empty}++lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a a)+lookupStorage cId w = do+  dynS <- Map.lookup cId (storages w)+  fromDynamic (storageDyn dynS)++insertComponent :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype+insertComponent e cId c arch =+  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++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)++lookupComponent :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a+lookupComponent e cId w = lookupStorage cId w >>= S.lookup (unEntityId e)++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'}++remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)+remove e arch =+  foldl'+    ( \(dynAcc, archAcc) (cId, s) ->+        let !(dynA, dynS) = removeDyn s (unEntityId e) (storageDyn 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)}+            )+    )+    (Map.empty, arch)+    (Map.toList $ storages arch)++removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)+removeStorages e arch =+  foldl'+    ( \(dynAcc, archAcc) (cId, s) ->+        let (dynA, dynS) = removeAny s (unEntityId e) (storageDyn 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)}+            )+    )+    (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')

@@ -0,0 +1,271 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Aztecs.ECS.World.Archetypes+  ( ArchetypeID (..),+    Node (..),+    Archetypes (..),+    empty,+    insertArchetype,+    lookupArchetypeId,+    findArchetypeIds,+    lookupNode,+    lookup,+    map,+    adjustArchetype,+    insert,+    remove,+  )+where++import Aztecs.ECS.Component (Component (..), ComponentID)+import Aztecs.ECS.Entity (EntityID (..))+import Aztecs.ECS.World.Archetype+  ( AnyStorage (..),+    Archetype (..),+    insertComponent,+    removeStorages,+  )+import qualified Aztecs.ECS.World.Archetype as A+import Control.DeepSeq (NFData (..))+import Data.Data (Typeable)+import Data.Dynamic (fromDynamic)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Generics (Generic)+import Prelude hiding (all, lookup, map)++#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif++-- | `Archetype` ID.+newtype ArchetypeID = ArchetypeID {unArchetypeId :: Int}+  deriving newtype (Eq, Ord, Show, NFData)++-- | Node in `Archetypes`.+data Node = Node+  { -- | Unique set of `ComponentID`s of this `Node`.+    nodeComponentIds :: !(Set ComponentID),+    -- | `Archetype` of this `Node`.+    nodeArchetype :: !Archetype,+    -- | Edges to other `Archetype`s by adding a `ComponentID`.+    nodeAdd :: !(Map ComponentID ArchetypeID),+    -- | Edges to other `Archetype`s by removing a `ComponentID`.+    nodeRemove :: !(Map ComponentID ArchetypeID)+  }+  deriving (Show, Generic, NFData)++-- | `Archetype` graph.+data Archetypes = Archetypes+  { -- | Archetype nodes in the graph.+    nodes :: !(Map ArchetypeID Node),+    -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.+    archetypeIds :: !(Map (Set ComponentID) ArchetypeID),+    -- | Next unique `ArchetypeID`.+    nextArchetypeId :: !ArchetypeID,+    -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.+    componentIds :: !(Map ComponentID (Set ArchetypeID))+  }+  deriving (Show, Generic, NFData)++-- | Empty `Archetypes`.+empty :: Archetypes+empty =+  Archetypes+    { nodes = mempty,+      archetypeIds = mempty,+      nextArchetypeId = ArchetypeID 0,+      componentIds = mempty+    }++-- | Insert an archetype by its set of `ComponentID`s.+insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)+insertArchetype cIds n arches =+  let aId = nextArchetypeId arches+   in ( aId,+        arches+          { nodes = Map.insert aId n (nodes arches),+            archetypeIds = Map.insert cIds aId (archetypeIds arches),+            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1),+            componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches)+          }+      )++adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes+adjustArchetype aId f arches = arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}++-- | Find `ArchetypeID`s containing a set of `ComponentID`s.+findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID+findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of+  (aId : aIds') -> foldl' Set.intersection aId aIds'+  [] -> Set.empty++-- | Lookup `Archetype`s containing a set of `ComponentID`s.+lookup :: Set ComponentID -> Archetypes -> Map ArchetypeID Node+lookup 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 !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)++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)++-- | Insert a component into an entity with its `ComponentID`.+insert ::+  (Component a, Typeable (StorageT a)) =>+  EntityID ->+  ArchetypeID ->+  ComponentID ->+  a ->+  Archetypes ->+  (Maybe ArchetypeID, Archetypes)+insert e aId cId c arches = case lookupNode 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)})+      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)}+              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')+                  }+              )+        Nothing ->+          let !(s, arch') = removeStorages e (nodeArchetype node)+              !n =+                Node+                  { nodeComponentIds = Set.insert cId (nodeComponentIds node),+                    nodeArchetype = insertComponent e cId c (Archetype {storages = s}),+                    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')+                  }+              )+  Nothing -> (Nothing, arches)++remove ::+  (Component a, Typeable (StorageT a)) =>+  EntityID ->+  ArchetypeID ->+  ComponentID ->+  Archetypes ->+  (Maybe (a, ArchetypeID), Archetypes)+remove e aId cId arches = case lookupNode 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+       in ( (,nextAId) <$> (a >>= fromDynamic),+            arches'+              { nodes =+                  Map.adjust+                    ( \nextNode ->+                        nextNode+                          { nodeArchetype =+                              foldl'+                                f+                                (nodeArchetype nextNode)+                                (Map.toList cs')+                          }+                    )+                    nextAId+                    (nodes $ arches')+              }+          )+    Nothing ->+      let !(cs, arch') = removeStorages e (nodeArchetype node)+          (a, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) cId cs+          !n =+            Node+              { nodeComponentIds = Set.insert cId (nodeComponentIds node),+                nodeArchetype = Archetype {storages = cs'},+                nodeAdd = Map.empty,+                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')+              }+          )+  Nothing -> (Nothing, arches)

@@ -0,0 +1,60 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.ECS.World.Components+  ( ComponentID (..),+    Components (..),+    empty,+    lookup,+    insert,+    insert',+  )+where++import Aztecs.ECS.Component (Component, ComponentID (..))+import Control.DeepSeq (NFData)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Typeable (Proxy (..), TypeRep, Typeable, typeOf)+import GHC.Generics (Generic)+import Prelude hiding (lookup)++-- | Component ID map.+data Components = Components+  { componentIds :: !(Map TypeRep ComponentID),+    nextComponentId :: !ComponentID+  }+  deriving (Show, Generic, NFData)++-- | Empty `Components`.+empty :: Components+empty =+  Components+    { componentIds = mempty,+      nextComponentId = ComponentID 0+    }++-- | Lookup a component ID by type.+lookup :: forall a. (Typeable a) => Components -> Maybe ComponentID+lookup cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs)++-- | Insert a component ID by type, if it does not already exist.+insert :: forall a. (Component a) => Components -> (ComponentID, Components)+insert cs = case lookup @a cs of+  Just cId -> (cId, cs)+  Nothing -> insert' @a cs++-- | Insert a component ID by type.+insert' :: forall c. (Component c) => Components -> (ComponentID, Components)+insert' cs =+  let !cId = nextComponentId cs+   in ( cId,+        cs+          { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs),+            nextComponentId = ComponentID (unComponentId cId + 1)+          }+      )

@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.ECS.World.Storage (Storage (..)) where++import Control.DeepSeq (NFData)+import Data.Data (Typeable)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap++-- | Component storage, containing zero or many components of the same type.+class (Typeable (s a), NFData (s a), Typeable a) => Storage s a where+  -- | Storage with a single component.+  singleton :: Int -> a -> s a++  -- | All components in the storage.+  all :: s a -> [(Int, a)]++  -- | Insert a component into the storage.+  insert :: Int -> a -> s a -> s a++  -- | Lookup a component in the storage.+  lookup :: Int -> s a -> Maybe a++  -- | Convert a sorted list of components (in ascending order) into a storage.+  fromAscList :: [(Int, a)] -> s a++  -- | Remove a component from the storage.+  remove :: Int -> s a -> (Maybe a, s a)++instance (Typeable a, NFData a) => Storage IntMap a where+  singleton = IntMap.singleton+  all = IntMap.toList+  insert = IntMap.insert+  lookup = IntMap.lookup+  fromAscList = IntMap.fromAscList+  remove i s = (IntMap.lookup i s, IntMap.delete i s) -- TODO remove double lookup

@@ -0,0 +1,175 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.Hierarchy+  ( Parent (..),+    Children (..),+    update,+    Hierarchy (..),+    hierarchy,+    hierarchies,+    ParentState (..),+    ChildState (..),+  )+where++import Aztecs+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.Set (Set)+import qualified Data.Set as Set+import GHC.Generics (Generic)++newtype Parent = Parent {unParent :: EntityID}+  deriving (Eq, Ord, Show, Generic, NFData)++instance Component Parent++newtype ParentState = ParentState {unParentState :: EntityID}+  deriving (Show, Generic, NFData)++instance Component ParentState++newtype Children = Children {unChildren :: Set EntityID}+  deriving (Eq, Ord, Show, Semigroup, Monoid, Generic, NFData)++instance Component Children++newtype ChildState = ChildState {unChildState :: Set EntityID}+  deriving (Show, Generic, NFData)++instance Component ChildState++update ::+  (ArrowQueryReader qr, ArrowQuery q, ArrowReaderSystem qr arr, ArrowSystem q arr) =>+  arr () ()+update = proc () -> do+  parents <-+    S.all+      ( proc () -> do+          entity <- Q.entity -< ()+          Parent parent <- Q.fetch -< ()+          maybeParentState <- Q.fetchMaybe @_ @ParentState -< ()+          returnA -< (entity, parent, maybeParentState)+      )+      -<+        ()+  children <-+    S.all+      ( proc () -> do+          entity <- Q.entity -< ()+          Children cs <- Q.fetch -< ()+          maybeChildState <- Q.fetchMaybe @_ @ChildState -< ()+          returnA -< (entity, cs, maybeChildState)+      )+      -<+        ()+  S.queue+    ( \(parents, childRes) -> do+        mapM_+          ( \(entity, parent, maybeParentState) -> case maybeParentState of+              Just (ParentState parentState) -> do+                when (parent /= parentState) $ do+                  A.insert parent $ ParentState parent++                  -- Remove this entity from the previous parent's children.+                  maybeLastChildren <- A.lookup parentState+                  let lastChildren = maybe mempty unChildren maybeLastChildren+                  let lastChildren' = Set.filter (/= entity) lastChildren+                  A.insert parentState . Children $ lastChildren'++                  -- Add this entity to the new parent's children.+                  maybeChildren <- A.lookup parent+                  let parentChildren = maybe mempty unChildren maybeChildren+                  A.insert parent . Children $ Set.insert entity parentChildren+              Nothing -> do+                A.spawn_ . bundle $ ParentState parent+                maybeChildren <- A.lookup parent+                let parentChildren = maybe mempty unChildren maybeChildren+                A.insert parent . Children $ Set.insert entity parentChildren+          )+          parents+        mapM_+          ( \(entity, children, maybeChildState) -> case maybeChildState of+              Just (ChildState childState) -> do+                when (children /= childState) $ do+                  A.insert entity $ ChildState children+                  let added = Set.difference children childState+                  -- TODO removed = Set.difference childState children+                  mapM_ (\e -> A.insert e . Parent $ entity) added+              Nothing -> do+                A.insert entity $ ChildState children+                mapM_ (\e -> A.insert e . Parent $ entity) children+          )+          childRes+    )+    -<+      (parents, children)++data Hierarchy a = Node+  { nodeEntityId :: EntityID,+    nodeEntity :: a,+    nodeChildren :: [Hierarchy a]+  }++hierarchy ::+  (ArrowQueryReader q, ArrowReaderSystem q arr) =>+  EntityID ->+  q i a ->+  arr i [Hierarchy a]+hierarchy e q = proc i -> do+  children <-+    S.all+      ( proc i -> do+          entity <- Q.entity -< ()+          Children cs <- Q.fetch -< ()+          a <- q -< i+          returnA -< (entity, (cs, a))+      )+      -<+        i+  let childMap = Map.fromList children+  returnA -< hierarchy' e childMap++-- | Build all hierarchies of parents to children with the given query.+hierarchies ::+  (ArrowQueryReader q, ArrowReaderSystem q arr) =>+  q i a ->+  arr i [[Hierarchy a]]+hierarchies q = proc i -> do+  children <-+    S.all+      ( proc i -> do+          entity <- Q.entity -< ()+          Children cs <- Q.fetch -< ()+          a <- q -< i+          returnA -< (entity, (cs, a))+      )+      -<+        i+  let childMap = Map.fromList children+  roots <- S.filter Q.entity $ with @Children <> without @Parent -< ()+  returnA -< map (`hierarchy'` childMap) roots++hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> [Hierarchy a]+hierarchy' e childMap = case Map.lookup e childMap of+  Just (cs, a) ->+    let bs = concatMap (`hierarchy'` childMap) (Set.toList cs)+     in [ Node+            { nodeEntityId = e,+              nodeEntity = a,+              nodeChildren = bs+            }+        ]+  Nothing -> []

@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Aztecs.Input+  ( Key (..),+    InputMotion (..),+    KeyboardInput (..),+    keyboardInput,+    isKeyPressed,+    wasKeyPressed,+    wasKeyReleased,+    handleKeyboardEvent,+    MouseButton (..),+    MouseInput (..),+    mouseInput,+    handleMouseMotion,+  )+where++import Aztecs.ECS+import Control.DeepSeq (NFData)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Generics (Generic)+import Linear (V2 (..))+import Linear.Affine (Point (..))++data Key+  = KeyA+  | KeyB+  | KeyC+  | KeyD+  | KeyE+  | KeyF+  | KeyG+  | KeyH+  | KeyI+  | KeyJ+  | KeyK+  | KeyL+  | KeyM+  | KeyN+  | KeyO+  | KeyP+  | KeyQ+  | KeyR+  | KeyS+  | KeyT+  | KeyU+  | KeyV+  | KeyW+  | KeyX+  | KeyY+  | KeyZ+  | Key0+  | Key1+  | Key2+  | Key3+  | Key4+  | Key5+  | Key6+  | Key7+  | Key8+  | Key9+  | KeyF1+  | KeyF2+  | KeyF3+  | KeyF4+  | KeyF5+  | KeyF6+  | KeyF7+  | KeyF8+  | KeyF9+  | KeyF10+  | KeyF11+  | KeyF12+  | KeyEscape+  | KeyEnter+  | KeySpace+  | KeyBackspace+  | KeyTab+  | KeyCapsLock+  | KeyShift+  | KeyCtrl+  | KeyAlt+  | KeyLeft+  | KeyRight+  | KeyUp+  | KeyDown+  | KeyHome+  | KeyEnd+  | KeyPageUp+  | KeyPageDown+  | KeyInsert+  | KeyDelete+  | KeyMinus+  | KeyEquals+  | KeyBracketLeft+  | KeyBracketRight+  | KeyBackslash+  | KeySemicolon+  | KeyComma+  | KeyPeriod+  | KeySlash+  | KeyNumLock+  | KeyNumpad0+  | KeyNumpad1+  | KeyNumpad2+  | KeyNumpad3+  | KeyNumpad4+  | KeyNumpad5+  | KeyNumpad6+  | KeyNumpad7+  | KeyNumpad8+  | KeyNumpad9+  | KeyNumpadDivide+  | KeyNumpadMultiply+  | KeyNumpadMinus+  | KeyNumpadPlus+  | KeyNumpadEnter+  | KeyNumpadPeriod+  | KeySuper+  | KeyMenu+  deriving (Show, Eq, Ord, Enum, Bounded, Generic, NFData)++-- | Keyboard input component.+data KeyboardInput = KeyboardInput+  { -- | Keyboard events that occured this frame.+    keyboardEvents :: !(Map Key InputMotion),+    -- | Keys that are currently pressed.+    keyboardPressed :: !(Set Key)+  }+  deriving (Show, Generic, NFData)++instance Component KeyboardInput++keyboardInput :: KeyboardInput+keyboardInput = KeyboardInput Map.empty Set.empty++data InputMotion = Pressed | Released+  deriving (Show, Eq, Generic, NFData)++-- | @True@ if this key is currently pressed.+isKeyPressed :: Key -> KeyboardInput -> Bool+isKeyPressed key kb = Set.member key $ keyboardPressed kb++-- | Check for a key event that occured this frame.+keyEvent :: Key -> KeyboardInput -> Maybe InputMotion+keyEvent key kb = Map.lookup key $ keyboardEvents kb++-- | @True@ if this key was pressed this frame.+wasKeyPressed :: Key -> KeyboardInput -> Bool+wasKeyPressed key kb = case keyEvent key kb of+  Just Pressed -> True+  _ -> False++-- | @True@ if this key was released this frame.+wasKeyReleased :: Key -> KeyboardInput -> Bool+wasKeyReleased key kb = case keyEvent key kb of+  Just Released -> True+  _ -> False++handleKeyboardEvent :: Key -> InputMotion -> KeyboardInput -> KeyboardInput+handleKeyboardEvent key motion kb =+  KeyboardInput+    { keyboardEvents = Map.insert key motion $ keyboardEvents kb,+      keyboardPressed = case motion of+        Pressed -> Set.insert key $ keyboardPressed kb+        Released -> Set.delete key $ keyboardPressed kb+    }++data MouseButton+  = ButtonLeft+  | ButtonMiddle+  | ButtonRight+  | ButtonX1+  | ButtonX2+  | -- | An unknown mouse button.+    ButtonExtra !Int+  deriving (Eq, Ord, Show, Generic, NFData)++-- | Mouse input component.+data MouseInput = MouseInput+  { -- | Mouse position in screen-space.+    mousePosition :: !(Point V2 Int),+    -- | Mouse offset since last frame.+    mouseOffset :: !(V2 Int),+    -- | Mouse button states.+    mouseButtons :: !(Map MouseButton InputMotion)+  }+  deriving (Show, Generic, NFData)++instance Component MouseInput++mouseInput :: MouseInput+mouseInput = MouseInput (P 0) (V2 0 0) Map.empty++handleMouseMotion :: V2 Int -> MouseInput -> MouseInput+handleMouseMotion delta mouse =+  mouse+    { mouseOffset = delta,+      mousePosition = mousePosition mouse + P delta+    }

@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Aztecs.Time (Time (..)) where++import Aztecs.ECS+import Control.DeepSeq+import Data.Word (Word32)+import GHC.Generics++newtype Time = Time {elapsedMS :: Word32}+  deriving (Eq, Ord, Num, Show, Generic)++instance Component Time++instance NFData Time where+  rnf = rwhnf

@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Aztecs.Transform where++import Aztecs.ECS+import Control.DeepSeq+import GHC.Generics (Generic)+import Linear (V2 (..))++data Transform = Transform+  { transformPosition :: !(V2 Int),+    transformRotation :: !Float,+    transformScale :: !(V2 Int)+  }+  deriving (Eq, Show, Generic, NFData)++transform :: Transform+transform = Transform (V2 0 0) 0 (V2 1 1)++instance Component Transform++newtype Size = Size {unSize :: V2 Int}+  deriving (Generic, NFData)++instance Component Size

@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Aztecs.Window (Window (..)) where++import Aztecs.ECS+import Control.DeepSeq (NFData)+import GHC.Generics (Generic)++-- | Window component.+data Window = Window+  { -- | Window title.+    windowTitle :: !String+  }+  deriving (Show, Generic, NFData)++instance Component Window

@@ -1,81 +0,0 @@--- | Aztecs is a type-safe and friendly ECS for games and more.------ An ECS is a modern approach to organizing your application state as a database,--- providing patterns for data-oriented design and parallel processing.------ The ECS architecture is composed of three main concepts:------ === Entities--- An entity is an object comprised of zero or more components.--- In Aztecs, entities are represented by their `EntityID`, a unique identifier.------ === Components--- A `Component` holds the data for a particular aspect of an entity.--- For example, a zombie entity might have a @Health@ and a @Transform@ component.------ > newtype Position = Position Int deriving (Show)--- > instance Component Position--- >--- > newtype Velocity = Velocity Int deriving (Show)--- > instance Component Velocity------ === Systems--- A `System` is a pipeline that processes entities and their components.--- Systems in Aztecs either run in sequence or in parallel automatically based on the components they access.------ Systems can access game state in two ways:------ ==== Access--- An `Access` can be queued for full access to the `World`, after a system is complete.--- `Access` allows for spawning, inserting, and removing components.------ > setup :: System  () ()--- > setup = S.queue . const . A.spawn_ $ bundle (Position 0) <> bundle (Velocity 1)------ ==== Queries--- A `Query` can read and write matching components.------ > move :: System  () ()--- > move =--- >  S.map--- >    ( proc () -> do--- >        Velocity v <- Q.fetch -< ()--- >        Position p <- Q.fetch -< ()--- >        Q.set -< Position $ p + v--- >    )--- >    >>> S.run print------ Finally, systems can be run on a `World` to produce a result.------ > main :: IO ()--- > main = runSystem_ $ setup >>> S.forever move-module Data.Aztecs-  ( Access,-    runAccess,-    Bundle,-    bundle,-    Component (..),-    EntityID,-    Query,-    QueryFilter,-    with,-    without,-    System,-    SystemT,-    Schedule,-    schedule,-    forever,-    runSchedule,-    runSchedule_,-    World,-  )-where--import Data.Aztecs.Access (Access, runAccess)-import Data.Aztecs.Component (Component (..))-import Data.Aztecs.Entity (EntityID)-import Data.Aztecs.Query (Query, QueryFilter, with, without)-import Data.Aztecs.Schedule (Schedule, forever, runSchedule, runSchedule_, schedule)-import Data.Aztecs.System (System, SystemT)-import Data.Aztecs.World (World)-import Data.Aztecs.World.Archetype (Bundle, bundle)

@@ -1,69 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.Access-  ( Access (..),-    runAccess,-    spawn,-    spawn_,-    insert,-    lookup,-    despawn,-  )-where--import Control.Monad.IO.Class (MonadIO)-import Control.Monad.State.Strict (MonadState (..), StateT (..))-import Data.Aztecs.Component (Component (..))-import Data.Aztecs.Entity (EntityID (..))-import Data.Aztecs.World (World (..))-import qualified Data.Aztecs.World as W-import Data.Aztecs.World.Archetype (Bundle (..))-import Data.Data (Typeable)-import Prelude hiding (all, lookup, map)---- | Access into the `World`.-newtype Access m a = Access {unAccess :: StateT World m a}-  deriving (Functor, Applicative, Monad, MonadIO)---- | Run an `Access` on a `World`, returning the output and updated `World`.-runAccess :: (Functor m) => Access m a -> World -> m (a, World)-runAccess a = runStateT $ unAccess a---- | Spawn an entity with a component.-spawn ::-  (Monad m) =>-  Bundle ->-  Access m EntityID-spawn c = Access $ do-  !w <- get-  let !(e, w') = W.spawn c w-  put w'-  return e--spawn_ :: (Monad m) => Bundle -> Access m ()-spawn_ c = do-  _ <- spawn c-  return ()---- | Insert a component into an entity.-insert :: (Monad m, Component a, Typeable (StorageT a)) => EntityID -> a -> Access m ()-insert e c = Access $ do-  !w <- get-  let !w' = W.insert e c w-  put w'--lookup :: (Monad m, Component a) => EntityID -> Access m (Maybe a)-lookup e = Access $ do-  !w <- get-  return $ W.lookup e w--despawn :: (Monad m) => EntityID -> Access m ()-despawn e = Access $ do-  !w <- get-  let !(_, w') = W.despawn e w-  put w'

@@ -1,20 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Aztecs.Component (Component (..), ComponentID (..)) where--import Data.Aztecs.Storage (Storage)-import Data.IntMap.Strict (IntMap)-import Data.Kind (Type)-import Data.Typeable (Typeable)---- | Component ID.-newtype ComponentID = ComponentID {unComponentId :: Int}-  deriving (Eq, Ord, Show)---- | Component that can be stored in the `World`.-class (Typeable a, Storage (StorageT a) a) => Component a where-  -- | `Storage` of this component.-  type StorageT a :: Type -> Type--  type StorageT a = IntMap

@@ -1,5 +0,0 @@-module Data.Aztecs.Entity (EntityID (..)) where---- | Entity ID.-newtype EntityID = EntityID {unEntityId :: Int}-  deriving (Eq, Ord, Show)

@@ -1,318 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Aztecs.Query-  ( -- * Queries-    Query (..),-    entity,-    fetch,-    fetchMaybe,-    set,-    task,-    all,--    -- * Filters-    QueryFilter (..),-    with,-    without,-    DynamicQueryFilter (..),--    -- * Dynamic queries-    DynamicQuery (..),-    entityDyn,-    fetchDyn,-    fetchMaybeDyn,-    setDyn,--    -- * Reads and writes-    ReadsWrites (..),-    disjoint,-  )-where--import Control.Arrow (Arrow (..))-import Control.Category (Category (..))-import Control.Monad (mapM)-import Data.Aztecs.Component-import Data.Aztecs.Entity (EntityID)-import Data.Aztecs.World (World (..))-import Data.Aztecs.World.Archetype (Archetype)-import qualified Data.Aztecs.World.Archetype as A-import Data.Aztecs.World.Archetypes (Node (nodeArchetype))-import qualified Data.Aztecs.World.Archetypes as AS-import Data.Aztecs.World.Components (Components)-import qualified Data.Aztecs.World.Components as CS-import qualified Data.Map.Strict as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Prelude hiding (all, any, id, lookup, map, mapM, reads, (.))---- | 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-newtype Query m i o-  = Query {runQuery :: Components -> (ReadsWrites, Components, DynamicQuery m i o)}--instance (Functor m) => Functor (Query m i) where-  fmap f (Query q) = Query $ \cs -> let (cIds, cs', qS) = q cs in (cIds, cs', fmap f qS)--instance (Monad m) => Applicative (Query m i) where-  pure a = Query $ \cs -> (mempty, cs, pure a)-  (Query f) <*> (Query g) = Query $ \cs ->-    let (cIdsG, cs', aQS) = g cs-        (cIdsF, cs'', bQS) = f cs'-     in (cIdsG <> cIdsF, cs'', bQS <*> aQS)--instance (Monad m) => Category (Query m) where-  id = Query $ \cs -> (mempty, cs, id)-  (Query f) . (Query g) = Query $ \cs ->-    let (cIdsG, cs', aQS) = g cs-        (cIdsF, cs'', bQS) = f cs'-     in (cIdsG <> cIdsF, cs'', bQS . aQS)--instance (Monad m) => Arrow (Query m) 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)---- | Get the currently matched `EntityID`.-entity :: (Applicative m) => Query m () EntityID-entity = Query $ \cs -> (mempty, cs, entityDyn)---- | Fetch a `Component` by its type.-fetch :: forall m a. (Applicative m, Component a) => Query m () (a)-fetch = Query $ \cs ->-  let (cId, cs') = CS.insert @a cs-   in (ReadsWrites (Set.singleton cId) (Set.empty), cs', fetchDyn cId)---- | Fetch a `Component` by its type, returning `Nothing` if it doesn't exist.-fetchMaybe :: forall m a. (Applicative m, Component a) => Query m () (Maybe a)-fetchMaybe = Query $ \cs ->-  let (cId, cs') = CS.insert @a cs-   in (ReadsWrites (Set.singleton cId) (Set.empty), cs', fetchMaybeDyn cId)---- | Set a `Component` by its type.-set :: forall m a. (Applicative m, Component a) => Query m a a-set = Query $ \cs ->-  let (cId, cs') = CS.insert @a cs-   in (ReadsWrites Set.empty (Set.singleton cId), cs', setDyn cId)---- | Run a monadic task in a `Query`.-task :: (Monad m) => (i -> m o) -> Query m i o-task f = Query $ \cs ->-  ( mempty,-    cs,-    DynamicQuery-      { dynQueryAll = \is _ arch -> (,arch) <$> mapM f is,-        dynQueryLookup = \i _ arch -> (\a -> (Just a, arch)) <$> f i-      }-  )---- | Query all matching entities.------ >>> :set -XTypeApplications--- >>> import Data.Aztecs--- >>> import qualified Data.Aztecs.World as W--- >>>--- >>> newtype X = X Int deriving (Show)--- >>> instance Component X--- >>>--- >>> let (_, w) = W.spawn (bundle $ X 0) W.empty--- >>> (xs, _) <- all (fetch @_ @X) w--- >>> xs--- [X 0]-all :: (Monad m) => Query m () a -> World -> m ([a], World)-all q w = do-  let (rws, cs', dynQ) = runQuery q (components w)-  as <--    mapM-      (\n -> fst <$> dynQueryAll dynQ (repeat ()) (A.entities $ nodeArchetype n) (nodeArchetype n))-      (Map.elems $ AS.lookup (reads rws <> writes rws) (archetypes w))-  return (concat as, w {components = cs'})--data ReadsWrites = ReadsWrites-  { reads :: !(Set ComponentID),-    writes :: !(Set ComponentID)-  }-  deriving (Show)--instance Semigroup ReadsWrites where-  ReadsWrites r1 w1 <> ReadsWrites r2 w2 = ReadsWrites (r1 <> r2) (w1 <> w2)--instance Monoid ReadsWrites where-  mempty = ReadsWrites mempty mempty--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)---- | Filter for a `Query`.-newtype QueryFilter = QueryFilter {runQueryFilter :: Components -> (DynamicQueryFilter, Components)}--instance Semigroup QueryFilter where-  a <> b =-    QueryFilter-      ( \cs ->-          let (withA', cs') = runQueryFilter a cs-              (withB', cs'') = runQueryFilter b cs'-           in (withA' <> withB', cs'')-      )--instance Monoid QueryFilter where-  mempty = QueryFilter (mempty,)---- | Filter for entities containing this component.-with :: forall a. (Component a) => QueryFilter-with = QueryFilter $ \cs ->-  let (cId, cs') = CS.insert @a cs in (mempty {filterWith = Set.singleton cId}, cs')---- | Filter out entities containing this component.-without :: forall a. (Component a) => QueryFilter-without = QueryFilter $ \cs ->-  let (cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')--data DynamicQueryFilter = DynamicQueryFilter-  { filterWith :: !(Set ComponentID),-    filterWithout :: !(Set ComponentID)-  }--instance Semigroup DynamicQueryFilter where-  DynamicQueryFilter withA withoutA <> DynamicQueryFilter withB withoutB =-    DynamicQueryFilter (withA <> withB) (withoutA <> withoutB)--instance Monoid DynamicQueryFilter where-  mempty = DynamicQueryFilter mempty mempty---- | Dynamic query for components by ID.-data DynamicQuery m i o = DynamicQuery-  { dynQueryAll :: !([i] -> [EntityID] -> Archetype -> m ([o], Archetype)),-    dynQueryLookup :: !(i -> EntityID -> Archetype -> m (Maybe o, Archetype))-  }--instance (Functor m) => Functor (DynamicQuery m i) where-  fmap f q =-    DynamicQuery-      { dynQueryAll =-          \i es arch -> fmap (\(a, arch') -> (fmap f a, arch')) $ dynQueryAll q i es arch,-        dynQueryLookup = \i eId arch -> fmap (first $ fmap f) $ dynQueryLookup q i eId arch-      }--instance (Monad m) => Applicative (DynamicQuery m i) where-  pure a =-    DynamicQuery-      { dynQueryAll = \_ es arch -> pure (take (length es) $ repeat a, arch),-        dynQueryLookup = \_ _ arch -> pure (Just a, arch)-      }-  f <*> g =-    DynamicQuery-      { dynQueryAll = \i es arch -> do-          (as, arch') <- dynQueryAll g i es arch-          (fs, arch'') <- dynQueryAll f i es arch'-          return (zipWith ($) fs as, arch''),-        dynQueryLookup = \i eId arch -> do-          (res, arch') <- dynQueryLookup g i eId arch-          case res of-            Just a -> do-              (res', arch'') <- dynQueryLookup f i eId arch'-              return (fmap ($) res' <*> Just a, arch'')-            Nothing -> pure (Nothing, arch')-      }--instance (Monad m) => Category (DynamicQuery m) where-  id =-    DynamicQuery-      { dynQueryAll = \as _ arch -> pure (as, arch),-        dynQueryLookup = \a _ arch -> pure (Just a, arch)-      }-  f . g =-    DynamicQuery-      { dynQueryAll = \i es arch -> do-          (as, arch') <- dynQueryAll g i es arch-          dynQueryAll f as es arch',-        dynQueryLookup = \i eId arch -> do-          (res, arch') <- dynQueryLookup g i eId arch-          case res of-            Just a -> dynQueryLookup f a eId arch'-            Nothing -> pure (Nothing, arch')-      }--instance (Monad m) => Arrow (DynamicQuery m) where-  arr f =-    DynamicQuery-      { dynQueryAll = \bs _ arch -> pure (fmap f bs, arch),-        dynQueryLookup = \b _ arch -> pure (Just (f b), arch)-      }-  first f =-    DynamicQuery-      { dynQueryAll = \bds es arch -> do-          let (bs, ds) = unzip bds-          (cs, arch') <- dynQueryAll f bs es arch-          return (zip cs ds, arch'),-        dynQueryLookup = \(b, d) eId arch -> do-          (res, arch') <- dynQueryLookup f b eId arch-          return-            ( case res of-                Just c -> Just (c, d)-                Nothing -> Nothing,-              arch'-            )-      }---- | Fetch the `EntityID` belonging to this entity.-entityDyn :: (Applicative m) => DynamicQuery m i EntityID-entityDyn =-  DynamicQuery-    { dynQueryAll = \_ es arch -> pure (es, arch),-      dynQueryLookup = \_ eId arch -> pure $ (Just eId, arch)-    }---- | Fetch an `Component` by its `ComponentID`.-fetchDyn :: forall m a. (Applicative m, Component a) => ComponentID -> DynamicQuery m () a-fetchDyn cId =-  DynamicQuery-    { dynQueryAll = \_ _ arch -> let !as = A.all cId arch in pure (fmap snd as, arch),-      dynQueryLookup = \_ eId arch -> pure $ (A.lookupComponent eId cId arch, arch)-    }---- | Fetch an `EntityID` and `Component` by its `ComponentID`.-fetchMaybeDyn ::-  forall m a.-  (Applicative m, Component a) =>-  ComponentID ->-  DynamicQuery m () (Maybe a)-fetchMaybeDyn cId =-  DynamicQuery-    { dynQueryAll = \_ _ arch -> let as = A.allMaybe cId arch in pure (fmap snd as, arch),-      dynQueryLookup = \_ eId arch -> pure $ (Just <$> A.lookupComponent eId cId arch, arch)-    }---- | Set a `Component` by its `ComponentID`.-setDyn ::-  forall m a.-  (Applicative m, Component a) =>-  ComponentID ->-  DynamicQuery m a a-setDyn cId =-  DynamicQuery-    { dynQueryAll = \is _ arch -> let !arch' = A.withAscList cId is arch in pure (is, arch'),-      dynQueryLookup =-        \i eId arch -> pure (A.lookupComponent eId cId arch, A.insertComponent eId cId i arch)-    }

@@ -1,70 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Data.Aztecs.Schedule-  ( -- * Schedules-    Schedule (..),-    schedule,-    forever,-    runSchedule,-    runSchedule_,-  )-where--import Control.Arrow (Arrow (..))-import Control.Category (Category (..))-import Control.Monad ((>=>))-import Control.Monad.State (MonadState (..))-import Control.Monad.Trans (MonadTrans (..))-import Data.Aztecs.Access (Access (..), runAccess)-import Data.Aztecs.System (DynamicSystemT (..), SystemT (..))-import qualified Data.Aztecs.View as V-import Data.Aztecs.World (World (..))-import qualified Data.Aztecs.World as W-import Data.Aztecs.World.Components (Components)--newtype Schedule m i o = Schedule {runSchedule' :: Components -> (i -> Access m o, Components)}--instance (Monad m) => Category (Schedule m) where-  id = Schedule $ \cs -> (return, cs)-  Schedule f . Schedule g = Schedule $ \cs ->-    let (g', cs') = g cs-        (f', cs'') = f cs'-     in (g' >=> f', 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')--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') <- runAccess (f i) w {components = cs}-  return (o, w')--runSchedule_ :: (Monad m) => Schedule m () () -> m ()-runSchedule_ s = const () <$> runSchedule s (W.empty) ()--schedule :: (Monad m) => SystemT m i o -> Schedule m i o-schedule t = Schedule $ \cs ->-  let (dynT, _, cs') = runSystemT t cs-      go i = Access $ do-        w <- get-        let f = runSystemTDyn dynT w-        (o, v, access) <- lift $ f i-        ((), w') <- lift Prelude.. runAccess access $ V.unview v w-        put w'-        return o-   in (go, cs')--forever :: (Monad m) => Schedule m i () -> Schedule m i ()-forever s = Schedule $ \cs ->-  let (f, cs') = runSchedule' s cs-      go i = Access $ do-        w <- get-        let loop wAcc = do-              ((), wAcc') <- lift $ runAccess (f i) wAcc-              loop wAcc'-        loop w-   in (go, cs')

@@ -1,37 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.Aztecs.Storage (Storage (..)) where--import Data.Data (Typeable)-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap---- | Component storage, containing zero or many components of the same type.-class (Typeable (s a), Typeable a) => Storage s a where-  -- | Storage with a single component.-  singleton :: Int -> a -> s a--  -- | All components in the storage.-  all :: s a -> [(Int, a)]--  -- | Insert a component into the storage.-  insert :: Int -> a -> s a -> s a--  -- | Lookup a component in the storage.-  lookup :: Int -> s a -> Maybe a--  -- | Convert a sorted list of components (in ascending order) into a storage.-  fromAscList :: [(Int, a)] -> s a--  -- | Remove a component from the storage.-  remove :: Int -> s a -> (Maybe a, s a)--instance (Typeable a) => Storage IntMap a where-  singleton = IntMap.singleton-  all = IntMap.toList-  insert = IntMap.insert-  lookup = IntMap.lookup-  fromAscList = IntMap.fromAscList-  remove i s = (IntMap.lookup i s, IntMap.delete i s) -- TODO remove double lookup

@@ -1,214 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}--module Data.Aztecs.System-  ( -- * Systems-    System,-    SystemT (..),-    queue,-    task,--    -- ** Queries--    -- *** Reading-    all,-    filter,-    single,--    -- *** Writing-    map,-    map_,-    filterMap,-    mapSingle,--    -- * Dynamic SystemTs-    DynamicSystemT (..),-    queueDyn,-    raceDyn,--    -- ** Queries--    -- *** Reading-    allDyn,-    filterDyn,-    singleDyn,--    -- *** Writing-    mapDyn,-    filterMapDyn,-  )-where--import Control.Arrow (Arrow (..))-import Control.Category (Category (..))-import Control.Concurrent.ParallelIO.Global-import Data.Aztecs.Access (Access (..))-import Data.Aztecs.Component (ComponentID)-import Data.Aztecs.Query (DynamicQuery, DynamicQueryFilter (..), Query (..), QueryFilter (..), ReadsWrites)-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.View (View)-import qualified Data.Aztecs.View as V-import Data.Aztecs.World (World (..))-import qualified Data.Aztecs.World.Archetype as A-import Data.Aztecs.World.Archetypes (Node (..))-import Data.Aztecs.World.Components (Components)-import qualified Data.Foldable as F-import Data.Set (Set)-import Prelude hiding (all, filter, map, (.))-import qualified Prelude hiding (filter, map)--type System i o = SystemT IO i o--newtype SystemT m i o = SystemT {runSystemT :: Components -> (DynamicSystemT m i o, ReadsWrites, Components)}-  deriving (Functor)--instance (Monad m) => Category (SystemT m) where-  id = SystemT $ \cs -> (DynamicSystemT $ \_ -> \i -> return (i, mempty, pure ()), mempty, cs)-  SystemT f . SystemT g = SystemT $ \cs ->-    let (f', rwsF, cs') = f cs-        (g', rwsG, cs'') = g cs'-     in (f' . g', rwsF <> rwsG, cs'')--instance Arrow (SystemT IO) where-  arr f = SystemT $ \cs -> (DynamicSystemT $ \_ -> \i -> return (f i, mempty, pure ()), mempty, cs)-  first (SystemT f) = SystemT $ \cs ->-    let (f', rwsF, cs') = f cs-     in (first f', rwsF, cs')-  a &&& b = SystemT $ \cs ->-    let (dynA, rwsA, cs') = runSystemT a cs-        (dynB, rwsB, cs'') = runSystemT b cs'-     in ( if Q.disjoint rwsA rwsB-            then dynA &&& dynB-            else raceDyn dynA dynB,-          rwsA <> rwsB,-          cs''-        )---- | Query all matching entities.-all :: (Monad m) => Query m i a -> SystemT m i [a]-all q = SystemT $ \cs ->-  let !(rws, cs', dynQ) = runQuery q cs-   in (allDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')---- | Query all matching entities with a `QueryFilter`.-filter :: (Monad m) => Query m () a -> QueryFilter -> SystemT m () [a]-filter q qf = SystemT $ \cs ->-  let !(rws, cs', dynQ) = runQuery q cs-      !(dynQf, cs'') = runQueryFilter qf cs'-      qf' n =-        F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)-          && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)-   in (filterDyn (Q.reads rws <> Q.writes rws) dynQ qf', rws, cs'')---- | Query a single matching entity.--- If there are zero or multiple matching entities, an error will be thrown.-single :: (Monad m) => Query m () a -> SystemT m () a-single q =-  fmap-    ( \as -> case as of-        [a] -> a-        _ -> error "TODO"-    )-    (all q)---- | Query all matching entities.-map :: (Monad m) => Query m i a -> SystemT m i [a]-map q = SystemT $ \cs ->-  let !(rws, cs', dynQ) = runQuery q cs-   in (mapDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')--map_ :: (Monad m) => Query m i o -> SystemT m i ()-map_ q = const () <$> map q---- | Map all matching entities with a `QueryFilter`, storing the updated entities.-filterMap :: (Monad m) => Query m i a -> QueryFilter -> SystemT m i [a]-filterMap q qf = SystemT $ \cs ->-  let !(rws, cs', dynQ) = runQuery q cs-      !(dynQf, cs'') = runQueryFilter qf cs'-      f' n =-        F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)-          && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)-   in (filterMapDyn (Q.reads rws <> Q.writes rws) dynQ f', rws, cs'')---- | Map a single matching entity, storing the updated components.--- If there are zero or multiple matching entities, an error will be thrown.-mapSingle :: (Monad m) => Query m i a -> SystemT m i a-mapSingle q =-  fmap-    ( \as -> case as of-        [a] -> a-        _ -> error "TODO"-    )-    (map q)--queue :: (Monad m) => (i -> Access m ()) -> SystemT m i ()-queue f = SystemT $ \cs -> (queueDyn f, mempty, cs)--task :: (Monad m) => (i -> m o) -> SystemT m i o-task f = SystemT $ \cs ->-  ( DynamicSystemT $ \_ -> \i -> do-      o <- f i-      return (o, mempty, pure ()),-    mempty,-    cs-  )--newtype DynamicSystemT m i o = DynamicSystemT {runSystemTDyn :: World -> (i -> m (o, View, Access m ()))}-  deriving (Functor)--instance (Monad m) => Category (DynamicSystemT m) where-  id = DynamicSystemT $ \_ -> \i -> return (i, mempty, pure ())-  DynamicSystemT f . DynamicSystemT g = DynamicSystemT $ \w -> \i -> do-    (b, gView, gAccess) <- g w i-    (a, fView, fAccess) <- f w b-    return (a, gView <> fView, gAccess >> fAccess)--instance (Monad m) => Arrow (DynamicSystemT m) where-  arr f = DynamicSystemT $ \_ -> \i -> return (f i, mempty, pure ())-  first (DynamicSystemT f) = DynamicSystemT $ \w -> \(i, x) -> do-    (a, v, access) <- f w i-    return ((a, x), v, access)---- | Query all matching entities.-allDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> DynamicSystemT m i [o]-allDyn cIds q = DynamicSystemT $ \w ->-  let !v = V.view cIds $ archetypes w-   in \i -> fmap (\(a, _) -> (a, mempty, pure ())) (V.allDyn i q v)--filterDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> (Node -> Bool) -> DynamicSystemT m i [o]-filterDyn cIds q f = DynamicSystemT $ \w ->-  let !v = V.filterView cIds f $ archetypes w-   in \i -> fmap (\(a, _) -> (a, mempty, pure ())) (V.allDyn i q v)--singleDyn :: (Monad m) => Set ComponentID -> DynamicQuery m () a -> DynamicSystemT m () a-singleDyn cIds q =-  fmap-    ( \as -> case as of-        [a] -> a-        _ -> error "TODO"-    )-    (allDyn cIds q)---- | Map all matching entities, storing the updated entities.-mapDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> DynamicSystemT m i [o]-mapDyn cIds q = DynamicSystemT $ \w ->-  let !v = V.view cIds $ archetypes w-   in \i -> fmap (\(a, v') -> (a, v', pure ())) (V.allDyn i q v)--filterMapDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> (Node -> Bool) -> DynamicSystemT m i [o]-filterMapDyn cIds q f = DynamicSystemT $ \w ->-  let !v = V.filterView cIds f $ archetypes w-   in \i -> fmap (\(a, v') -> (a, v', pure ())) (V.allDyn i q v)--queueDyn :: (Monad m) => (i -> Access m ()) -> DynamicSystemT m i ()-queueDyn f = DynamicSystemT $ \_ -> \i -> return ((), mempty, f i)--raceDyn :: DynamicSystemT IO i a -> DynamicSystemT IO i b -> DynamicSystemT IO i (a, b)-raceDyn (DynamicSystemT f) (DynamicSystemT g) = DynamicSystemT $ \w -> \i -> do-  results <- parallel [fmap (\a -> (Just a, Nothing)) $ f w i, fmap (\b -> (Nothing, Just b)) $ g w i]-  ((a, v, fAccess), (b, v', gAccess)) <- case results of-    [(Just a, _), (_, Just b)] -> return (a, b)-    _ -> error "joinDyn: exception"-  return ((a, b), v <> v', fAccess >> gAccess)

@@ -1,70 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.View-  ( View (..),-    view,-    filterView,-    unview,-    allDyn,-  )-where--import Data.Aztecs.Query (DynamicQuery (..))-import Data.Aztecs.World (World)-import qualified Data.Aztecs.World as W-import qualified Data.Aztecs.World.Archetype as A-import Data.Aztecs.World.Archetypes (ArchetypeID, Archetypes, Node (..))-import qualified Data.Aztecs.World.Archetypes as AS-import Data.Aztecs.World.Components (ComponentID)-import Data.Foldable (foldlM)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Set (Set)--#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif---- | View into a `World`, containing a subset of archetypes.-newtype View = View {viewArchetypes :: Map ArchetypeID Node}-  deriving (Show, Semigroup, Monoid)---- | View into all archetypes containing the provided component IDs.-view :: Set ComponentID -> Archetypes -> View-view cIds as = View $ AS.lookup cIds as---- | View into all archetypes containing the provided component IDs and matching the provided predicate.-filterView ::-  Set ComponentID ->-  (Node -> Bool) ->-  Archetypes ->-  View-filterView cIds f as = View $ Map.filter f (AS.lookup cIds as)---- | "Un-view" a `View` back into a `World`.-unview :: View -> World -> World-unview v w =-  w-    { W.archetypes =-        foldl'-          (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)})-          (W.archetypes w)-          (Map.toList $ viewArchetypes v)-    }---- | Query all matching entities in a `View`.-allDyn :: (Monad m) => i -> DynamicQuery m i a -> View -> m ([a], View)-allDyn i q v =-  fmap (\(as, arches) -> (as, View arches)) $-    foldlM-      ( \(acc, archAcc) (aId, n) -> do-          (as, arch') <- dynQueryAll q (repeat i) (A.entities (nodeArchetype n)) (nodeArchetype n)-          return (as ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)-      )-      ([], Map.empty)-      (Map.toList $ viewArchetypes v)

@@ -1,279 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE BangPatterns #-}--module Data.Aztecs.World-  ( World (..),-    empty,-    spawn,-    spawnComponent,-    spawnWithId,-    spawnWithArchetypeId,-    spawnEmpty,-    insert,-    insertWithId,-    lookup,-    despawn,-  )-where--import Data.Aztecs.Component-  ( Component (..),-    ComponentID,-  )-import Data.Aztecs.Entity (EntityID (..))-import Data.Aztecs.World.Archetype (Archetype (..), Bundle (..), DynamicBundle (..))-import qualified Data.Aztecs.World.Archetype as A-import Data.Aztecs.World.Archetypes (ArchetypeID, Archetypes, Node (..))-import qualified Data.Aztecs.World.Archetypes as AS-import Data.Aztecs.World.Components (Components (..))-import qualified Data.Aztecs.World.Components as CS-import Data.Dynamic (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 Prelude hiding (lookup)--#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif---- | World of entities and their components.-data World = World-  { archetypes :: !Archetypes,-    components :: !Components,-    entities :: !(Map EntityID ArchetypeID),-    nextEntityId :: !EntityID-  }-  deriving (Show)---- | Empty `World`.-empty :: World-empty =-  World-    { archetypes = AS.empty,-      components = CS.empty,-      entities = mempty,-      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}---- | 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)})---- | 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 ->-  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)-        }---- | 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 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 -> case AS.lookupNode aId (archetypes w) of-    Just node ->-      if Set.member cId (nodeComponentIds node)-        then w {archetypes = (archetypes w) {AS.nodes = Map.adjust (\n -> n {nodeArchetype = A.insertComponent e cId c (nodeArchetype n)}) aId (AS.nodes $ archetypes w)}}-        else case AS.lookupArchetypeId (Set.insert cId (nodeComponentIds node)) (archetypes w) of-          Just nextAId ->-            let !(cs, arch') = A.remove e (nodeArchetype node)-                !w' = w {archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}}-                f archAcc (itemCId, dyn) =-                  archAcc-                    { A.storages =-                        Map.adjust-                          (\s -> s {A.storageDyn = A.insertDyn s (unEntityId e) dyn (A.storageDyn s)})-                          itemCId-                          (A.storages archAcc)-                    }-             in w'-                  { archetypes =-                      (archetypes w')-                        { AS.nodes =-                            Map.adjust-                              ( \nextNode ->-                                  nextNode-                                    { nodeArchetype =-                                        A.insertComponent e cId c $-                                          foldl'-                                            f-                                            (nodeArchetype nextNode)-                                            (Map.toList cs)-                                    }-                              )-                              nextAId-                              (AS.nodes $ archetypes w')-                        },-                    entities = Map.insert e nextAId (entities w')-                  }-          Nothing ->-            let !(s, arch') = A.removeStorages e (nodeArchetype node)-                !n =-                  Node-                    { nodeComponentIds = Set.insert cId (nodeComponentIds node),-                      nodeArchetype = A.insertComponent e cId c (Archetype {A.storages = s}),-                      nodeAdd = Map.empty,-                      nodeRemove = Map.singleton cId aId-                    }-                !(nextAId, arches) = AS.insertArchetype (Set.insert cId (nodeComponentIds node)) n (archetypes w)-             in w-                  { archetypes =-                      arches-                        { AS.nodes =-                            Map.insert-                              aId-                              node-                                { nodeArchetype = arch',-                                  nodeAdd = Map.insert cId nextAId (nodeAdd node)-                                }-                              (AS.nodes arches)-                        },-                    entities = Map.insert e nextAId (entities w)-                  }-    Nothing -> w-  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 -> 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)---- | 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)

@@ -1,207 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--module Data.Aztecs.World.Archetype-  ( Archetype (..),-    empty,-    all,-    allMaybe,-    entities,-    lookupComponent,-    lookupStorage,-    member,-    remove,-    removeStorages,-    insertComponent,-    insertAscList,-    withAscList,-    Bundle (..),-    bundle,-    runBundle,-    DynamicBundle (..),-    dynBundle,-    AnyStorage (..),-    anyStorage,-  )-where--import Data.Aztecs.Component (Component (..), ComponentID)-import Data.Aztecs.Entity (EntityID (..))-import qualified Data.Aztecs.Storage as S-import Data.Aztecs.World.Components (Components)-import qualified Data.Aztecs.World.Components as CS-import Data.Bifunctor (Bifunctor (..))-import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)-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 Prelude hiding (all, lookup)--#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])-  }--instance Show AnyStorage where-  show s = "AnyStorage " ++ show (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 -> []-    }--newtype Archetype = Archetype {storages :: Map ComponentID AnyStorage}-  deriving (Show)--empty :: Archetype-empty = Archetype {storages = Map.empty}--lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a a)-lookupStorage cId w = do-  dynS <- Map.lookup cId (storages w)-  fromDynamic (storageDyn dynS)--insertComponent :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype-insertComponent e cId c arch =-  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--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)--lookupComponent :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a-lookupComponent e cId w = lookupStorage cId w >>= S.lookup (unEntityId e)--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'}--remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)-remove e arch =-  foldl'-    ( \(dynAcc, archAcc) (cId, s) ->-        let !(dynA, dynS) = removeDyn s (unEntityId e) (storageDyn 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)}-            )-    )-    (Map.empty, arch)-    (Map.toList $ storages arch)--removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)-removeStorages e arch =-  foldl'-    ( \(dynAcc, archAcc) (cId, s) ->-        let (dynA, dynS) = removeAny s (unEntityId e) (storageDyn 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)}-            )-    )-    (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')

@@ -1,123 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Aztecs.World.Archetypes-  ( ArchetypeID (..),-    Node (..),-    Archetypes (..),-    empty,-    insertArchetype,-    lookupArchetypeId,-    findArchetypeIds,-    lookupNode,-    lookup,-    map,-    adjustArchetype,-  )-where--import Data.Aztecs.Component (ComponentID)-import Data.Aztecs.World.Archetype hiding (empty)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import Prelude hiding (all, lookup, map)--#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif---- | `Archetype` ID.-newtype ArchetypeID = ArchetypeID {unArchetypeId :: Int}-  deriving (Eq, Ord, Show)---- | Node in `Archetypes`.-data Node = Node-  { -- | Unique set of `ComponentID`s of this `Node`.-    nodeComponentIds :: !(Set ComponentID),-    -- | `Archetype` of this `Node`.-    nodeArchetype :: !Archetype,-    -- | Edges to other `Archetype`s by adding a `ComponentID`.-    nodeAdd :: !(Map ComponentID ArchetypeID),-    -- | Edges to other `Archetype`s by removing a `ComponentID`.-    nodeRemove :: !(Map ComponentID ArchetypeID)-  }-  deriving (Show)---- | `Archetype` graph.-data Archetypes = Archetypes-  { -- | Archetype nodes in the graph.-    nodes :: !(Map ArchetypeID Node),-    -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.-    archetypeIds :: !(Map (Set ComponentID) ArchetypeID),-    -- | Next unique `ArchetypeID`.-    nextArchetypeId :: !ArchetypeID,-    -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.-    componentIds :: !(Map ComponentID (Set ArchetypeID))-  }-  deriving (Show)---- | Empty `Archetypes`.-empty :: Archetypes-empty =-  Archetypes-    { nodes = mempty,-      archetypeIds = mempty,-      nextArchetypeId = ArchetypeID 0,-      componentIds = mempty-    }---- | Insert an archetype by its set of `ComponentID`s.-insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)-insertArchetype cIds n arches =-  let aId = nextArchetypeId arches-   in ( aId,-        arches-          { nodes = Map.insert aId n (nodes arches),-            archetypeIds = Map.insert cIds aId (archetypeIds arches),-            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1),-            componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches)-          }-      )--adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes-adjustArchetype aId f arches = arches {nodes = Map.adjust (\node -> node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}---- | Find `ArchetypeID`s containing a set of `ComponentID`s.-findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID-findArchetypeIds cIds arches = case mapMaybe (\cId -> Map.lookup cId (componentIds arches)) (Set.elems cIds) of-  (aId : aIds') -> foldl' Set.intersection aId aIds'-  [] -> Set.empty---- | Lookup `Archetype`s containing a set of `ComponentID`s.-lookup :: Set ComponentID -> Archetypes -> Map ArchetypeID Node-lookup 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 !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)--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)

@@ -1,56 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.World.Components-  ( ComponentID (..),-    Components (..),-    empty,-    lookup,-    insert,-    insert',-  )-where--import Data.Aztecs.Component (Component, ComponentID (..))-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Typeable (Proxy (..), TypeRep, Typeable, typeOf)-import Prelude hiding (lookup)---- | Component ID map.-data Components = Components-  { componentIds :: !(Map TypeRep ComponentID),-    nextComponentId :: !ComponentID-  }-  deriving (Show)---- | Empty `Components`.-empty :: Components-empty =-  Components-    { componentIds = mempty,-      nextComponentId = ComponentID 0-    }---- | Lookup a component ID by type.-lookup :: forall a. (Typeable a) => Components -> Maybe ComponentID-lookup cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs)---- | Insert a component ID by type, if it does not already exist.-insert :: forall a. (Component a) => Components -> (ComponentID, Components)-insert cs = case lookup @a cs of-  Just cId -> (cId, cs)-  Nothing -> insert' @a cs---- | Insert a component ID by type.-insert' :: forall c. (Component c) => Components -> (ComponentID, Components)-insert' cs =-  let !cId = nextComponentId cs-   in ( cId,-        cs-          { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs),-            nextComponentId = ComponentID (unComponentId cId + 1)-          }-      )

@@ -1,45 +1,52 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Main (main) where +import Aztecs+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.World as W+import Aztecs.Hierarchy (Children (..), Parent (..))+import qualified Aztecs.Hierarchy as Hierarchy import Control.Arrow ((&&&))-import Data.Aztecs-import qualified Data.Aztecs.Query as Q-import qualified Data.Aztecs.World as W-import Data.Functor.Identity (Identity (..))+import Control.DeepSeq+import qualified Data.Set as Set+import GHC.Generics import Test.Hspec import Test.QuickCheck -newtype X = X Int deriving (Eq, Show, Arbitrary)+newtype X = X Int deriving (Eq, Show, Arbitrary, Generic, NFData)  instance Component X -newtype Y = Y Int deriving (Eq, Show, Arbitrary)+newtype Y = Y Int deriving (Eq, Show, Arbitrary, Generic, NFData)  instance Component Y -newtype Z = Z Int deriving (Eq, Show, Arbitrary)+newtype Z = Z Int deriving (Eq, Show, Arbitrary, Generic, NFData)  instance Component Z  main :: IO () main = hspec $ do-  describe "Data.Aztecs.Query.all" $ do+  describe "Aztecs.ECS.Query.all" $ do     it "queries a single component" $ property prop_queryOneComponent     it "queries two components" $ property prop_queryTwoComponents     it "queries three components" $ property prop_queryThreeComponents+  describe "Aztecs.ECS.Hierarchy.update" $ do+    it "adds Parent components to children" $ property prop_addParents  prop_queryOneComponent :: [X] -> Expectation prop_queryOneComponent xs =   let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs-      (res, _) = runIdentity $ Q.all Q.fetch w+      (res, _) = Q.all Q.fetch 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, _) = runIdentity $ Q.all (Q.fetch &&& Q.fetch) w+      (res, _) = Q.all (Q.fetch &&& Q.fetch) w    in res `shouldMatchList` xys  prop_queryThreeComponents :: [(X, Y, Z)] -> Expectation@@ -50,5 +57,13 @@         y <- Q.fetch         z <- Q.fetch         pure (x, y, z)-      (res, _) = runIdentity $ Q.all q w+      (res, _) = Q.all q 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''+  res `shouldMatchList` [Parent e]