aztecs 0.3.0.0 → 0.4.0.0

raw patch · 18 files changed

+1718/−1832 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +29/−29
• aztecs.cabal +74/−75
• bench/Iter.hs +31/−31
• examples/ECS.hs +35/−33
• src/Data/Aztecs.hs +77/−21
• src/Data/Aztecs/Access.hs +62/−90
• src/Data/Aztecs/Component.hs +20/−19
• src/Data/Aztecs/Entity.hs +5/−215
• src/Data/Aztecs/Query.hs +317/−231
• src/Data/Aztecs/Scheduler.hs +0/−231
• src/Data/Aztecs/Storage.hs +37/−37
• src/Data/Aztecs/System.hs +308/−137
• src/Data/Aztecs/View.hs +65/−80
• src/Data/Aztecs/World.hs +250/−257
• src/Data/Aztecs/World/Archetype.hs +203/−138
• src/Data/Aztecs/World/Archetypes.hs +117/−114
• src/Data/Aztecs/World/Components.hs +55/−55
• test/Main.hs +33/−39

@@ -1,29 +1,29 @@-Copyright (c) 2024, Matt Hunzinger
-
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of the copyright holder nor the names of its
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2024, Matt Hunzinger+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,75 +1,74 @@-cabal-version: 2.4
-name:          aztecs
-version:       0.3.0.0
-license:       BSD-3-Clause
-license-file:  LICENSE
-maintainer:    matt@hunzinger.me
-author:        Matt Hunzinger
-synopsis:      A type-safe and friendly Entity-Component-System (ECS) for Haskell
-description:   The Entity-Component-System (ECS) pattern is commonly used in video game develop to represent world objects.
-               .
-               ECS follows the principal of composition over inheritence. Each type of
-               object (e.g. sword, monster, etc), in the game has a unique EntityId. Each
-               entity has various Components associated with it (material, weight, damage, etc).
-               Systems act on entities which have the required Components.
-homepage:      https://github.com/matthunz/aztecs
-category:      Game Engine
-
-source-repository head
-    type:     git
-    location: https://github.com/matthunz/aztecs.git
-
-library
-    exposed-modules:
-        Data.Aztecs
-        Data.Aztecs.Access
-        Data.Aztecs.Component
-        Data.Aztecs.Entity
-        Data.Aztecs.Query
-        Data.Aztecs.Scheduler
-        Data.Aztecs.Storage
-        Data.Aztecs.System
-        Data.Aztecs.View
-        Data.Aztecs.World
-        Data.Aztecs.World.Archetype
-        Data.Aztecs.World.Archetypes
-        Data.Aztecs.World.Components
-
-    hs-source-dirs:   src
-    default-language: Haskell2010
-    ghc-options:      -Wall
-    build-depends:
-        base >=4 && <5,
-        containers >=0.7,
-        mtl >=2
-
-executable ecs
-    main-is:          ECS.hs
-    hs-source-dirs:   examples
-    default-language: Haskell2010
-    ghc-options:      -Wall
-    build-depends:
-        base >=4 && <5,
-        aztecs
-
-test-suite aztecs-test
-    type:             exitcode-stdio-1.0
-    main-is:          Main.hs
-    hs-source-dirs:   test
-    default-language: Haskell2010
-    ghc-options:      -Wall
-    build-depends:
-        base >=4 && <5,
-        aztecs,
-        hspec >=2
-
-benchmark aztecs-bench
-    type:             exitcode-stdio-1.0
-    main-is:          Iter.hs
-    hs-source-dirs:   bench
-    default-language: Haskell2010
-    ghc-options:      -Wall
-    build-depends:
-        base >=4 && <5,
-        aztecs,
-        criterion >=1
+cabal-version: 2.4+name:          aztecs+version:       0.4.0.0+license:       BSD-3-Clause+license-file:  LICENSE+maintainer:    matt@hunzinger.me+author:        Matt Hunzinger+synopsis:      A type-safe and friendly Entity-Component-System (ECS) for Haskell+description:   The Entity-Component-System (ECS) pattern is commonly used in video game develop to represent world objects.+               .+               ECS follows the principal of composition over inheritence. Each type of+               object (e.g. sword, monster, etc), in the game has a unique EntityId. Each+               entity has various Components associated with it (material, weight, damage, etc).+               Systems act on entities which have the required Components.+homepage:      https://github.com/matthunz/aztecs+category:      Game Engine++source-repository head+    type:     git+    location: https://github.com/matthunz/aztecs.git++library+    exposed-modules:+        Data.Aztecs+        Data.Aztecs.Access+        Data.Aztecs.Component+        Data.Aztecs.Entity+        Data.Aztecs.Query+        Data.Aztecs.Storage+        Data.Aztecs.System+        Data.Aztecs.View+        Data.Aztecs.World+        Data.Aztecs.World.Archetype+        Data.Aztecs.World.Archetypes+        Data.Aztecs.World.Components++    hs-source-dirs:   src+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4 && <5,+        containers >=0.7,+        mtl >=2++executable ecs+    main-is:          ECS.hs+    hs-source-dirs:   examples+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4 && <5,+        aztecs++test-suite aztecs-test+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4 && <5,+        aztecs,+        hspec >=2++benchmark aztecs-bench+    type:             exitcode-stdio-1.0+    main-is:          Iter.hs+    hs-source-dirs:   bench+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4 && <5,+        aztecs,+        criterion >=1

@@ -1,31 +1,31 @@-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
-import Criterion.Main
-import Data.Aztecs
-import qualified Data.Aztecs.Query as Q
-import Data.Aztecs.World (World)
-import qualified Data.Aztecs.World as W
-
-newtype Position = Position Int deriving (Show)
-
-instance Component Position
-
-newtype Velocity = Velocity Int deriving (Show)
-
-instance Component Velocity
-
-run :: World -> World
-run w = let !(_, w') = Q.mapWorld (\(Velocity v :& Position x) -> Position (x + v)) w in w'
-
-main :: IO ()
-main = do
-  let !w =
-        foldr
-          ( \_ wAcc ->
-              let (e, wAcc') = W.spawn (Position 0) wAcc
-               in W.insert e (Velocity 1) wAcc'
-          )
-          W.empty
-          [0 :: Int .. 10000]
-  defaultMain [bench "iter" $ whnf run w]
+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Criterion.Main+import Data.Aztecs+import qualified Data.Aztecs.Query as Q+import Data.Aztecs.World (World)+import qualified Data.Aztecs.World as W++newtype Position = Position Int deriving (Show)++instance Component Position++newtype Velocity = Velocity Int deriving (Show)++instance Component Velocity++run :: World -> World+run w = let !(_, w') = Q.mapWorld (\(Velocity v :& Position x) -> Position (x + v)) w in w'++main :: IO ()+main = do+  let !w =+        foldr+          ( \_ wAcc ->+              let (e, wAcc') = W.spawn (Position 0) wAcc+               in W.insert e (Velocity 1) wAcc'+          )+          W.empty+          [0 :: Int .. 10000]+  defaultMain [bench "iter" $ whnf run w]

@@ -1,33 +1,35 @@-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Main where
-
-import Control.Arrow ((>>>))
-import Data.Aztecs
-import qualified Data.Aztecs.Access as A
-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
-
-data Setup
-
-instance System IO Setup where
-  task = S.queue (A.spawn_ (Position 0 :& Velocity 1))
-
-data Movement
-
-instance System IO Movement where
-  task = S.map (\(Position x :& Velocity v) -> Position (x + v)) >>> S.run print
-
-app :: Scheduler IO
-app = schedule @_ @Startup @Setup [] <> schedule @_ @Update @Movement []
-
-main :: IO ()
-main = run app
+{-# LANGUAGE Arrows #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}++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.run print++main :: IO ()+main = runSystem_ $ setup >>> S.forever move

@@ -1,21 +1,77 @@-module Data.Aztecs
-  ( Access,
-    runAccess,
-    Component (..),
-    EntityID,
-    Entity,
-    (:&) (..),
-    System (..),
-    Scheduler,
-    Startup,
-    Update,
-    run,
-    schedule,
-  )
-where
-
-import Data.Aztecs.Access (Access, runAccess)
-import Data.Aztecs.Component (Component (..))
-import Data.Aztecs.Entity (Entity, EntityID, (:&) (..))
-import Data.Aztecs.Scheduler (Scheduler, Startup, Update, run, schedule)
-import Data.Aztecs.System (System (..))
+-- | 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,+    System,+    SystemT (..),+    Query,+    QueryFilter,+    with,+    without,+    runSystem,+    runSystem_,+    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.System (System, SystemT (..), runSystem, runSystem_)+import Data.Aztecs.World (World)+import Data.Aztecs.World.Archetype (Bundle, bundle)

@@ -1,90 +1,62 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Aztecs.Access
-  ( Access (..),
-    runAccess,
-    spawn,
-    spawn_,
-    insert,
-    all,
-    map,
-    lookup,
-    lookupQuery,
-    alter,
-  )
-where
-
-import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.State (MonadState (..), StateT (..), gets)
-import Data.Aztecs.Component (Component (..))
-import Data.Aztecs.Entity (ComponentIds, Entity, EntityID, EntityT, FromEntity (..), ToEntity)
-import Data.Aztecs.Query (IsEq, Map, Query, Queryable (..))
-import qualified Data.Aztecs.Query as Q
-import Data.Aztecs.World (World)
-import qualified Data.Aztecs.World as W
-import Data.Aztecs.World.Archetype (Insert)
-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 :: Access m a -> World -> m (a, World)
-runAccess a = runStateT (unAccess a)
-
--- | Spawn an entity with a component.
-spawn ::
-  (Monad m, ComponentIds (EntityT a), ToEntity a, Insert (Entity (EntityT a))) =>
-  a ->
-  Access m EntityID
-spawn c = Access $ do
-  w <- get
-  let (e, w') = W.spawn c w
-  put w'
-  return e
-
-spawn_ :: (Monad m, ComponentIds (EntityT a), ToEntity a, Insert (Entity (EntityT a))) => a -> 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'
-
-all :: forall m a. (Monad m, ToEntity a, FromEntity a, Queryable (EntityT a)) => Access m [a]
-all = Access $ gets (fmap fromEntity . Q.queryAll (query @(EntityT a)))
-
--- | Map over all entities that match this query,
--- storing the resulting components in the @World@.
-map ::
-  forall m i o.
-  (Monad m, Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o) =>
-  (i -> o) ->
-  Access m [o]
-map f = Access $ do
-  w <- get
-  let (out, w') = Q.map @i @o f w
-  put w'
-  return out
-
-alter :: forall a m. (Monad m, FromEntity a, ToEntity a, Queryable (EntityT a)) => EntityID -> (a -> a) -> Access m ()
-alter eId f = Access $ do
-  w <- get
-  let w' = Q.alter eId f w
-  put w'
-
-lookup :: forall a m. (Monad m, FromEntity a, Queryable (EntityT a)) => EntityID -> Access m (Maybe a)
-lookup eId = Access . gets $ Q.lookup eId
-
-lookupQuery :: (Monad m) => EntityID -> Query a -> Access m (Maybe (Entity a))
-lookupQuery eId q = Access . gets $ Q.lookupQuery eId q
+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Aztecs.Access+  ( Access (..),+    runAccess,+    spawn,+    spawn_,+    insert,+    despawn,+  )+where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.State (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'++despawn :: (Monad m) => EntityID -> Access m ()+despawn e = Access $ do+  w <- get+  let (_, w') = W.despawn e w+  put w'

@@ -1,19 +1,20 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Data.Aztecs.Component (Component (..), ComponentID (..)) where
-
-import Data.Aztecs.Storage (Storage)
-import Data.IntMap (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
+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Aztecs.Component (Component (..), ComponentID (..)) where++import Data.Aztecs.Storage (Storage)+import Data.IntMap (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,215 +1,5 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Data.Aztecs.Entity
-  ( EntityID (..),
-    Entity (..),
-    EntityT,
-    FromEntity (..),
-    ToEntity (..),
-    ConcatT,
-    IntersectT,
-    Intersect (..),
-    DifferenceT,
-    Difference (..),
-    SplitT,
-    Split (..),
-    Has (..),
-    Sort (..),
-    ComponentIds(..),
-    concat,
-    (<&>),
-    (:&) (..),
-  )
-where
-
-import Data.Aztecs.Component (Component, ComponentID)
-import Data.Aztecs.World.Components (Components)
-import qualified Data.Aztecs.World.Components as CS
-import Data.Kind (Type)
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Prelude hiding (concat)
-
--- | Entity ID.
-newtype EntityID = EntityID {unEntityId :: Int}
-  deriving (Eq, Ord, Show)
-
-data Entity (ts :: [Type]) where
-  ENil :: Entity '[]
-  ECons :: t -> Entity ts -> Entity (t ': ts)
-
-instance Show (Entity '[]) where
-  show ENil = "[]"
-
-instance (Show a, Show' (Entity as)) => Show (Entity (a ': as)) where
-  show (ECons x xs) = "[" ++ show x ++ showRow xs
-
-class Show' a where
-  showRow :: a -> String
-
-instance Show' (Entity '[]) where
-  showRow ENil = "]"
-
-instance (Show a, Show' (Entity as)) => Show' (Entity (a ': as)) where
-  showRow (ECons x xs) = ", " ++ show x ++ showRow xs
-
-instance Eq (Entity '[]) where
-  ENil == ENil = True
-
-instance (Eq a, Eq (Entity as)) => Eq (Entity (a ': as)) where
-  ECons x xs == ECons y ys = x == y && xs == ys
-
-(<&>) :: Entity as -> a -> Entity (a : as)
-(<&>) es c = ECons c es
-
-type family ConcatT (a :: [Type]) (b :: [Type]) where
-  ConcatT '[] b = b
-  ConcatT (a ': as) b = a ': ConcatT as b
-
-concat :: Entity as -> Entity bs -> Entity (ConcatT as bs)
-concat ENil ys = ys
-concat (ECons x xs) ys = ECons x (concat xs ys)
-
-type family SplitT (a :: [Type]) (b :: [Type]) :: [Type] where
-  SplitT '[] bs = bs
-  SplitT (a ': as) (a ': bs) = SplitT as bs
-
-class Split (a :: [Type]) (b :: [Type]) where
-  split :: Entity b -> (Entity a, Entity (SplitT a b))
-
-instance Split '[] bs where
-  split e = (ENil, e)
-
-instance forall a as bs. (Split as bs) => Split (a ': as) (a ': bs) where
-  split (ECons x xs) =
-    let (as, bs) = split @as xs
-     in (ECons x as, bs)
-
-data a :& b = a :& b
-
-type family EntityT a where
-  EntityT (a :& b) = a ': EntityT b
-  EntityT (Entity ts) = ts
-  EntityT a = '[a]
-
-class FromEntity a where
-  fromEntity :: Entity (EntityT a) -> a
-
-instance {-# OVERLAPS #-} (EntityT a ~ '[a]) => FromEntity a where
-  fromEntity (ECons a ENil) = a
-
-instance FromEntity (Entity ts) where
-  fromEntity = id
-
-instance (FromEntity a, FromEntity b, EntityT (a :& b) ~ (a ': EntityT b)) => FromEntity (a :& b) where
-  fromEntity (ECons a rest) = a :& fromEntity rest
-
-class ToEntity a where
-  toEntity :: a -> Entity (EntityT a)
-
-instance {-# OVERLAPS #-} (EntityT a ~ '[a]) => ToEntity a where
-  toEntity a = ECons a ENil
-
-instance ToEntity (Entity ts) where
-  toEntity = id
-
-instance (ToEntity a, ToEntity b, EntityT (a :& b) ~ (a ': EntityT b)) => ToEntity (a :& b) where
-  toEntity (a :& b) = ECons a (toEntity b)
-
-type family ElemT (a :: Type) (b :: [Type]) :: Bool where
-  ElemT a '[] = 'False
-  ElemT a (a ': as) = 'True
-  ElemT a (b ': as) = ElemT a as
-
-type family If (cond :: Bool) (true :: [Type]) (false :: [Type]) :: [Type] where
-  If 'True true false = true
-  If 'False true false = false
-
-type family IntersectT (a :: [Type]) (b :: [Type]) :: [Type] where
-  IntersectT '[] b = '[]
-  IntersectT (a ': as) b = If (ElemT a b) (a ': IntersectT as b) (IntersectT as b)
-
-class Intersect' (flag :: Bool) (a :: [Type]) (b :: [Type]) where
-  intersect' :: Entity a -> Entity b -> Entity (IntersectT a b)
-
-instance (Intersect as b, ElemT a b ~ 'True) => Intersect' 'True (a ': as) b where
-  intersect' (ECons x xs) ys = ECons x (xs `intersect` ys)
-
-instance (Intersect as (b ': bs), ElemT a (b ': bs) ~ 'False) => Intersect' 'False (a ': as) (b ': bs) where
-  intersect' (ECons _ xs) = intersect xs
-
-class Intersect (a :: [Type]) (b :: [Type]) where
-  intersect :: Entity a -> Entity b -> Entity (IntersectT a b)
-
-instance Intersect '[] b where
-  intersect _ _ = ENil
-
-instance (Intersect' (ElemT a bs) (a ': as) bs) => Intersect (a ': as) bs where
-  intersect = intersect' @(ElemT a bs)
-
-type family DifferenceT (a :: [Type]) (b :: [Type]) :: [Type] where
-  DifferenceT '[] b = '[]
-  DifferenceT (a ': as) b = If (ElemT a b) (DifferenceT as b) (a ': DifferenceT as b)
-
-class Difference' (flag :: Bool) (a :: [Type]) (b :: [Type]) where
-  difference' :: Entity a -> Entity b -> Entity (DifferenceT a b)
-
-instance (Difference as b, DifferenceT (a ': as) b ~ DifferenceT as b) => Difference' 'True (a ': as) b where
-  difference' (ECons _ xs) ys = xs `difference` ys
-
-instance (Difference as (b ': bs), DifferenceT (a ': as) (b ': bs) ~ (a ': DifferenceT as (b ': bs))) => Difference' 'False (a ': as) (b ': bs) where
-  difference' (ECons x xs) ys = ECons x (xs `difference` ys)
-
-class Difference (a :: [Type]) (b :: [Type]) where
-  difference :: Entity a -> Entity b -> Entity (DifferenceT a b)
-
-instance Difference '[] b where
-  difference _ _ = ENil
-
-instance (Difference' (ElemT a bs) (a ': as) bs) => Difference (a ': as) bs where
-  difference = difference' @(ElemT a bs)
-
-class Has a e where
-  component :: e -> a
-  setComponent :: a -> e -> e
-
-instance {-# OVERLAPPING #-} Has a (Entity (a ': ts)) where
-  component (ECons x _) = x
-  setComponent x (ECons _ xs) = ECons x xs
-
-instance {-# OVERLAPPING #-} (Has a (Entity ts)) => Has a (Entity (b ': ts)) where
-  component (ECons _ xs) = component xs
-  setComponent x (ECons y xs) = ECons y (setComponent x xs)
-
-class Sort (a :: [Type]) (b :: [Type]) where
-  sort :: Entity a -> Entity b
-
-instance Sort as '[] where
-  sort _ = ENil
-
-instance (Has b (Entity as), Sort as bs) => Sort as (b ': bs) where
-  sort es = ECons (component es) (sort es)
-
-class ComponentIds (a :: [Type]) where
-  componentIds :: Components -> (Set ComponentID, Components)
-
-instance ComponentIds '[] where
-  componentIds cs = (Set.empty, cs)
-
-instance (Component a, ComponentIds as) => ComponentIds (a ': as) where
-  componentIds cs =
-    let (cId, cs') = CS.insert @a cs
-        (cIds, cs'') = componentIds @as cs'
-     in (Set.insert cId cIds, cs'')
-
+module Data.Aztecs.Entity (EntityID (..)) where++-- | Entity ID.+newtype EntityID = EntityID {unEntityId :: Int}+  deriving (Eq, Ord, Show)

@@ -1,231 +1,317 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Data.Aztecs.Query
-  ( Query (..),
-    (<?>),
-    fetch,
-    fetchId,
-    all,
-    queryAll,
-    queryAll',
-    map,
-    Queryable (..),
-    lookup,
-    lookupQuery,
-    alter,
-    QueryState (..),
-    IsEq,
-    Map (..),
-  )
-where
-
-import Data.Aztecs.Component
-import Data.Aztecs.Entity (ConcatT, Difference, DifferenceT, Entity (..), EntityID, EntityT, FromEntity (..), Intersect, IntersectT, Sort, ToEntity (..))
-import qualified Data.Aztecs.Entity as E
-import Data.Aztecs.World (World (..))
-import Data.Aztecs.World.Archetype (Archetype)
-import qualified Data.Aztecs.World.Archetype as A
-import Data.Aztecs.World.Archetypes (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 Data.Data (Typeable)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Prelude hiding (all, lookup, map)
-
-data QueryState a = QueryState
-  { queryStateComponentIds :: Set ComponentID,
-    queryStateAll :: Archetype -> ([Entity a], [Entity a] -> Archetype -> Archetype),
-    queryStateLookup :: EntityID -> Archetype -> Maybe (Entity a),
-    queryStateInsert :: EntityID -> Archetype -> Entity a -> Archetype
-  }
-
--- | Query into the `World`.
-newtype Query a = Query {runQuery' :: Components -> QueryState a}
-
-(<?>) ::
-  (E.Split a (ConcatT a b), E.SplitT a (ConcatT a b) ~ b) =>
-  Query a ->
-  Query b ->
-  Query (ConcatT a b)
-(Query a) <?> (Query b) = Query $ \cs ->
-  let aQS = a cs
-      bQS = b cs
-   in QueryState
-        { queryStateComponentIds = queryStateComponentIds aQS <> queryStateComponentIds bQS,
-          queryStateAll = \arch ->
-            let (a'', aF) = queryStateAll aQS arch
-                (b'', bF) = queryStateAll bQS arch
-             in ( uncurry E.concat <$> zip a'' b'',
-                  \new newArch -> let (as, bs) = unzip $ fmap E.split new in bF bs $ aF as newArch
-                ),
-          queryStateLookup = \eId arch -> do
-            aE <- queryStateLookup aQS eId arch
-            bE <- queryStateLookup bQS eId arch
-            return $ E.concat aE bE,
-          queryStateInsert = \eId arch e ->
-            let (aE, bE) = E.split e
-                arch' = queryStateInsert aQS eId arch aE
-             in queryStateInsert bQS eId arch' bE
-        }
-
--- | Fetch a `Component` by its type.
-fetch :: forall a. (Component a, Typeable (StorageT a)) => Query '[a]
-fetch = Query $ \cs ->
-  let cId = fromMaybe (error "TODO") (CS.lookup @a cs)
-   in QueryState
-        { queryStateComponentIds = Set.singleton cId,
-          queryStateAll = \arch ->
-            let as = A.all cId arch
-             in ( fmap (\x -> ECons (snd x) ENil) as,
-                  A.insertAscList cId . fmap (\((e, _), ECons a ENil) -> (e, a)) . zip as
-                ),
-          queryStateLookup = \eId arch -> do
-            a <- A.lookup eId cId arch
-            return $ ECons a ENil,
-          queryStateInsert = \eId arch e -> let (_, arch', _) = A.insert eId e arch cs in arch'
-        }
-
--- | Fetch a `Component` by its `ComponentID`.
-fetchId :: forall a. (Component a, Typeable (StorageT a)) => ComponentID -> Query '[a]
-fetchId cId = fetch' @a (const cId)
-
-fetch' :: forall a. (Component a, Typeable (StorageT a)) => (Components -> ComponentID) -> Query '[a]
-fetch' f = Query $ \cs ->
-  let cId = f cs
-   in QueryState
-        { queryStateComponentIds = Set.singleton cId,
-          queryStateAll = \arch ->
-            let as = A.all cId arch
-             in ( fmap (\x -> ECons (snd x) ENil) as,
-                  A.insertAscList cId . fmap (\((e, _), ECons a ENil) -> (e, a)) . zip as
-                ),
-          queryStateLookup = \eId arch -> do
-            a <- A.lookup eId cId arch
-            return $ ECons a ENil,
-          queryStateInsert = \eId arch e -> let (_, arch', _) = A.insert eId e arch cs in arch'
-        }
-
-all :: forall a. (ToEntity a, FromEntity a, Queryable (EntityT a)) => World -> [a]
-all = fmap fromEntity . queryAll (query @(EntityT a))
-
-queryAll :: Query a -> World -> [Entity a]
-queryAll q w = fromMaybe [] $ do
-  let qS = runQuery' q (components w)
-  return $ concatMap (fst . queryStateAll qS) (AS.lookup (queryStateComponentIds qS) (archetypes w))
-
-queryAll' :: Query a -> Archetypes -> Components -> [Entity a]
-queryAll' q as cs = fromMaybe [] $ do
-  let qS = runQuery' q cs
-  return $ concatMap (fst . queryStateAll qS) (AS.lookup (queryStateComponentIds qS) as)
-
-class Queryable a where
-  query :: Query a
-
-instance {-# OVERLAPPING #-} (Component a, Typeable (StorageT a)) => Queryable '[a] where
-  query = fetch @a
-
-instance (Component a, Typeable (StorageT a), Queryable as) => Queryable (a ': as) where
-  query = fetch @a <?> query @as
-
--- | Map over all entities that match this query,
--- storing the resulting components in the @World@.
-map ::
-  forall i o.
-  (Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o) =>
-  (i -> o) ->
-  World ->
-  ([o], World)
-map f w =
-  let (o, arches) = map' @(IsEq (Entity (EntityT i)) (Entity (EntityT o))) f (components w) AS.map (archetypes w)
-   in (o, w {archetypes = arches})
-
--- Returns @True@ if @a@ and @b@ are the same type.
-type family IsEq a b :: Bool where
-  IsEq a a = 'True
-  IsEq a b = 'False
-
--- Map over an entity's components.
---
--- @flag@ indicates if the input and output entities are the same,
--- in order to specialize at compile-time.
---
--- If the input and output entities are different, a reader and writer query are combined into one.
--- Otherwise, if the input and output entities are the same, we can use a more efficient implementation.
-class Map (flag :: Bool) i o where
-  map' :: (i -> o) -> Components -> (Set ComponentID -> (Archetype -> ([o], Archetype)) -> a -> ([[o]], a)) -> a -> ([o], a)
-
-instance (FromEntity i, ToEntity o, EntityT i ~ a, EntityT o ~ a, Queryable a) => Map 'True i o where
-  map' f cs mapArches arches = fromMaybe ([], arches) $ do
-    let qS = runQuery' (query @a) cs
-        go arch =
-          let (as, h) = queryStateAll qS arch
-              as' = fmap (f . fromEntity) as
-              arch' = h (fmap toEntity as') arch
-           in (as', arch')
-    let (es, arches') = mapArches (queryStateComponentIds qS) go arches'
-    return (concat es, arches')
-
-instance
-  ( FromEntity i,
-    ToEntity o,
-    Intersect (EntityT i) (EntityT o),
-    Queryable (IntersectT (EntityT i) (EntityT o)),
-    Difference (EntityT i) (EntityT o),
-    Queryable (DifferenceT (EntityT i) (EntityT o)),
-    Sort (ConcatT (DifferenceT (EntityT i) (EntityT o)) (IntersectT (EntityT i) (EntityT o))) (EntityT i),
-    Sort (EntityT o) (IntersectT (EntityT i) (EntityT o))
-  ) =>
-  Map 'False i o
-  where
-  map' f cs mapArches arches = fromMaybe ([], arches) $ do
-    let i = query @(IntersectT (EntityT i) (EntityT o))
-        o = query @(DifferenceT (EntityT i) (EntityT o))
-        aQS = runQuery' i cs
-        bQS = runQuery' o cs
-        g arch =
-          let (as, aH) = queryStateAll aQS arch
-              (bs, _) = queryStateAll bQS arch
-              es = fmap (\(aE, bE) -> f $ fromEntity @i (E.sort $ E.concat bE aE)) (zip as bs)
-              arch' = aH (fmap (\x -> let e = E.sort $ toEntity x in e) es) arch
-           in (es, arch')
-        (es', arches') = mapArches (queryStateComponentIds aQS <> queryStateComponentIds bQS) g arches
-    return (concat es', arches')
-
-lookup :: forall a. (FromEntity a, Queryable (EntityT a)) => EntityID -> World -> Maybe a
-lookup eId w = fromEntity <$> lookupQuery eId (query @(EntityT a)) w
-
-lookupQuery :: EntityID -> Query a -> World -> Maybe (Entity a)
-lookupQuery eId q w = do
-  let qS = runQuery' q (components w)
-  aId <- Map.lookup eId (entities w)
-  node <- AS.lookupNode aId (archetypes w)
-  queryStateLookup qS eId (nodeArchetype node)
-
-alter :: forall a. (FromEntity a, ToEntity a, Queryable (EntityT a)) => EntityID -> (a -> a) -> World -> World
-alter eId f w = fromMaybe w $ do
-  let qS = runQuery' (query @(EntityT a)) (components w)
-  aId <- Map.lookup eId (entities w)
-  node <- AS.lookupNode aId (archetypes w)
-  e <- queryStateLookup qS eId (nodeArchetype node)
-  let e' = f (fromEntity e)
-      arch' = queryStateInsert qS eId (nodeArchetype node) (toEntity e')
-  return $
-    w
-      { archetypes =
-          (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}
-      }
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Aztecs.Query+  ( -- * Queries+    Query (..),+    entity,+    fetch,+    fetchMaybe,+    set,+    run,+    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 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`.+run :: (Monad m) => (i -> m o) -> Query m i o+run 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+-- >>>+-- >>> data 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 -> pure (is, A.withAscList cId is arch),+      dynQueryLookup =+        \i eId arch -> pure (A.lookupComponent eId cId arch, A.insertComponent eId cId i arch)+    }

@@ -1,231 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Aztecs.Scheduler where
-
-import Data.Aztecs.Access (Access, runAccess)
-import Data.Aztecs.System (System (..), Task (runTask))
-import Data.Aztecs.World (World (..))
-import qualified Data.Aztecs.World as W
-import Data.Aztecs.World.Components (ComponentID)
-import Data.Data (Proxy (..), TypeRep, Typeable, typeOf)
-import Data.Foldable (foldrM)
-import Data.List (sortBy)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-data Node m = Node
-  { nodeTask :: Task m () (),
-    nodeBefore :: Set TypeRep,
-    nodeAfter :: Set TypeRep
-  }
-
-instance Show (Node m) where
-  show n =
-    "Node "
-      ++ "{ nodeBefore = "
-      ++ show (nodeBefore n)
-      ++ ", nodeAfter = "
-      ++ show (nodeAfter n)
-      ++ " }"
-
-data Constraint = Constraint {constraintKind :: ConstraintKind, constraintId :: TypeRep}
-  deriving (Eq, Show)
-
-data ConstraintKind = Before | After deriving (Eq, Show)
-
-before :: forall m a. (System m a) => Constraint
-before = Constraint Before (typeOf (Proxy @a))
-
-after :: forall m a. (System m a) => Constraint
-after = Constraint After (typeOf (Proxy @a))
-
-data Startup
-
-data Update
-
-newtype Scheduler m = Scheduler {unScheduler :: Map TypeRep (Stage m)}
-  deriving (Show, Monoid)
-
-instance Semigroup (Scheduler m) where
-  s1 <> s2 = Scheduler (Map.unionWith (<>) (unScheduler s1) (unScheduler s2))
-
-schedule :: forall m l a. (Typeable l, System m a) => [Constraint] -> Scheduler m
-schedule cs =
-  let (bs, as) =
-        foldr
-          ( \c (bAcc, aAcc) -> case constraintKind c of
-              Before -> (constraintId c : bAcc, aAcc)
-              After -> (bAcc, constraintId c : aAcc)
-          )
-          ([], [])
-          cs
-   in Scheduler
-        ( Map.singleton
-            (typeOf (Proxy @l))
-            ( Stage
-                ( Map.singleton
-                    (typeOf (Proxy @a))
-                    ( Node
-                        { nodeTask = task @m @a,
-                          nodeBefore = Set.fromList bs,
-                          nodeAfter = Set.fromList as
-                        }
-                    )
-                )
-            )
-        )
-
-newtype Stage m = Stage {unStage :: Map TypeRep (Node m)}
-  deriving (Show, Semigroup, Monoid)
-
-data ScheduleBuilderNode m = ScheduleBuilderNode
-  { scheduleBuilderNodeTask :: Task m () (),
-    scheduleBuilderNodeBefore :: Set TypeRep
-  }
-
-instance Show (ScheduleBuilderNode m) where
-  show n = "Node " ++ "{ scheduleBuilderNodeBefore = " ++ show (scheduleBuilderNodeBefore n) ++ " }"
-
-newtype ScheduleBuilderStage m = ScheduleBuilderStage {unScheduleBuilderStage :: Map TypeRep (ScheduleBuilderNode m)}
-  deriving (Show)
-
-data Error = MissingError TypeRep | AmbiguousError TypeRep
-  deriving (Show)
-
-stageBuilder :: Stage m -> (ScheduleBuilderStage m, [Error])
-stageBuilder s =
-  let go' nodeId (acc, errorAcc) = case Map.lookup nodeId acc of
-        Just n ->
-          let acc' = Map.insert nodeId n {nodeBefore = Set.insert nodeId (nodeBefore n)} acc
-              errorAcc' =
-                if Set.member nodeId (nodeBefore n)
-                  then AmbiguousError nodeId : errorAcc
-                  else errorAcc
-           in (acc', errorAcc')
-        Nothing -> (acc, MissingError nodeId : errorAcc)
-      go node (acc, errorAcc) = foldr go' (acc, errorAcc) (nodeAfter node)
-      (nodes, errors) = foldr go (unStage s, []) (unStage s)
-   in ( ScheduleBuilderStage $
-          fmap
-            ( \n ->
-                ScheduleBuilderNode
-                  { scheduleBuilderNodeTask = nodeTask n,
-                    scheduleBuilderNodeBefore = nodeBefore n
-                  }
-            )
-            nodes,
-        errors
-      )
-
-data ScheduleGraphNode m = ScheduleGraphNode
-  { scheduleGraphNodeIds :: [Set ComponentID],
-    scheduleGraphNodeBefore :: Set TypeRep,
-    runScheduleGraphNode :: World -> m (World -> World, Access m ())
-  }
-
-instance Show (ScheduleGraphNode m) where
-  show n =
-    "Node "
-      ++ "{ scheduleGraphNodeIds = "
-      ++ show (scheduleGraphNodeIds n)
-      ++ ", scheduleGraphNodeBefore = "
-      ++ show (scheduleGraphNodeBefore n)
-      ++ " }"
-
-newtype ScheduleGraphStage m = ScheduleGraphStage {unScheduleGraphStage :: Map TypeRep (ScheduleGraphNode m)}
-  deriving (Show)
-
-buildGraphStage :: (Functor m) => ScheduleBuilderStage m -> World -> (ScheduleGraphStage m, World)
-buildGraphStage s w =
-  let go (nodeId, node) (acc, wAcc) =
-        let (cs, cIds, f) = runTask (scheduleBuilderNodeTask node) (components wAcc)
-         in ( Map.insert
-                nodeId
-                ScheduleGraphNode
-                  { scheduleGraphNodeIds = cIds,
-                    scheduleGraphNodeBefore = scheduleBuilderNodeBefore node,
-                    runScheduleGraphNode = fmap (\(_, f', a) -> (f', a)) . f ()
-                  }
-                acc,
-              wAcc {components = cs}
-            )
-      (nodes, w') = foldr go (Map.empty, w) (Map.toList $ unScheduleBuilderStage s)
-   in (initGraphStage $ ScheduleGraphStage nodes, w')
-
-initGraphStage :: ScheduleGraphStage m -> ScheduleGraphStage m
-initGraphStage s =
-  let go (nodeId, node) nodeAcc =
-        let go' nodeId' (beforeAcc, nodeAcc') = case Map.lookup nodeId' nodeAcc of
-              Just node' -> (scheduleGraphNodeBefore node' <> beforeAcc, nodeAcc')
-              Nothing -> foldr go' (beforeAcc, nodeAcc') (Set.toList $ scheduleGraphNodeBefore (unScheduleGraphStage s Map.! nodeId))
-            (befores, nodeAcc'') = foldr go' (Set.empty, nodeAcc) (Set.toList $ scheduleGraphNodeBefore node)
-         in Map.insert nodeId node {scheduleGraphNodeBefore = befores} nodeAcc''
-   in ScheduleGraphStage $ foldr go Map.empty (Map.toList $ unScheduleGraphStage s)
-
-buildStage :: ScheduleGraphStage m -> [ScheduleNode m]
-buildStage s =
-  map (\n -> ScheduleNode {runScheduleNode = runScheduleGraphNode n})
-    . sortBy (\a b -> compare (length $ scheduleGraphNodeIds a) (length $ scheduleGraphNodeIds b))
-    $ Map.elems (unScheduleGraphStage s)
-
-newtype ScheduleBuilder m = ScheduleBuilder {unScheduleBuilder :: Map TypeRep (ScheduleBuilderStage m)}
-  deriving (Show)
-
-builder :: Scheduler m -> (ScheduleBuilder m, [Error])
-builder (Scheduler s) =
-  let (stages, errors) = unzip $ fmap stageBuilder (Map.elems s)
-   in (ScheduleBuilder $ Map.fromList $ zip (Map.keys s) stages, concat errors)
-
-newtype ScheduleGraph m = ScheduleGraph {unScheduleGraph :: Map TypeRep (ScheduleGraphStage m)}
-  deriving (Show)
-
-buildGraph :: (Functor m) => Scheduler m -> World -> (ScheduleGraph m, World, [Error])
-buildGraph s w =
-  let (sb, errors) = builder s
-      (s', w') = buildGraph' sb w
-   in (s', w', errors)
-
-buildGraph' :: (Functor m) => ScheduleBuilder m -> World -> (ScheduleGraph m, World)
-buildGraph' (ScheduleBuilder s) w =
-  let go (stageId, stage) (acc, wAcc) =
-        let (stage', wAcc') = buildGraphStage stage wAcc
-         in (Map.insert stageId stage' acc, wAcc')
-      (stages, w') = foldr go (Map.empty, w) (Map.toList s)
-   in (ScheduleGraph stages, w')
-
-newtype ScheduleNode m = ScheduleNode {runScheduleNode :: World -> m (World -> World, Access m ())}
-
-newtype Schedule m = Schedule {unSchedule :: Map TypeRep [ScheduleNode m]}
-
-build :: (Functor m) => Scheduler m -> World -> (Schedule m, World, [Error])
-build s w = let (s', w', errors) = buildGraph s w in (build' s', w', errors)
-
-build' :: (Functor m) => ScheduleGraph m -> Schedule m
-build' g = Schedule $ fmap buildStage (unScheduleGraph g)
-
-runStage :: forall l m. (Typeable l, Monad m) => Schedule m -> World -> m World
-runStage s w = case Map.lookup (typeOf (Proxy @l)) (unSchedule s) of
-  Just stage ->
-    let go node wAcc = do
-          (f, access) <- runScheduleNode node wAcc
-          (_, wAcc') <- runAccess access (f wAcc)
-          return wAcc'
-     in foldrM go w stage
-  Nothing -> return w
-
-runWorld :: (Monad m) => Scheduler m -> World -> m ()
-runWorld s w = do
-  let (s', w', _) = build s w
-  w'' <- runStage @Startup s' w'
-  let go wAcc = do
-        wAcc' <- runStage @Update s' wAcc
-        go wAcc'
-  go w''
-
-run :: (Monad m) => Scheduler m -> m ()
-run s = runWorld s W.empty

@@ -1,37 +1,37 @@-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MonoLocalBinds #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
-module Data.Aztecs.Storage (Storage (..)) where
-
-import Data.Data (Typeable)
-import Data.IntMap (IntMap)
-import qualified Data.IntMap 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
+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.Aztecs.Storage (Storage (..)) where++import Data.Data (Typeable)+import Data.IntMap (IntMap)+import qualified Data.IntMap 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,137 +1,308 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Aztecs.System where
-
-import Control.Arrow (Arrow (..))
-import Control.Category (Category (..))
-import Data.Aztecs.Access (Access, runAccess)
-import Data.Aztecs.Entity (ComponentIds (componentIds), Entity, EntityT)
-import Data.Aztecs.Query (IsEq, Queryable)
-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 Data.Aztecs.World.Components (ComponentID, Components)
-import Data.Data (Typeable)
-import Data.Set (Set)
-
-class (Typeable a) => System m a where
-  task :: Task m () ()
-
-runSystem :: forall m s. (System m s, Monad m) => World -> m World
-runSystem w = do
-  let (cs, _, f) = runTask (task @m @s) (components w)
-      w' = w {components = cs}
-  (_, g, access) <- f () w'
-  (_, w'') <- runAccess access w'
-  return $ g w''
-
--- | System task.
-newtype Task m i o = Task
-  { runTask ::
-      Components ->
-      ( Components,
-        [Set ComponentID],
-        i -> World -> m (o, World -> World, Access m ())
-      )
-  }
-  deriving (Functor)
-
-instance (Monad m) => Applicative (Task m i) where
-  pure a = Task (,[],\_ _ -> pure (a, Prelude.id, pure ()))
-  f <*> a =
-    Task $ \w ->
-      let (w', cIds, f') = runTask f w
-          (w'', cIds', a') = runTask a w'
-       in ( w'',
-            cIds <> cIds',
-            \i cs -> do
-              (f'', fG, access) <- f' i cs
-              (a'', aG, access') <- a' i cs
-              return (f'' a'', fG Prelude.. aG, access >> access')
-          )
-
-instance (Monad m) => Category (Task m) where
-  id = Task (,[],\i _ -> pure (i, Prelude.id, pure ()))
-  (.) t1 t2 = Task $ \w ->
-    let (w', cIds, f) = runTask t2 w
-        (w'', cIds', g) = runTask t1 w'
-     in ( w'',
-          cIds <> cIds',
-          \i cs -> do
-            (o, f', access) <- f i cs
-            (a, g', access') <- g o cs
-            return (a, g' Prelude.. f', access >> access')
-        )
-
-instance (Monad m) => Arrow (Task m) where
-  arr f = Task (,[],\i _ -> pure (f i, Prelude.id, pure ()))
-  first t =
-    Task $ \w ->
-      let (w', cIds, f) = runTask t w
-       in ( w',
-            cIds,
-            \(i, x) cs -> do
-              (o, f', access) <- f i cs
-              return ((o, x), f', access)
-          )
-
-all :: forall m v. (Monad m, ComponentIds v, Queryable v) => Task m () [Entity v]
-all = view @_ @v (\v cs -> pure $ V.queryAll v cs)
-
-map ::
-  forall m i o.
-  ( Monad m,
-    ComponentIds (EntityT i),
-    Queryable (EntityT i),
-    Q.Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o
-  ) =>
-  (i -> o) ->
-  Task m () [o]
-map f = mapView (\v cs -> pure $ V.map f v cs)
-
-view ::
-  forall m v a.
-  (Monad m, ComponentIds v, Queryable v) =>
-  (View v -> Components -> m a) ->
-  Task m () a
-view f = Task $ \cs ->
-  let (cIds, cs') = componentIds @v cs
-   in ( cs',
-        [cIds],
-        \_ w ->
-          let (v, w') = V.view @v w
-           in (,Prelude.id,pure ()) <$> f v (components w')
-      )
-
-mapView ::
-  forall m v a.
-  (Monad m, ComponentIds v, Queryable v) =>
-  (View v -> Components -> m (a, View v)) ->
-  Task m () a
-mapView f = Task $ \cs ->
-  let (cIds, cs') = componentIds @v cs
-   in ( cs',
-        [cIds],
-        \_ w ->
-          let (v, w') = V.view @v w
-           in (\(a, v') -> (a, V.unview v', pure ())) <$> f v (components w')
-      )
-
--- | Queue an `Access` to alter the world after this task is complete.
-queue :: (Monad m) => Access m () -> Task m () ()
-queue a = Task (,[],\_ _ -> pure ((), Prelude.id, a))
-
-run :: (Monad m) => (i -> m o) -> Task m i o
-run f =
-  Task
-    (,[],\i _ -> do
-           o <- f i
-           return (o, Prelude.id, pure ()))
+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Data.Aztecs.System+  ( -- * Systems+    System,+    SystemT (..),+    forever,+    run,+    queue,++    -- ** Queries++    -- *** Reading+    all,+    filter,+    single,++    -- *** Writing+    map,+    map_,+    mapSingle,+    filterMap,++    -- ** Running+    runSystem,+    runSystem_,+    runSystemWithWorld,++    -- * Dynamic systems+    DynamicSystem,+    DynamicSystemT (..),+    allDyn,+    singleDyn,+    mapDyn,+    mapDyn_,+    queueDyn,+    runDyn,+  )+where++import Control.Arrow (Arrow (..), ArrowLoop (..))+import Control.Category (Category (..))+import Control.Concurrent (forkIO)+import Data.Aztecs.Access (Access, runAccess)+import Data.Aztecs.Query (DynamicQuery, DynamicQueryFilter (..), Query (..), QueryFilter (..), ReadsWrites)+import qualified Data.Aztecs.Query as Q+import qualified Data.Aztecs.View as V+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 (Node (nodeArchetype))+import Data.Aztecs.World.Components (ComponentID, Components)+import qualified Data.Foldable as F+import Data.Set (Set)+import GHC.Conc (TVar, atomically, newTVarIO, readTVarIO, writeTVar)+import Prelude hiding (all, filter, id, map, (.))++type System = SystemT IO++-- | System that can access and alter a `World`.+--+-- Systems can be composed either in sequence or parallel with `Category` and `Arrow` combinators.+-- Using the arrow combinator `&&&`, systems will automatically run in parallel+-- as long as their queries don't intersect.+newtype SystemT m i o = SystemT+  { -- | Initialize a system, producing a `DynamicSystem`.+    runSystem' :: Components -> (Components, ReadsWrites, DynamicSystemT m i o)+  }+  deriving (Functor)++instance (Monad m) => Applicative (SystemT m i) where+  pure a = SystemT (,mempty,pure a)+  f <*> a =+    SystemT $ \w ->+      let (w', cIds, f') = runSystem' f w+          (w'', cIds', a') = runSystem' a w'+       in (w'', cIds <> cIds', f' <*> a')++instance Category System where+  id = SystemT (,mempty,id)+  f . g = SystemT $ \cs ->+    let (cs', cIds, g') = runSystem' g cs+        (cs'', cIds', f') = runSystem' f cs'+     in (cs'', cIds <> cIds', f' . g')++instance Arrow System where+  arr f = SystemT (,mempty,arr f)+  first s = SystemT $ \w -> let (w', cIds, dynS) = runSystem' s w in (w', cIds, first dynS)+  a &&& b = SystemT $ \w ->+    let (w', aRws, dynA) = runSystem' a w+        (w'', bRws, dynB) = runSystem' b w'+        f = if Q.disjoint aRws bRws then (&&&) else joinDyn+     in (w'', aRws <> bRws, f dynA dynB)++instance ArrowLoop System where+  loop s = SystemT $ \w -> let (w', cIds, dynS) = runSystem' s w in (w', cIds, loop dynS)++-- | Run a system forever.+forever :: System () () -> System () ()+forever s = SystemT $ \w -> let (w', cIds, dynS) = runSystem' s w in (w', cIds, foreverDyn dynS)++runSystem_ :: System () () -> IO ()+runSystem_ s = runSystem s >> pure ()++runSystem :: System () () -> IO World+runSystem s = runSystemWithWorld s W.empty++runSystemWithWorld :: System () () -> World -> IO World+runSystemWithWorld s w = do+  let (cs, _, dynS) = runSystem' s (components w)+      w' = w {components = cs}+  wVar <- newTVarIO w'+  ((), access) <- runSystemDyn dynS () wVar+  w'' <- readTVarIO wVar+  ((), w''') <- runAccess access w''+  return w'''++-- | Query all matching entities.+all :: Query IO () a -> System () [a]+all q = SystemT $ \cs ->+  let (rws, cs', dynQ) = runQuery q cs+   in (cs', rws, allDyn (Q.reads rws <> Q.writes rws) dynQ)++-- | Query all matching entities with a `QueryFilter`.+filter :: Query IO () a -> QueryFilter -> System () [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 (cs'', rws, filterDyn (Q.reads rws <> Q.writes rws) dynQ qf')++-- | Query a single matching entity.+-- If there are zero or multiple matching entities, an error will be thrown.+single :: Query IO () a -> System () a+single q =+  fmap+    ( \as -> case as of+        [a] -> a+        _ -> error "TODO"+    )+    (all q)++-- | Map all matching entities, storing the updated entities.+map :: Query IO i a -> System i [a]+map q = SystemT $ \cs ->+  let (rws, cs', dynS) = runQuery q cs in (cs', rws, mapDyn (Q.reads rws <> Q.writes rws) dynS)++-- | Map all matching entities and ignore the output, storing the updated entities.+map_ :: Query IO i a -> System i ()+map_ q = const () <$> map q++-- | Map all matching entities with a `QueryFilter`, storing the updated entities.+filterMap :: Query IO i a -> QueryFilter -> System 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 (cs'', rws, filterMapDyn (Q.reads rws <> Q.writes rws) dynQ f')++-- | Map a single matching entity, storing the updated components.+-- If there are zero or multiple matching entities, an error will be thrown.+mapSingle :: Query IO i a -> System i a+mapSingle q =+  fmap+    ( \as -> case as of+        [a] -> a+        _ -> error "TODO"+    )+    (map q)++-- | Queue an `Access` to alter the world after this system is complete.+queue :: (Monad m) => (i -> Access m ()) -> SystemT m i ()+queue f = SystemT (,mempty,queueDyn f)++-- | Run a monadic task.+run :: (Monad m) => (i -> m o) -> SystemT m i o+run f = SystemT (,mempty,runDyn f)++type DynamicSystem = DynamicSystemT IO++-- | Dynamic system that can access and alter a `World`.+newtype DynamicSystemT m i o = DynamicSystemT+  {runSystemDyn :: i -> TVar World -> m (o, Access m ())}+  deriving (Functor)++instance (Monad m) => Applicative (DynamicSystemT m i) where+  pure a = DynamicSystemT $ \_ _ -> pure (a, pure ())+  f <*> a =+    DynamicSystemT $ \i w -> do+      (f'', access) <- runSystemDyn f i w+      (a'', access') <- runSystemDyn a i w+      return (f'' a'', access >> access')++instance Category DynamicSystem where+  id = DynamicSystemT $ \i _ -> pure (i, pure ())+  f . g = DynamicSystemT $ \i wVar -> do+    (a, access) <- runSystemDyn g i wVar+    w <- readTVarIO wVar+    ((), w') <- runAccess access w+    atomically $ writeTVar wVar w'+    (b, access') <- runSystemDyn f a wVar+    return (b, access')++instance Arrow DynamicSystem where+  arr f = DynamicSystemT $ \i _ -> pure (f i, pure ())+  first s =+    DynamicSystemT $ \(i, x) w -> do+      (o, access) <- runSystemDyn s i w+      return ((o, x), access)++instance ArrowLoop DynamicSystem where+  loop s = DynamicSystemT $ \b w -> mdo+    ((c, d), access) <- runSystemDyn s (b, d) w+    return (c, access)++-- | Combine two dynamic systems in parallel.+joinDyn :: DynamicSystem i a -> DynamicSystem i b -> DynamicSystem i (a, b)+joinDyn f g = DynamicSystemT $ \i w -> do+  fVar <- newTVarIO Nothing+  gVar <- newTVarIO Nothing+  _ <- forkIO $ do+    result <- runSystemDyn f i w+    atomically $ writeTVar fVar (Just result)+  _ <- forkIO $ do+    result <- runSystemDyn g i w+    atomically $ writeTVar gVar (Just result)+  let go = do+        maybeA <- readTVarIO fVar+        maybeB <- readTVarIO gVar+        case (maybeA, maybeB) of+          (Just (a, accessA), Just (b, accessB)) -> return ((a, b), accessA >> accessB)+          _ -> go+  go++-- | Run a dynamic system forever.+foreverDyn :: DynamicSystem () () -> DynamicSystem () ()+foreverDyn s = DynamicSystemT $ \_ w -> do+  let go w' = do+        ((), access) <- runSystemDyn s () w'+        wAcc' <- readTVarIO w'+        ((), wAcc'') <- runAccess access wAcc'+        atomically $ writeTVar w' wAcc''+        go w'+  go w++-- | Query all matching entities.+allDyn :: Set ComponentID -> DynamicQuery IO () a -> DynamicSystem () [a]+allDyn cIds q = DynamicSystemT $ \_ w -> do+  w' <- readTVarIO w+  let v = V.view cIds (archetypes w')+  fmap (\(a, _) -> (a, pure ())) (V.allDyn () q v)++filterDyn :: Set ComponentID -> DynamicQuery IO i a -> (Node -> Bool) -> DynamicSystemT IO i [a]+filterDyn cIds q f = DynamicSystemT $ \i wVar -> do+  w <- readTVarIO wVar+  let v = V.filterView cIds f (archetypes w)+  (as, _) <- V.allDyn i q v+  return (as, pure ())++-- | Query a single matching entity.+-- If there are zero or multiple matching entities, an error will be thrown.+singleDyn :: Set ComponentID -> DynamicQuery IO () a -> DynamicSystem () 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 :: Set ComponentID -> DynamicQuery IO i a -> DynamicSystem i [a]+mapDyn cIds q = DynamicSystemT $ \i wVar -> do+  w <- readTVarIO wVar+  let v = V.view cIds (archetypes w)+  (as, v') <- V.allDyn i q v+  atomically $ writeTVar wVar $ V.unview v' w+  return (as, pure ())++filterMapDyn :: Set ComponentID -> DynamicQuery IO i a -> (Node -> Bool) -> DynamicSystemT IO i [a]+filterMapDyn cIds q f = DynamicSystemT $ \i wVar -> do+  w <- readTVarIO wVar+  let v = V.filterView cIds f (archetypes w)+  (as, v') <- V.allDyn i q v+  atomically $ writeTVar wVar $ V.unview v' w+  return (as, pure ())++-- | Map all matching entities and ignore the output, storing the updated entities.+mapDyn_ :: Set ComponentID -> DynamicQuery IO () a -> DynamicSystem () ()+mapDyn_ cIds q = const () <$> mapDyn cIds q++-- | Queue an `Access` to alter the world after this system is complete.+queueDyn :: (Applicative m) => (i -> Access m ()) -> DynamicSystemT m i ()+queueDyn f = DynamicSystemT $ \i _ -> pure ((), f i)++-- | Run a monadic task.+runDyn :: (Monad m) => (i -> m o) -> DynamicSystemT m i o+runDyn f = DynamicSystemT $ \i _ -> fmap (,pure ()) (f i)

@@ -1,80 +1,65 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Aztecs.View where
-
-import Data.Aztecs.Entity (ComponentIds, EntityT, componentIds, Entity)
-import Data.Aztecs.Query (IsEq, Query (..), QueryState (..), Queryable (..))
-import qualified Data.Aztecs.Query as Q
-import Data.Aztecs.World (ArchetypeID, World)
-import qualified Data.Aztecs.World as W
-import Data.Aztecs.World.Archetype (Archetype)
-import Data.Aztecs.World.Archetypes (Archetypes)
-import qualified Data.Aztecs.World.Archetypes as AS
-import Data.Aztecs.World.Components (Components)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-
-data View a = View
-  { viewArchetypes :: Map ArchetypeID Archetype,
-    viewQuery :: Query a
-  }
-
-view :: forall a. (ComponentIds a, Queryable a) => World -> (View a, World)
-view w =
-  let (v, cs') = view' @a (W.components w) (W.archetypes w)
-   in (v, w {W.components = cs'})
-
-view' :: forall a. (ComponentIds a, Queryable a) => Components -> Archetypes -> (View a, Components)
-view' cs as =
-  let (cIds, cs') = componentIds @a cs
-   in ( View
-          { viewArchetypes = AS.lookup cIds as,
-            viewQuery = query @a
-          },
-        cs'
-      )
-
-unview :: View a -> World -> World
-unview v w =
-  w
-    { W.archetypes =
-        foldr
-          (\(aId, arch) as -> AS.adjustArchetype aId (const arch) as)
-          (W.archetypes w)
-          (Map.toList $ viewArchetypes v)
-    }
-
-queryAll :: View a -> Components -> [Entity a]
-queryAll v cs = fromMaybe [] $ do
-  let qS = runQuery' (viewQuery v) cs
-  return $ concatMap (fst . queryStateAll qS) (Map.elems $ viewArchetypes v)
-
--- | Map over all entities that match this query,
--- storing the resulting components in the @View@.
-map ::
-  forall i o.
-  (Q.Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o) =>
-  (i -> o) ->
-  View (EntityT i) ->
-  Components ->
-  ([o], View (EntityT i))
-map f v cs =
-  let (o, arches) =
-        Q.map' @(IsEq (Entity (EntityT i)) (Entity (EntityT o)))
-          f
-          cs
-          ( \_ g arches' ->
-              foldr
-                ( \(aId, arch) (acc, archAcc) ->
-                    let (os, arch') = g arch
-                     in (os : acc, Map.insert aId arch' archAcc)
-                )
-                ([], Map.empty)
-                (Map.toList arches')
-          )
-          (viewArchetypes v)
-   in (o, v {viewArchetypes = arches})
+{-# 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 (foldrM)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)++-- | 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 =+        foldr+          (\(aId, n) as -> 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)) $+    foldrM+      ( \(aId, n) (acc, archAcc) -> 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,257 +1,250 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Aztecs.World
-  ( ArchetypeID (..),
-    World (..),
-    empty,
-    spawn,
-    spawnComponent,
-    spawnWithId,
-    spawnWithArchetypeId,
-    spawnEmpty,
-    insert,
-    insertWithId,
-    despawn,
-  )
-where
-
-import Data.Aztecs.Component
-  ( Component (..),
-    ComponentID,
-  )
-import Data.Aztecs.Entity (ComponentIds, Entity, EntityID (..), ToEntity (..), EntityT)
-import qualified Data.Aztecs.Entity as E
-import Data.Aztecs.World.Archetype (Archetype (..), Insert)
-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)
-
--- | 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 ::
-  forall a.
-  (ComponentIds (EntityT a), ToEntity a, Insert (Entity (EntityT a))) =>
-   a ->
-  World ->
-  (EntityID, World)
-spawn e w =
-  let (eId, w') = spawnEmpty w
-      (cIds, components') = E.componentIds @(EntityT a) (components w)
-   in case AS.lookupArchetypeId cIds (archetypes w) of
-        Just aId -> fromMaybe (eId, w') $ do
-          node <- AS.lookupNode aId (archetypes w)
-          let (_, arch', components'') = A.insert eId (toEntity e) (nodeArchetype node) components'
-          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, components'') = A.insert eId (toEntity e) A.empty components'
-              (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 (itemCId, dyn) archAcc =
-                  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 $
-                                          foldr
-                                            f
-                                            (nodeArchetype nextNode)
-                                            (Map.toList cs)
-                                    }
-                              )
-                              nextAId
-                              (AS.nodes $ archetypes w')
-                        },
-                    entities = Map.insert e aId (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 -> 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)
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Aztecs.World+  ( World (..),+    empty,+    spawn,+    spawnComponent,+    spawnWithId,+    spawnWithArchetypeId,+    spawnEmpty,+    insert,+    insertWithId,+    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)++-- | 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 (itemCId, dyn) archAcc =+                  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 $+                                          foldr+                                            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 -> 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)

@@ -1,138 +1,203 @@-{-# 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,
-    lookup,
-    lookupStorage,
-    remove,
-    removeStorages,
-    insertComponent,
-    insertAscList,
-    Insert (..),
-    AnyStorage (..),
-    anyStorage,
-  )
-where
-
-import Data.Aztecs.Component (Component (..), ComponentID)
-import Data.Aztecs.Entity (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, fromDynamic, toDyn)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Prelude hiding (all, lookup)
-
-data AnyStorage = AnyStorage
-  { storageDyn :: Dynamic,
-    insertDyn :: Int -> Dynamic -> Dynamic -> Dynamic,
-    removeDyn :: Int -> Dynamic -> (Maybe Dynamic, Dynamic),
-    removeAny :: Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
-  }
-
-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)
-    }
-
-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
-
-lookup :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a
-lookup e cId w = lookupStorage cId w >>= S.lookup (unEntityId e)
-
-insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype
-insertAscList cId as arch = arch {storages = Map.insert cId (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as)) (storages arch)}
-
-remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
-remove e arch =
-  foldr
-    ( \(cId, s) (dynAcc, archAcc) ->
-        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 =
-  foldr
-    ( \(cId, s) (dynAcc, archAcc) ->
-        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)
-
-class Insert a where
-  insert :: EntityID -> a -> Archetype -> Components -> (Set ComponentID, Archetype, Components)
-
-instance Insert (Entity '[]) where
-  insert _ ENil arch cs = (Set.empty, arch, cs)
-
-instance (Component a, Insert (Entity as)) => Insert (Entity (a ': as)) where
-  insert eId (ECons e es) arch cs =
-    let (cId, cs') = CS.insert @a cs
-        arch' = insertComponent eId cId e arch
-        (cIds, arch'', cs'') = insert eId es arch' cs'
-     in (Set.insert cId cIds, arch'', cs'')
+{-# 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 (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Prelude hiding (all, lookup)++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 =+  arch+    { storages =+        Map.insert+          cId+          (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as))+          (storages arch)+    }++withAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype+withAscList cId as arch =+  arch+    { storages =+        Map.adjust+          ( \s ->+              (anyStorage $ S.fromAscList @(StorageT a) (zip (entitiesDyn s (storageDyn s)) as))+          )+          cId+          (storages arch)+    }++remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)+remove e arch =+  foldr+    ( \(cId, s) (dynAcc, archAcc) ->+        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 =+  foldr+    ( \(cId, s) (dynAcc, archAcc) ->+        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,114 +1,117 @@-{-# 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, lookup)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (mapMaybe)
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Prelude hiding (all, lookup, map)
-
--- | `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') -> foldr Set.intersection aId aIds'
-  [] -> Set.empty
-
--- | Lookup `Archetype`s containing a set of `ComponentID`s.
-lookup :: Set ComponentID -> Archetypes -> Map ArchetypeID Archetype
-lookup cIds arches = Map.fromSet (\aId -> nodeArchetype $ 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 =
-  foldr
-    ( \aId (acc, archAcc) ->
-        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)
+{-# 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 (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Prelude hiding (all, lookup, map)++-- | `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') -> foldr 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 =+  foldr+    ( \aId (acc, archAcc) ->+        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,55 +1,55 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# 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 (Map)
-import qualified Data.Map 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)
-          }
-      )
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# 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 (Map)+import qualified Data.Map 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,39 +1,33 @@-module Main (main) where
-
-import Data.Aztecs
-import Data.Aztecs.Entity (ToEntity (toEntity))
-import qualified Data.Aztecs.Query as Q
-import qualified Data.Aztecs.World as W
-import Test.Hspec
-
-newtype X = X Int deriving (Eq, Show)
-
-instance Component X
-
-newtype Y = Y Int deriving (Eq, Show)
-
-instance Component Y
-
-newtype Z = Z Int deriving (Eq, Show)
-
-instance Component Z
-
-main :: IO ()
-main = hspec $ do
-  describe "Data.Aztecs.Query.all" $ do
-    it "queries multiple components" $ do
-      let (_, w) = W.spawn (X 0) W.empty
-          (_, w') = W.spawn (X 1) w
-          xs = Q.all w'
-      xs `shouldMatchList` [X 0, X 1]
-    it "queries a group of components" $ do
-      let (e, w) = W.spawn (X 0) W.empty
-          w' = W.insert e (Y 1) w
-          xs = Q.all w'
-      xs `shouldMatchList` [toEntity (X 0 :& Y 1)]
-    it "queries a fragmented group of components" $ do
-      let (e, w) = W.spawn (X 0) W.empty
-          w' = W.insert e (Y 1) w
-          w'' = W.insert e (Z 2) w'
-          xs = Q.all w''
-      xs `shouldMatchList` [toEntity (Y 1 :& Z 2)]
+module Main (main) where++import Control.Arrow ((&&&))+import Data.Aztecs+import qualified Data.Aztecs.Query as Q+import qualified Data.Aztecs.World as W+import Test.Hspec++newtype X = X Int deriving (Eq, Show)++instance Component X++newtype Y = Y Int deriving (Eq, Show)++instance Component Y++newtype Z = Z Int deriving (Eq, Show)++instance Component Z++main :: IO ()+main = hspec $ do+  describe "Data.Aztecs.Query.all" $ do+    it "queries multiple components" $ do+      let (_, w) = W.spawn (bundle $ X 0) W.empty+          (_, w') = W.spawn (bundle $ X 1) w+      (xs, _) <- Q.all (Q.fetch) w'+      xs `shouldMatchList` [X 0, X 1]+    it "queries a group of components" $ do+      let (e, w) = W.spawn (bundle $ X 0) W.empty+          w' = W.insert e (Y 1) w+      (xs, _) <- Q.all (Q.fetch &&& Q.fetch) w'+      xs `shouldMatchList` [(X 0, Y 1)]