aztecs 0.7.0 → 0.8.0

raw patch · 23 files changed

+452/−350 lines, 23 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• aztecs.cabal +5/−5
• bench/Bench.hs +41/−0
• bench/Iter.hs +0/−47
• src/Aztecs/ECS/Component.hs +3/−4
• src/Aztecs/ECS/Query.hs +22/−13
• src/Aztecs/ECS/Query/Dynamic.hs +44/−9
• src/Aztecs/ECS/Query/Dynamic/Reader.hs +37/−9
• src/Aztecs/ECS/Query/Reader.hs +15/−2
• src/Aztecs/ECS/Schedule.hs +21/−25
• src/Aztecs/ECS/Schedule/Dynamic.hs +7/−0
• src/Aztecs/ECS/Schedule/Reader.hs +7/−7
• src/Aztecs/ECS/System.hs +23/−30
• src/Aztecs/ECS/System/Dynamic.hs +23/−19
• src/Aztecs/ECS/System/Dynamic/Reader.hs +24/−15
• src/Aztecs/ECS/System/Reader.hs +15/−13
• src/Aztecs/ECS/View.hs +12/−11
• src/Aztecs/ECS/World.hs +0/−6
• src/Aztecs/ECS/World/Archetype.hs +35/−31
• src/Aztecs/ECS/World/Archetypes.hs +13/−14
• src/Aztecs/ECS/World/Entities.hs +9/−7
• src/Aztecs/ECS/World/Storage.hs +11/−26
• src/Aztecs/ECS/World/Storage/Dynamic.hs +18/−35
• test/Main.hs +67/−22

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          aztecs-version:       0.7.0+version:       0.8.0 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me@@ -85,7 +85,7 @@     default-language: Haskell2010     ghc-options:      -Wall     build-depends:-        base >=4.6 && <5,+        base >=4 && <5,         containers >=0.6,         deepseq >=1,         linear >=1,@@ -99,7 +99,7 @@     default-language: Haskell2010     ghc-options:      -Wall     build-depends:-        base >=4.6 && <5,+        base >=4 && <5,         aztecs,         containers >=0.6,         deepseq >=1,@@ -108,12 +108,12 @@  benchmark aztecs-bench     type:             exitcode-stdio-1.0-    main-is:          Iter.hs+    main-is:          Bench.hs     hs-source-dirs:   bench     default-language: Haskell2010     ghc-options:      -Wall     build-depends:-        base >=4.6 && <5,+        base >=4 && <5,         aztecs,         criterion >=1,         deepseq >=1

@@ -0,0 +1,41 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++import Aztecs.ECS+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.System as S+import Aztecs.ECS.World (World (..))+import qualified Aztecs.ECS.World as W+import Control.DeepSeq+import Criterion.Main+import GHC.Generics (Generic)++newtype Position = Position Int deriving (Show, Generic, NFData)++instance Component Position++newtype Velocity = Velocity Int deriving (Show, Generic, NFData)++instance Component Velocity++query :: Query () Position+query = proc () -> do+  Velocity v <- Q.fetch -< ()+  Position p <- Q.fetch -< ()+  Q.set -< Position $ p + v++run :: World -> World+run w = let !(_, es) = Q.map () query $ entities w in w {entities = es}++runSystem :: World -> IO World+runSystem w = do+  (_, _, w') <- runSchedule (system $ S.map query) w ()+  return w'++main :: IO ()+main = do+  let go wAcc = snd $ W.spawn (bundle (Position 0) <> bundle (Velocity 1)) wAcc+      !w = foldr (const go) W.empty [0 :: Int .. 10000]+  defaultMain [bench "iter" $ nf run w, bench "iter system" . nfIO $ runSystem w]

@@ -1,47 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--import Aztecs.ECS-import qualified Aztecs.ECS.Query as Q-import qualified Aztecs.ECS.System as S-import qualified Aztecs.ECS.World as W-import Control.DeepSeq-import Control.Monad (void)-import Criterion.Main-import GHC.Generics (Generic)--newtype Position = Position Int deriving (Show, Generic, NFData)--instance Component Position--newtype Velocity = Velocity Int deriving (Show, Generic, NFData)--instance Component Velocity--run :: World -> IO ()-run w = do-  let s =-        void-          ( S.map-              ( proc () -> do-                  Velocity v <- Q.fetch -< ()-                  Position p <- Q.fetch -< ()-                  Q.set -< Position $ p + v-              )-          )-  !_ <- runSchedule (system s) w ()-  return ()--main :: IO ()-main = do-  let !w =-        foldr-          ( \_ wAcc ->-              let (e, wAcc') = W.spawn (bundle $ Position 0) wAcc-               in W.insert e (Velocity 1) wAcc'-          )-          W.empty-          [0 :: Int .. 10000]-  defaultMain [bench "iter" $ nfIO (run w)]

@@ -7,7 +7,6 @@  import Aztecs.ECS.World.Storage (Storage) import Control.DeepSeq (NFData)-import Data.IntMap.Strict (IntMap) import Data.Kind (Type) import Data.Typeable (Typeable) import GHC.Generics (Generic)@@ -17,8 +16,8 @@   deriving (Eq, Ord, Show, Generic, NFData)  -- | Component that can be stored in the `World`.-class (Typeable a, Storage (StorageT a) a) => Component a where+class (Typeable a, Storage a (StorageT a)) => Component a where   -- | `Storage` of this component.-  type StorageT a :: Type -> Type+  type StorageT a :: Type -  type StorageT a = IntMap+  type StorageT a = [a]

@@ -15,7 +15,12 @@      -- ** Running     all,+    map, +    -- ** Conversion+    fromReader,+    toReader,+     -- * Filters     QueryFilter (..),     with,@@ -29,14 +34,12 @@  import Aztecs.ECS.Component import Aztecs.ECS.Query.Class (ArrowQuery (..))-import Aztecs.ECS.Query.Dynamic (DynamicQuery (..), fromDynReader)+import Aztecs.ECS.Query.Dynamic (DynamicQuery (..), fromDynReader, mapDyn, toDynReader) import Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..)) import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) import Aztecs.ECS.Query.Reader (QueryFilter (..), QueryReader (..), with, without)+import qualified Aztecs.ECS.Query.Reader as QR import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..))-import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Archetypes (Node (..))-import qualified Aztecs.ECS.World.Archetypes as AS import Aztecs.ECS.World.Components (Components) import qualified Aztecs.ECS.World.Components as CS import Aztecs.ECS.World.Entities (Entities (..))@@ -44,7 +47,7 @@ import Control.Category (Category (..)) import Data.Set (Set) import qualified Data.Set as Set-import Prelude hiding (all, id, reads, (.))+import Prelude hiding (all, id, map, reads, (.))  -- | Query for matching entities. --@@ -108,6 +111,10 @@ fromReader (QueryReader f) = Query $ \cs ->   let (cIds, cs', dynQ) = f cs in (ReadsWrites cIds Set.empty, cs', fromDynReader dynQ) +toReader :: Query i o -> QueryReader i o+toReader (Query f) = QueryReader $ \cs ->+  let (rws, cs', dynQ) = f cs in (reads rws, cs', toDynReader dynQ)+ -- | Reads and writes of a `Query`. data ReadsWrites = ReadsWrites   { reads :: !(Set ComponentID),@@ -129,11 +136,13 @@     || Set.disjoint (writes b) (writes a)  -- | Match all entities.-all :: Query () a -> Entities -> ([a], Entities)-all q w =-  let (rws, cs', dynQ) = runQuery q (components w)-      as =-        fmap-          (\n -> fst $ dynQueryAll dynQ (repeat ()) (A.entities $ nodeArchetype n) (nodeArchetype n))-          (AS.find (reads rws <> writes rws) (archetypes w))-   in (concat as, w {components = cs'})+all :: i -> Query i a -> Entities -> ([a], Entities)+all i = QR.all i . toReader++-- | Map all matched entities.+map :: i -> Query i a -> Entities -> ([a], Entities)+map i q es =+  let (rws, cs', dynQ) = runQuery q (components es)+      cIds = reads rws <> writes rws+      (as, es') = mapDyn cIds i dynQ es+   in (as, es' {components = cs'})

@@ -7,54 +7,68 @@     DynamicQuery (..),     ArrowDynamicQueryReader (..),     ArrowDynamicQuery (..),++    -- ** Conversion     fromDynReader,+    toDynReader, +    -- ** Running+    mapDyn,+     -- * Dynamic query filters     DynamicQueryFilter (..),   ) where +import Aztecs.ECS.Component (ComponentID) import Aztecs.ECS.Entity (EntityID) import Aztecs.ECS.Query.Dynamic.Class (ArrowDynamicQuery (..)) import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryFilter (..), DynamicQueryReader (..)) import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) import Aztecs.ECS.World.Archetype (Archetype) import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Archetypes (Node (..))+import qualified Aztecs.ECS.World.Archetypes as AS+import Aztecs.ECS.World.Entities (Entities (..)) import Control.Arrow (Arrow (..), ArrowChoice (..)) import Control.Category (Category (..)) import Data.Either (partitionEithers)+import Data.Foldable+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set import Prelude hiding ((.))  -- | Dynamic query for components by ID. newtype DynamicQuery i o-  = DynamicQuery {dynQueryAll :: [i] -> [EntityID] -> Archetype -> ([o], Archetype)}+  = DynamicQuery {runDynQuery :: [i] -> [EntityID] -> Archetype -> ([o], Archetype)}   deriving (Functor)  instance Applicative (DynamicQuery i) where   pure a = DynamicQuery $ \_ es arch -> (replicate (length es) a, arch)    f <*> g = DynamicQuery $ \i es arch ->-    let (as, arch') = dynQueryAll g i es arch-        (fs, arch'') = dynQueryAll f i es arch'+    let (as, arch') = runDynQuery g i es arch+        (fs, arch'') = runDynQuery f i es arch'      in (zipWith ($) fs as, arch'')  instance Category DynamicQuery where   id = DynamicQuery $ \as _ arch -> (as, arch)    f . g = DynamicQuery $ \i es arch ->-    let (as, arch') = dynQueryAll g i es arch in dynQueryAll f as es arch'+    let (as, arch') = runDynQuery g i es arch in runDynQuery f as es arch'  instance Arrow DynamicQuery where   arr f = DynamicQuery $ \bs _ arch -> (fmap f bs, arch)   first f = DynamicQuery $ \bds es arch ->     let (bs, ds) = unzip bds-        (cs, arch') = dynQueryAll f bs es arch+        (cs, arch') = runDynQuery f bs es arch      in (zip cs ds, arch')  instance ArrowChoice DynamicQuery where   left f = DynamicQuery $ \eds es arch ->     let (es', ds) = partitionEithers eds-        (cs, arch') = dynQueryAll f es' es arch+        (cs, arch') = runDynQuery f es' es arch      in (fmap Left cs ++ fmap Right ds, arch')  instance ArrowDynamicQueryReader DynamicQuery where@@ -63,9 +77,30 @@   fetchMaybeDyn = fromDynReader . fetchMaybeDyn  instance ArrowDynamicQuery DynamicQuery where-  setDyn cId = DynamicQuery $ \is es arch ->-    let !arch' = A.insertAscList cId (zip es is) arch in (is, arch')+  setDyn cId = DynamicQuery $ \is _ arch ->+    let !arch' = A.insertAscList cId is arch in (is, arch')  fromDynReader :: DynamicQueryReader i o -> DynamicQuery i o fromDynReader q = DynamicQuery $ \is es arch ->-  let os = dynQueryReaderAll q is es arch in (os, arch)+  let os = runDynQueryReader' q is es arch in (os, arch)++toDynReader :: DynamicQuery i o -> DynamicQueryReader i o+toDynReader q = DynamicQueryReader $ \is es arch -> fst $ runDynQuery q is es arch++-- | Map all matched entities.+mapDyn :: Set ComponentID -> i -> DynamicQuery i a -> Entities -> ([a], Entities)+mapDyn cIds i q es =+  let (as, es') =+        if Set.null cIds+          then (fst $ go (Map.keys $ entities es) A.empty, es)+          else+            foldl'+              ( \(acc, esAcc) (aId, n) ->+                  let (as', arch') = go (Set.toList . A.entities $ nodeArchetype n) (nodeArchetype n)+                      nodes = Map.insert aId n {nodeArchetype = arch'} (AS.nodes $ archetypes esAcc)+                   in (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}})+              )+              ([], es)+              (Map.toList $ AS.find cIds (archetypes es))+      go = runDynQuery q (repeat i)+   in (as, es')

@@ -1,5 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}  module Aztecs.ECS.Query.Dynamic.Reader@@ -7,6 +11,10 @@     DynamicQueryReader (..),     ArrowDynamicQueryReader (..), +    -- ** Running+    allDyn,+    runDynQueryReader,+     -- * Dynamic query filters     DynamicQueryFilter (..),   )@@ -17,15 +25,19 @@ import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) import Aztecs.ECS.World.Archetype (Archetype) import qualified Aztecs.ECS.World.Archetype as A+import qualified Aztecs.ECS.World.Archetypes as AS+import Aztecs.ECS.World.Entities (Entities (..)) import qualified Aztecs.ECS.World.Storage as S import Control.Arrow import Control.Category import Data.Either (partitionEithers)+import qualified Data.Map as Map import Data.Set (Set)+import qualified Data.Set as Set  -- | Dynamic query for components by ID. newtype DynamicQueryReader i o-  = DynamicQueryReader {dynQueryReaderAll :: [i] -> [EntityID] -> Archetype -> [o]}+  = DynamicQueryReader {runDynQueryReader' :: [i] -> [EntityID] -> Archetype -> [o]}   deriving (Functor)  instance Applicative (DynamicQueryReader i) where@@ -33,34 +45,36 @@    f <*> g =     DynamicQueryReader $ \i es arch ->-      let as = dynQueryReaderAll g i es arch-          fs = dynQueryReaderAll f i es arch+      let as = runDynQueryReader' g i es arch+          fs = runDynQueryReader' f i es arch        in zipWith ($) fs as  instance Category DynamicQueryReader where   id = DynamicQueryReader $ \as _ _ -> as   f . g = DynamicQueryReader $ \i es arch ->-    let as = dynQueryReaderAll g i es arch in dynQueryReaderAll f as es arch+    let as = runDynQueryReader' g i es arch in runDynQueryReader' f as es arch  instance Arrow DynamicQueryReader where   arr f = DynamicQueryReader $ \bs _ _ -> fmap f bs   first f = DynamicQueryReader $ \bds es arch ->     let (bs, ds) = unzip bds-        cs = dynQueryReaderAll f bs es arch+        cs = runDynQueryReader' f bs es arch      in zip cs ds  instance ArrowChoice DynamicQueryReader where   left f = DynamicQueryReader $ \eds es arch ->     let (es', ds) = partitionEithers eds-        cs = dynQueryReaderAll f es' es arch+        cs = runDynQueryReader' f es' es arch      in fmap Left cs ++ fmap Right ds  instance ArrowDynamicQueryReader DynamicQueryReader where   entity = DynamicQueryReader $ \_ es _ -> es+  fetchDyn :: forall a. (Component a) => ComponentID -> DynamicQueryReader () a   fetchDyn cId = DynamicQueryReader $ \_ _ arch ->-    let !as = maybe [] S.toList (A.lookupStorage cId arch) in fmap snd as-  fetchMaybeDyn cId = DynamicQueryReader $ \_ es arch -> case A.lookupStorage cId arch of-    Just s -> let !as = S.toList s in fmap Just $ snd <$> as+    maybe [] (S.toAscList @a @(StorageT a)) (A.lookupStorage @a cId arch)+  fetchMaybeDyn :: forall a. (Component a) => ComponentID -> DynamicQueryReader () (Maybe a)+  fetchMaybeDyn cId = DynamicQueryReader $ \_ es arch -> case A.lookupStorage @a cId arch of+    Just s -> let !as = S.toAscList @a @(StorageT a) s in fmap Just as     Nothing -> map (const Nothing) es  data DynamicQueryFilter = DynamicQueryFilter@@ -74,3 +88,17 @@  instance Monoid DynamicQueryFilter where   mempty = DynamicQueryFilter mempty mempty++runDynQueryReader :: i -> DynamicQueryReader i o -> [EntityID] -> Archetype -> [o]+runDynQueryReader i q = runDynQueryReader' q (repeat i)++-- | Match all entities.+allDyn :: Set ComponentID -> i -> DynamicQueryReader i a -> Entities -> [a]+allDyn cIds i q es =+  if Set.null cIds+    then runDynQueryReader i q (Map.keys $ entities es) A.empty+    else+      let go n =+            let eIds = Set.toList $ A.entities $ AS.nodeArchetype n+             in runDynQueryReader i q eIds (AS.nodeArchetype n)+       in concatMap go (AS.find cIds $ archetypes es)

@@ -12,6 +12,10 @@     ArrowQueryReader (..),     ArrowDynamicQueryReader (..), +    -- ** Running+    all,+    all',+     -- * Filters     QueryFilter (..),     with,@@ -22,16 +26,18 @@  import Aztecs.ECS.Component import Aztecs.ECS.Query.Dynamic (DynamicQueryFilter (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..), allDyn) import Aztecs.ECS.Query.Dynamic.Reader.Class (ArrowDynamicQueryReader (..)) import Aztecs.ECS.Query.Reader.Class (ArrowQueryReader (..)) import Aztecs.ECS.World.Components (Components) import qualified Aztecs.ECS.World.Components as CS+import Aztecs.ECS.World.Entities (Entities (..))+import qualified Aztecs.ECS.World.Entities as E import Control.Arrow (Arrow (..), ArrowChoice (..)) import Control.Category (Category (..)) import Data.Set (Set) import qualified Data.Set as Set-import Prelude hiding (id, (.))+import Prelude hiding (all, id, (.))  -- | Query to read from entities. newtype QueryReader i o@@ -96,3 +102,10 @@ without :: forall a. (Component a) => QueryFilter without = QueryFilter $ \cs ->   let (cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')++all :: i -> QueryReader i a -> Entities -> ([a], Entities)+all i q es = let (as, cs) = all' i q es in (as, es {E.components = cs})++-- | Match all entities.+all' :: i -> QueryReader i a -> Entities -> ([a], Components)+all' i q es = let (rs, cs', dynQ) = runQueryReader q (E.components es) in (allDyn rs i dynQ es, cs')

@@ -9,6 +9,7 @@     ArrowReaderSchedule (..),     ArrowSchedule (..),     ArrowAccessSchedule (..),+    fromReaderSchedule,     delay,     forever,     forever_,@@ -18,29 +19,28 @@ where  import Aztecs.ECS.Access (AccessT (..), runAccessT)-import Aztecs.ECS.Schedule.Access.Class (ArrowAccessSchedule (..))-import Aztecs.ECS.Schedule.Class (ArrowSchedule (..))-import Aztecs.ECS.Schedule.Dynamic (DynamicSchedule, DynamicScheduleT (..))-import Aztecs.ECS.Schedule.Reader.Class (ArrowReaderSchedule (..))-import Aztecs.ECS.System (System (..))-import Aztecs.ECS.System.Dynamic (DynamicSystem (..))-import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..))-import Aztecs.ECS.System.Reader (ReaderSystem (..))+import Aztecs.ECS.Schedule.Access.Class+import Aztecs.ECS.Schedule.Class+import Aztecs.ECS.Schedule.Dynamic+import Aztecs.ECS.Schedule.Reader (ReaderScheduleT (..))+import Aztecs.ECS.Schedule.Reader.Class+import Aztecs.ECS.System+import Aztecs.ECS.System.Dynamic+import Aztecs.ECS.System.Reader (ReaderSystemT (..)) import qualified Aztecs.ECS.View as V import Aztecs.ECS.World (World (..)) import qualified Aztecs.ECS.World as W import Aztecs.ECS.World.Bundle (Bundle) import Aztecs.ECS.World.Components (Components) import Aztecs.ECS.World.Entities (Entities (..))-import Control.Arrow (Arrow (..), ArrowLoop (..))-import Control.Category (Category (..))+import Control.Arrow+import Control.Category import Control.DeepSeq-import Control.Exception (evaluate)+import Control.Exception import Control.Monad.Fix-import Control.Monad.Identity (Identity (runIdentity)) import Control.Monad.State (MonadState (..)) import Control.Monad.Trans (MonadTrans (..))-import Data.Functor (void)+import Data.Functor import Prelude hiding (id, (.))  type Schedule m = ScheduleT (AccessT m)@@ -74,27 +74,23 @@ instance (Monad m) => ArrowAccessSchedule Bundle (AccessT m) (Schedule m) where   access f = Schedule $ \cs -> (accessDyn f, cs) -instance (Monad m) => ArrowReaderSchedule ReaderSystem (Schedule m) where-  reader s = Schedule $ \cs ->-    let (dynS, _, cs') = runReaderSystem s cs-        go dynSAcc i = AccessT $ do-          w <- get-          let (o, a, dynSAcc') = runReaderSystemDyn dynSAcc (W.entities w) i-              ((), w') = runIdentity $ runAccessT a w-          put w'-          return (o, DynamicSchedule $ go dynSAcc')-     in (DynamicSchedule $ go dynS, cs')+instance (Monad m) => ArrowReaderSchedule (ReaderSystemT m) (Schedule m) where+  reader = fromReaderSchedule . reader -instance (Monad m) => ArrowSchedule System (Schedule m) where+instance (Monad m) => ArrowSchedule (SystemT m) (Schedule m) where   system s = Schedule $ \cs ->     let (dynS, _, cs') = runSystem s cs         go dynSAcc i = AccessT $ do           w <- get           let (o, v, a, dynSAcc') = runSystemDyn dynSAcc (W.entities w) i-              ((), w') = runIdentity $ runAccessT a w {W.entities = V.unview v (W.entities w)}+          ((), w') <- lift $ runAccessT a w {W.entities = V.unview v (W.entities w)}           put w'           return (o, DynamicSchedule $ go dynSAcc')      in (DynamicSchedule $ go dynS, cs')++fromReaderSchedule :: (Monad m) => ReaderScheduleT m i o -> ScheduleT m i o+fromReaderSchedule s = Schedule $ \cs ->+  let (dynS, cs') = runReaderSchedule s cs in (fromDynReaderSchedule dynS, cs')  delay :: (Monad m) => a -> Schedule m a a delay d = Schedule $ \cs -> (delayDyn d, cs)

@@ -4,10 +4,12 @@ module Aztecs.ECS.Schedule.Dynamic   ( DynamicSchedule,     DynamicScheduleT (..),+    fromDynReaderSchedule,   ) where  import Aztecs.ECS.Access+import Aztecs.ECS.Schedule.Dynamic.Reader (DynamicReaderScheduleT (..)) import Control.Arrow import Control.Category import Control.Monad.Fix@@ -42,3 +44,8 @@   loop (DynamicSchedule f) = DynamicSchedule $ \b -> do     rec ((c, d), f') <- f (b, d)     return (c, loop f')++fromDynReaderSchedule :: (Monad m) => DynamicReaderScheduleT m i o -> DynamicScheduleT m i o+fromDynReaderSchedule (DynamicReaderSchedule f) = DynamicSchedule $ \i -> do+  (o, f') <- f i+  return (o, fromDynReaderSchedule f')

@@ -7,18 +7,18 @@   ) where -import Aztecs.ECS.Access (AccessT (..), runAccessT)-import Aztecs.ECS.Schedule.Dynamic.Reader (DynamicReaderScheduleT (..))+import Aztecs.ECS.Access+import Aztecs.ECS.Schedule.Dynamic.Reader import Aztecs.ECS.Schedule.Reader.Class-import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..))-import Aztecs.ECS.System.Reader (ReaderSystem (..))+import Aztecs.ECS.System.Dynamic.Reader+import Aztecs.ECS.System.Reader import Aztecs.ECS.World (World (..)) import Aztecs.ECS.World.Components (Components) import Control.Arrow import Control.Category import Control.Monad.Fix-import Control.Monad.Identity (Identity (runIdentity)) import Control.Monad.State (MonadState (..))+import Control.Monad.Trans import Prelude hiding (id, (.))  type ReaderSchedule m = ReaderScheduleT (AccessT m)@@ -44,13 +44,13 @@ instance (MonadFix m) => ArrowLoop (ReaderScheduleT m) where   loop (ReaderSchedule f) = ReaderSchedule $ \cs -> let (f', cs') = f cs in (loop f', cs') -instance (Monad m) => ArrowReaderSchedule ReaderSystem (ReaderSchedule m) where+instance (Monad m) => ArrowReaderSchedule (ReaderSystemT m) (ReaderSchedule m) where   reader s = ReaderSchedule $ \cs ->     let (dynS, _, cs') = runReaderSystem s cs         go dynSAcc i = AccessT $ do           w <- get           let (o, a, dynSAcc') = runReaderSystemDyn dynSAcc (entities w) i-              ((), w') = runIdentity $ runAccessT a w+          ((), w') <- lift $ runAccessT a w           put w'           return (o, DynamicReaderSchedule $ go dynSAcc')      in (DynamicReaderSchedule $ go dynS, cs')

@@ -4,7 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System-  ( System (..),+  ( System,+    SystemT (..),     ArrowReaderSystem (..),     ArrowSystem (..),     ArrowQueueSystem (..),@@ -12,42 +13,41 @@   ) where -import Aztecs.ECS.Access (Access)+import Aztecs.ECS.Access import Aztecs.ECS.Query (Query (..), QueryFilter (..), ReadsWrites (..)) import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Reader (QueryReader (..), filterWith, filterWithout)-import Aztecs.ECS.System.Class (ArrowSystem (..))-import Aztecs.ECS.System.Dynamic (DynamicSystem (..), fromDynReaderSystem, raceDyn)-import Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..))-import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))-import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))-import Aztecs.ECS.System.Reader (ReaderSystem (..))-import Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..), all, filter, single)+import Aztecs.ECS.Query.Reader (DynamicQueryFilter (..), QueryReader (..))+import Aztecs.ECS.System.Class+import Aztecs.ECS.System.Dynamic+import Aztecs.ECS.System.Reader import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Archetypes (Node (..))-import Aztecs.ECS.World.Bundle (Bundle)+import Aztecs.ECS.World.Bundle import Aztecs.ECS.World.Components (Components) import Control.Arrow import Control.Category+import Control.Monad.Identity import qualified Data.Foldable as F import Prelude hiding (all, filter, id, map, (.)) import qualified Prelude hiding (filter, id, map) +type System = SystemT Identity+ -- | System to process entities.-newtype System i o = System+newtype SystemT m i o = System   { -- | Run a system, producing a `DynamicSystem` that can be repeatedly run.-    runSystem :: Components -> (DynamicSystem i o, ReadsWrites, Components)+    runSystem :: Components -> (DynamicSystemT m i o, ReadsWrites, Components)   }   deriving (Functor) -instance Category System where+instance (Monad m) => Category (SystemT m) where   id = System $ \cs -> (DynamicSystem $ \_ i -> (i, mempty, pure (), id), mempty, cs)   System f . System g = System $ \cs ->     let (f', rwsF, cs') = f cs         (g', rwsG, cs'') = g cs'      in (f' . g', rwsF <> rwsG, cs'') -instance Arrow System where+instance (Monad m) => Arrow (SystemT m) where   arr f = System $ \cs -> (DynamicSystem $ \_ i -> (f i, mempty, pure (), arr f), mempty, cs)   first (System f) = System $ \cs ->     let (f', rwsF, cs') = f cs in (first f', rwsF, cs')@@ -57,24 +57,17 @@         dynS = if Q.disjoint rwsA rwsB then dynF &&& dynG else raceDyn dynF dynG      in (dynS, rwsA <> rwsB, cs'') -instance ArrowChoice System where+instance (Monad m) => ArrowChoice (SystemT m) where   left (System f) = System $ \cs -> let (f', rwsF, cs') = f cs in (left f', rwsF, cs') -instance ArrowLoop System where+instance (Monad m) => ArrowLoop (SystemT m) where   loop (System f) = System $ \cs -> let (f', rwsF, cs') = f cs in (loop f', rwsF, cs') -instance ArrowReaderSystem QueryReader System where-  all q = System $ \cs ->-    let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, ReadsWrites rs mempty, cs')-  filter q qf = System $ \cs ->-    let !(rs, cs', dynQ) = runQueryReader q cs-        !(dynQf, cs'') = runQueryFilter qf cs'-        qf' n =-          F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynQf)-            && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)-     in (filterDyn rs dynQ qf', ReadsWrites rs mempty, cs'')+instance (Monad m) => ArrowReaderSystem QueryReader (SystemT m) where+  all = fromReader . all+  filter q = fromReader . filter q -instance ArrowSystem Query System where+instance (Monad m) => ArrowSystem Query (SystemT m) where   map q = System $ \cs ->     let !(rws, cs', dynQ) = runQuery q cs      in (mapDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')@@ -92,9 +85,9 @@     let !(rws, cs', dynQ) = runQuery q cs      in (mapSingleMaybeDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs') -instance ArrowQueueSystem Bundle Access System where+instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (SystemT m) where   queue f = System $ \cs -> (queue f, mempty, cs) -fromReader :: ReaderSystem i o -> System i o+fromReader :: (Monad m) => ReaderSystemT m i o -> SystemT m i o fromReader (ReaderSystem f) = System $ \cs ->   let (f', rs, cs') = f cs in (fromDynReaderSystem f', ReadsWrites rs mempty, cs')

@@ -4,7 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System.Dynamic-  ( DynamicSystem (..),+  ( DynamicSystem,+    DynamicSystemT (..),     ArrowDynamicReaderSystem (..),     ArrowDynamicSystem (..),     ArrowQueueSystem (..),@@ -13,56 +14,59 @@   ) where -import Aztecs.ECS.Access (Access)-import Aztecs.ECS.Query.Dynamic (DynamicQuery)-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader)-import Aztecs.ECS.System.Dynamic.Class (ArrowDynamicSystem (..))-import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem (..))-import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))+import Aztecs.ECS.Access+import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.System.Dynamic.Class+import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystemT (..))+import Aztecs.ECS.System.Dynamic.Reader.Class import Aztecs.ECS.System.Queue (ArrowQueueSystem (..)) import Aztecs.ECS.View (View) import qualified Aztecs.ECS.View as V-import Aztecs.ECS.World.Bundle (Bundle)+import Aztecs.ECS.World.Bundle import Aztecs.ECS.World.Entities (Entities (..)) import Control.Arrow import Control.Category+import Control.Monad.Identity import Control.Parallel (par) import Data.Maybe (fromMaybe) import Prelude hiding (id, (.)) -newtype DynamicSystem i o = DynamicSystem+type DynamicSystem = DynamicSystemT Identity++newtype DynamicSystemT m i o = DynamicSystem   { -- | Run a dynamic system,     -- producing some output, an updated `View` into the `World`, and any queued `Access`.-    runSystemDyn :: Entities -> i -> (o, View, Access (), DynamicSystem i o)+    runSystemDyn :: Entities -> i -> (o, View, AccessT m (), DynamicSystemT m i o)   }   deriving (Functor) -instance Category DynamicSystem where+instance (Monad m) => Category (DynamicSystemT m) where   id = DynamicSystem $ \_ i -> (i, mempty, pure (), id)   DynamicSystem f . DynamicSystem g = DynamicSystem $ \w i ->     let (b, gView, gAccess, g') = g w i         (a, fView, fAccess, f') = f w b      in (a, gView <> fView, gAccess >> fAccess, f' . g') -instance Arrow DynamicSystem where+instance (Monad m) => Arrow (DynamicSystemT m) where   arr f = DynamicSystem $ \_ i -> (f i, mempty, pure (), arr f)   first (DynamicSystem f) = DynamicSystem $ \w (i, x) ->     let (a, v, access, f') = f w i in ((a, x), v, access, first f') -instance ArrowChoice DynamicSystem where+instance (Monad m) => ArrowChoice (DynamicSystemT m) where   left (DynamicSystem f) = DynamicSystem $ \w i -> case i of     Left b -> let (c, v, access, f') = f w b in (Left c, v, access, left f')     Right d -> (Right d, mempty, pure (), left (DynamicSystem f)) -instance ArrowLoop DynamicSystem where+instance (Monad m) => ArrowLoop (DynamicSystemT m) where   loop (DynamicSystem f) = DynamicSystem $ \w b ->     let ((c, d), v, access, f') = f w (b, d) in (c, v, access, loop f') -instance ArrowDynamicReaderSystem DynamicQueryReader DynamicSystem where+instance (Monad m) => ArrowDynamicReaderSystem DynamicQueryReader (DynamicSystemT m) where   allDyn cIds q = fromDynReaderSystem $ allDyn cIds q   filterDyn cIds qf q = fromDynReaderSystem $ filterDyn cIds qf q -instance ArrowDynamicSystem DynamicQuery DynamicSystem where+instance (Monad m) => ArrowDynamicSystem DynamicQuery (DynamicSystemT m) where   mapDyn cIds q = DynamicSystem $ \w i ->     let !v = V.view cIds $ archetypes w         (o, v') = V.allDyn i q v@@ -83,10 +87,10 @@         (o, v') = V.allDyn i q v      in (o, v', pure (), filterMapDyn cIds q f) -instance ArrowQueueSystem Bundle Access DynamicSystem where+instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (DynamicSystemT m) where   queue f = DynamicSystem $ \_ i -> ((), mempty, f i, queue f) -raceDyn :: DynamicSystem i a -> DynamicSystem i b -> DynamicSystem i (a, b)+raceDyn :: (Monad m) => DynamicSystemT m i a -> DynamicSystemT m i b -> DynamicSystemT m i (a, b) raceDyn (DynamicSystem f) (DynamicSystem g) = DynamicSystem $ \w i ->   let fa = f w i       gb = g w i@@ -95,6 +99,6 @@       (b, v', gAccess, g') = gbPar    in ((a, b), v <> v', fAccess >> gAccess, raceDyn f' g') -fromDynReaderSystem :: DynamicReaderSystem i o -> DynamicSystem i o+fromDynReaderSystem :: DynamicReaderSystemT m i o -> DynamicSystemT m i o fromDynReaderSystem (DynamicReaderSystem f) = DynamicSystem $ \w i ->   let (o, access, f') = f w i in (o, mempty, access, fromDynReaderSystem f')

@@ -4,63 +4,72 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System.Dynamic.Reader-  ( DynamicReaderSystem (..),+  ( DynamicReaderSystem,+    DynamicReaderSystemT (..),     ArrowDynamicReaderSystem (..),     ArrowQueueSystem (..),     raceDyn,   ) where -import Aztecs.ECS.Access (Access)-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader)-import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))+import Aztecs.ECS.Access+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..), runDynQueryReader)+import Aztecs.ECS.System.Dynamic.Reader.Class import Aztecs.ECS.System.Queue (ArrowQueueSystem (..)) import qualified Aztecs.ECS.View as V-import Aztecs.ECS.World.Bundle (Bundle)+import qualified Aztecs.ECS.World.Archetype as A+import Aztecs.ECS.World.Bundle import Aztecs.ECS.World.Entities (Entities (..)) import Control.Arrow import Control.Category+import Control.Monad.Identity import Control.Parallel (par)+import qualified Data.Map as Map import Prelude hiding (id, (.)) -newtype DynamicReaderSystem i o = DynamicReaderSystem+type DynamicReaderSystem = DynamicReaderSystemT Identity++newtype DynamicReaderSystemT m i o = DynamicReaderSystem   { -- | Run a dynamic system producing some output-    runReaderSystemDyn :: Entities -> i -> (o, Access (), DynamicReaderSystem i o)+    runReaderSystemDyn :: Entities -> i -> (o, AccessT m (), DynamicReaderSystemT m i o)   }   deriving (Functor) -instance Category DynamicReaderSystem where+instance (Monad m) => Category (DynamicReaderSystemT m) where   id = DynamicReaderSystem $ \_ i -> (i, pure (), id)   DynamicReaderSystem f . DynamicReaderSystem g = DynamicReaderSystem $ \w i ->     let (b, gAccess, g') = g w i         (c, fAccess, f') = f w b      in (c, gAccess >> fAccess, f' . g') -instance Arrow DynamicReaderSystem where+instance (Monad m) => Arrow (DynamicReaderSystemT m) where   arr f = DynamicReaderSystem $ \_ i -> (f i, pure (), arr f)   first (DynamicReaderSystem f) = DynamicReaderSystem $ \w (i, x) ->     let (a, access, f') = f w i in ((a, x), access, first f') -instance ArrowChoice DynamicReaderSystem where+instance (Monad m) => ArrowChoice (DynamicReaderSystemT m) where   left (DynamicReaderSystem f) = DynamicReaderSystem $ \w i -> case i of     Left b -> let (c, access, f') = f w b in (Left c, access, left f')     Right d -> (Right d, pure (), left (DynamicReaderSystem f)) -instance ArrowLoop DynamicReaderSystem where+instance (Monad m) => ArrowLoop (DynamicReaderSystemT m) where   loop (DynamicReaderSystem f) = DynamicReaderSystem $ \w b ->     let ((c, d), access, f') = f w (b, d) in (c, access, loop f') -instance ArrowDynamicReaderSystem DynamicQueryReader DynamicReaderSystem where+instance (Monad m) => ArrowDynamicReaderSystem DynamicQueryReader (DynamicReaderSystemT m) where   allDyn cIds q = DynamicReaderSystem $ \w i ->-    let !v = V.view cIds $ archetypes w in (V.readAllDyn i q v, pure (), allDyn cIds q)+    let !v = V.view cIds $ archetypes w+     in if V.null v+          then (runDynQueryReader i q (Map.keys $ entities w) A.empty, pure (), allDyn cIds q)+          else (V.readAllDyn i q v, pure (), allDyn cIds q)   filterDyn cIds q f = DynamicReaderSystem $ \w i ->     let !v = V.filterView cIds f $ archetypes w      in (V.readAllDyn i q v, pure (), filterDyn cIds q f) -instance ArrowQueueSystem Bundle Access DynamicReaderSystem where+instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (DynamicReaderSystemT m) where   queue f = DynamicReaderSystem $ \_ i -> let !a = f i in ((), a, queue f) -raceDyn :: DynamicReaderSystem i a -> DynamicReaderSystem i b -> DynamicReaderSystem i (a, b)+raceDyn :: (Monad m) => DynamicReaderSystemT m i a -> DynamicReaderSystemT m i b -> DynamicReaderSystemT m i (a, b) raceDyn (DynamicReaderSystem f) (DynamicReaderSystem g) = DynamicReaderSystem $ \w i ->   let fa = f w i       gb = g w i

@@ -4,17 +4,16 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.System.Reader-  ( ReaderSystem (..),+  ( ReaderSystem,+    ReaderSystemT (..),     ArrowReaderSystem (..),     ArrowQueueSystem (..),   ) where -import Aztecs.ECS.Access (Access)+import Aztecs.ECS.Access (AccessT) import Aztecs.ECS.Query.Reader-import Aztecs.ECS.System.Dynamic.Reader (DynamicReaderSystem, raceDyn)-import Aztecs.ECS.System.Dynamic.Reader.Class (ArrowDynamicReaderSystem (..))-import Aztecs.ECS.System.Queue (ArrowQueueSystem (..))+import Aztecs.ECS.System.Dynamic.Reader import Aztecs.ECS.System.Reader.Class (ArrowReaderSystem (..)) import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Archetypes (Node (..))@@ -22,25 +21,28 @@ import Aztecs.ECS.World.Components (ComponentID, Components) import Control.Arrow import Control.Category+import Control.Monad.Identity import qualified Data.Foldable as F import Data.Set (Set) import Prelude hiding (id, (.)) +type ReaderSystem = ReaderSystemT Identity+ -- | System to process entities.-newtype ReaderSystem i o = ReaderSystem+newtype ReaderSystemT m i o = ReaderSystem   { -- | Run a system, producing a `DynamicSystem` that can be repeatedly run.-    runReaderSystem :: Components -> (DynamicReaderSystem i o, Set ComponentID, Components)+    runReaderSystem :: Components -> (DynamicReaderSystemT m i o, Set ComponentID, Components)   }   deriving (Functor) -instance Category ReaderSystem where+instance (Monad m) => Category (ReaderSystemT m) where   id = ReaderSystem $ \cs -> (id, mempty, cs)   ReaderSystem f . ReaderSystem g = ReaderSystem $ \cs ->     let (f', rwsF, cs') = f cs         (g', rwsG, cs'') = g cs'      in (f' . g', rwsF <> rwsG, cs'') -instance Arrow ReaderSystem where+instance (Monad m) => Arrow (ReaderSystemT m) where   arr f = ReaderSystem $ \cs -> (arr f, mempty, cs)   first (ReaderSystem f) = ReaderSystem $ \cs ->     let (f', rwsF, cs') = f cs in (first f', rwsF, cs')@@ -49,13 +51,13 @@         (dynG, rwsB, cs'') = runReaderSystem g cs'      in (raceDyn dynF dynG, rwsA <> rwsB, cs'') -instance ArrowChoice ReaderSystem where+instance (Monad m) => ArrowChoice (ReaderSystemT m) where   left (ReaderSystem f) = ReaderSystem $ \cs -> let (f', rwsF, cs') = f cs in (left f', rwsF, cs') -instance ArrowLoop ReaderSystem where+instance (Monad m) => ArrowLoop (ReaderSystemT m) where   loop (ReaderSystem f) = ReaderSystem $ \cs -> let (f', rwsF, cs') = f cs in (loop f', rwsF, cs') -instance ArrowReaderSystem QueryReader ReaderSystem where+instance (Monad m) => ArrowReaderSystem QueryReader (ReaderSystemT m) where   all q = ReaderSystem $ \cs ->     let !(rs, cs', dynQ) = runQueryReader q cs in (allDyn rs dynQ, rs, cs')   filter q qf = ReaderSystem $ \cs ->@@ -66,5 +68,5 @@             && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynQf)      in (filterDyn rs dynQ qf', rs, cs'') -instance ArrowQueueSystem Bundle Access ReaderSystem where+instance (Monad m) => ArrowQueueSystem Bundle (AccessT m) (ReaderSystemT m) where   queue f = ReaderSystem $ \cs -> (queue f, mempty, cs)

@@ -1,15 +1,14 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}  module Aztecs.ECS.View   ( View (..),     view,     viewSingle,     filterView,+    null,     unview,     allDyn,     singleDyn,@@ -18,20 +17,19 @@ where  import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))-import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..))+import Aztecs.ECS.Query.Dynamic.Reader (DynamicQueryReader (..), runDynQueryReader) import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Archetypes (ArchetypeID, Archetypes, Node (..)) import qualified Aztecs.ECS.World.Archetypes as AS import Aztecs.ECS.World.Components (ComponentID) import Aztecs.ECS.World.Entities (Entities) import qualified Aztecs.ECS.World.Entities as E+import Data.Foldable (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set)--#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif+import qualified Data.Set as Set+import Prelude hiding (null)  -- | View into a `World`, containing a subset of archetypes. newtype View = View {viewArchetypes :: Map ArchetypeID Node}@@ -43,7 +41,7 @@  viewSingle :: Set ComponentID -> Archetypes -> Maybe View viewSingle cIds as = case Map.toList $ AS.find cIds as of-  [a] -> Just . View $ Map.singleton (fst a) (snd a)+  [a] -> Just . View $ uncurry Map.singleton a   _ -> Nothing  -- | View into all archetypes containing the provided component IDs and matching the provided predicate.@@ -54,6 +52,9 @@   View filterView cIds f as = View $ Map.filter f (AS.find cIds as) +null :: View -> Bool+null = Map.null . viewArchetypes+ -- | "Un-view" a `View` back into a `World`. unview :: View -> Entities -> Entities unview v es =@@ -71,7 +72,7 @@   let (as, arches) =         foldl'           ( \(acc, archAcc) (aId, n) ->-              let (as', arch') = dynQueryAll q (repeat i) (A.entities (nodeArchetype n)) (nodeArchetype n)+              let (as', arch') = runDynQuery q (repeat i) (Set.toList . A.entities $ nodeArchetype n) (nodeArchetype n)                in (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)           )           ([], Map.empty)@@ -82,7 +83,7 @@ singleDyn :: i -> DynamicQuery i a -> View -> (Maybe a, View) singleDyn i q v = case allDyn i q v of   -- TODO [a], removing this errors for now-  ((a : _), v') -> (Just a, v')+  (a : _, v') -> (Just a, v')   _ -> (Nothing, v)  -- | Query all matching entities in a `View`.@@ -90,7 +91,7 @@ readAllDyn i q v =   foldl'     ( \acc n ->-        dynQueryReaderAll q (repeat i) (A.entities (nodeArchetype n)) (nodeArchetype n) ++ acc+        runDynQueryReader i q (Set.toList . A.entities $ nodeArchetype n) (nodeArchetype n) ++ acc     )     []     (viewArchetypes v)

@@ -1,11 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}  module Aztecs.ECS.World@@ -34,10 +32,6 @@ import Data.Map (Map) import GHC.Generics import Prelude hiding (lookup)--#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif  -- | World of entities and their components. data World = World

@@ -1,21 +1,19 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Aztecs.ECS.World.Archetype   ( Archetype (..),     empty,-    entities,     lookupComponent,     lookupStorage,     member,@@ -30,60 +28,64 @@ import Aztecs.ECS.Entity import qualified Aztecs.ECS.World.Storage as S import Aztecs.ECS.World.Storage.Dynamic+import qualified Aztecs.ECS.World.Storage.Dynamic as S import Control.DeepSeq import Data.Dynamic+import Data.Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set import GHC.Generics -#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif--newtype Archetype = Archetype {storages :: Map ComponentID DynamicStorage}+data Archetype = Archetype+  { storages :: !(Map ComponentID DynamicStorage),+    entities :: !(Set EntityID)+  }   deriving (Show, Generic, NFData)  empty :: Archetype-empty = Archetype {storages = Map.empty}+empty = Archetype {storages = Map.empty, entities = Set.empty} -lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a a)+lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a) lookupStorage cId w = do   dynS <- Map.lookup cId (storages w)   fromDynamic (storageDyn dynS) +lookupComponents :: forall a. (Component a) => ComponentID -> Archetype -> Map EntityID a+lookupComponents cId arch = case lookupStorage @a cId arch of+  Just s -> Map.fromAscList . zip (Set.toList $ entities arch) $ S.toAscList s+  Nothing -> Map.empty+ 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 (dynStorage storage) (storages arch)}+  let !storage =+        S.fromAscList @a @(StorageT a) . Map.elems . Map.insert e c $ lookupComponents cId arch+   in arch {storages = Map.insert cId (dynStorage @a storage) (storages arch)}  member :: ComponentID -> Archetype -> Bool member cId arch = Map.member cId (storages arch) -entities :: Archetype -> [EntityID]-entities arch = case Map.toList $ storages arch of-  [] -> []-  (_, s) : _ -> map (\i -> (EntityID i)) $ entitiesDyn s- lookupComponent :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a-lookupComponent e cId w = lookupStorage cId w >>= S.lookup (unEntityId e)+lookupComponent e cId w = lookupComponents cId w Map.!? e  -- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`.-insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype+insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype insertAscList cId as arch =-  let !storage = dynStorage $ S.fromAscList @(StorageT a) (map (\(e, a) -> (unEntityId e, a)) as)+  let !storage = dynStorage @a $ S.fromAscList @a @(StorageT a) as    in arch {storages = Map.insert cId storage (storages arch)}  remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype) remove e arch =   foldl'-    ( \(dynAcc, archAcc) (cId, s) ->-        let !(dynA, dynS) = removeDyn (unEntityId e) s+    ( \(dynAcc, archAcc) (cId, dynS) ->+        let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS+            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs+            dynS' = S.fromAscListDyn (Map.elems cs') dynS             !dynAcc' = case dynA of               Just d -> Map.insert cId d dynAcc               Nothing -> dynAcc-         in (dynAcc', archAcc {storages = Map.insert cId dynS $ storages archAcc})+         in (dynAcc', archAcc {storages = Map.insert cId dynS' $ storages archAcc})     )     (Map.empty, arch)     (Map.toList $ storages arch)@@ -91,12 +93,14 @@ removeStorages :: EntityID -> Archetype -> (Map ComponentID DynamicStorage, Archetype) removeStorages e arch =   foldl'-    ( \(dynAcc, archAcc) (cId, s) ->-        let (dynA, dynS) = removeAny (unEntityId e) s-            dynAcc' = case dynA of-              Just d -> Map.insert cId d dynAcc+    ( \(dynAcc, archAcc) (cId, dynS) ->+        let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS+            !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs+            dynS' = S.fromAscListDyn (Map.elems cs') dynS+            !dynAcc' = case dynA of+              Just d -> Map.insert cId (S.singletonDyn d dynS') dynAcc               Nothing -> dynAcc-         in (dynAcc', archAcc {storages = Map.insert cId dynS $ storages archAcc})+         in (dynAcc', archAcc {storages = Map.insert cId dynS' $ storages archAcc})     )     (Map.empty, arch)     (Map.toList $ storages arch)

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}@@ -37,9 +36,10 @@     removeStorages,   ) import qualified Aztecs.ECS.World.Archetype as A-import Aztecs.ECS.World.Storage.Dynamic (insertDyn, removeDyn)+import Aztecs.ECS.World.Storage.Dynamic (fromAscListDyn, toAscListDyn) import Control.DeepSeq (NFData (..)) import Data.Dynamic (fromDynamic)+import Data.Foldable (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe)@@ -48,10 +48,6 @@ import GHC.Generics (Generic) import Prelude hiding (all, lookup, map) -#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif- -- | `Archetype` ID. newtype ArchetypeID = ArchetypeID {unArchetypeId :: Int}   deriving newtype (Eq, Ord, Show, NFData)@@ -155,19 +151,19 @@               node' = node {nodeArchetype = arch'}               !arches' = arches {nodes = Map.insert aId node' (nodes arches)}               f archAcc (itemCId, dyn) =-                let go s = insertDyn (unEntityId e) dyn s-                    storages' = Map.adjust go itemCId (storages archAcc)+                let storages' = Map.adjust go itemCId (storages archAcc)+                    go s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s                  in archAcc {storages = storages'}               adjustNode nextNode =                 let nextArch = foldl' f (nodeArchetype nextNode) (Map.toList cs)                  in nextNode {nodeArchetype = insertComponent e cId c nextArch}-           in (Just nextAId, arches' {nodes = Map.adjust adjustNode nextAId (nodes $ arches')})+           in (Just nextAId, arches' {nodes = Map.adjust adjustNode nextAId (nodes arches')})         Nothing ->           let !(s, arch') = removeStorages e (nodeArchetype node)               !n =                 Node                   { nodeComponentIds = Set.insert cId (nodeComponentIds node),-                    nodeArchetype = insertComponent e cId c (Archetype {storages = s}),+                    nodeArchetype = insertComponent e cId c (Archetype {storages = s, entities = Set.singleton e}),                     nodeAdd = Map.empty,                     nodeRemove = Map.singleton cId aId                   }@@ -193,12 +189,12 @@           !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}           (a, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) cId cs           go' archAcc (itemCId, dyn) =-            let adjustStorage s = insertDyn (unEntityId e) dyn s+            let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s              in archAcc {storages = Map.adjust adjustStorage itemCId (storages archAcc)}           go nextNode =             nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (Map.toList cs')}        in ( (,nextAId) <$> (a >>= fromDynamic),-            arches' {nodes = Map.adjust go nextAId (nodes $ arches')}+            arches' {nodes = Map.adjust go nextAId (nodes arches')}           )     Nothing ->       let !(cs, arch') = removeStorages e (nodeArchetype node)@@ -206,13 +202,16 @@           !n =             Node               { nodeComponentIds = Set.insert cId (nodeComponentIds node),-                nodeArchetype = Archetype {storages = cs'},+                nodeArchetype = Archetype {storages = cs', entities = Set.singleton e},                 nodeAdd = Map.empty,                 nodeRemove = Map.singleton cId aId               }           !(nextAId, arches') = insertArchetype (Set.insert cId (nodeComponentIds node)) n arches           node' = node {nodeArchetype = arch', nodeAdd = Map.insert cId nextAId (nodeAdd node)}-       in ( (,nextAId) <$> (a >>= (\a' -> (fst $ removeDyn (unEntityId e) a') >>= fromDynamic)),+          removeDyn s =+            let (res, dyns) = Map.updateLookupWithKey (\_ _ -> Nothing) e . Map.fromAscList . zip (Set.toList $ entities arch') $ toAscListDyn s+             in (res, fromAscListDyn $ Map.elems dyns)+       in ( (,nextAId) <$> (a >>= (\a' -> fst (removeDyn a') >>= fromDynamic)),             arches' {nodes = Map.insert aId node' (nodes arches')}           )   Nothing -> (Nothing, arches)

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -41,10 +40,6 @@ import GHC.Generics import Prelude hiding (lookup) -#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif- -- | World of entities and their components. data Entities = Entities   { archetypes :: !Archetypes,@@ -68,7 +63,14 @@    in case AS.lookupArchetypeId cIds (archetypes w) of         Just aId -> fromMaybe w $ do           node <- AS.lookup aId $ archetypes w-          let arch' = runDynamicBundle dynB eId (nodeArchetype node)+          let arch' =+                runDynamicBundle+                  dynB+                  eId+                  ( (nodeArchetype node)+                      { A.entities = Set.insert eId . A.entities $ nodeArchetype node+                      }+                  )           return             w               { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},@@ -76,7 +78,7 @@                 entities = Map.insert eId aId (entities w)               }         Nothing ->-          let arch' = runDynamicBundle dynB eId A.empty+          let arch' = runDynamicBundle dynB eId A.empty {A.entities = Set.singleton eId}               (aId, arches) =                 AS.insertArchetype                   cIds

@@ -1,38 +1,23 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Aztecs.ECS.World.Storage (Storage (..)) where -import Control.DeepSeq (NFData)-import Data.Data (Typeable)-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap+import Control.DeepSeq+import Data.Data  -- | Component storage, containing zero or many components of the same type.-class (Typeable (s a), NFData (s a), Typeable a) => Storage s a where+class (Typeable s, NFData s, Typeable a) => Storage a s where   -- | Storage with a single component.-  singleton :: Int -> a -> s a--  -- | List of all components in the storage.-  toList :: s a -> [(Int, a)]--  -- | Insert a component into the storage.-  insert :: Int -> a -> s a -> s a+  singleton :: a -> s -  -- | Lookup a component in the storage.-  lookup :: Int -> s a -> Maybe a+  -- | List of all components in the storage in ascending order.+  toAscList :: s -> [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)+  fromAscList :: [a] -> s -instance (Typeable a, NFData a) => Storage IntMap a where-  singleton = IntMap.singleton-  toList = 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+instance (Typeable a, NFData a) => Storage a [a] where+  singleton a = [a]+  toAscList = id+  fromAscList = id

@@ -1,5 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -12,10 +11,9 @@ module Aztecs.ECS.World.Storage.Dynamic   ( DynamicStorage (..),     dynStorage,-    insertDyn,-    removeDyn,-    removeAny,-    entitiesDyn,+    singletonDyn,+    fromAscListDyn,+    toAscListDyn,   ) where @@ -26,10 +24,9 @@  data DynamicStorage = DynamicStorage   { storageDyn :: !Dynamic,-    insertDyn' :: !(Int -> Dynamic -> Dynamic -> Dynamic),-    removeDyn' :: !(Int -> Dynamic -> (Maybe Dynamic, Dynamic)),-    removeAny' :: !(Int -> Dynamic -> (Maybe DynamicStorage, Dynamic)),-    entitiesDyn' :: !(Dynamic -> [Int]),+    singletonDyn' :: !(Dynamic -> Dynamic),+    toAscListDyn' :: !(Dynamic -> [Dynamic]),+    fromAscListDyn' :: !([Dynamic] -> Dynamic),     storageRnf :: !(Dynamic -> ())   } @@ -39,35 +36,21 @@ instance NFData DynamicStorage where   rnf s = storageRnf s (storageDyn s) -dynStorage :: forall s a. (S.Storage s a) => s a -> DynamicStorage+dynStorage :: forall a s. (S.Storage a s) => s -> DynamicStorage dynStorage s =   DynamicStorage     { storageDyn = toDyn s,-      insertDyn' = \i cDyn sDyn ->-        fromMaybe sDyn $ do-          !s' <- fromDynamic @(s a) sDyn-          !c <- fromDynamic cDyn-          return . toDyn $ S.insert i c s',-      removeDyn' = \i dyn -> case fromDynamic @(s a) dyn of-        Just s' -> let !(a, b) = S.remove i s' in (fmap toDyn a, toDyn b)-        Nothing -> (Nothing, dyn),-      removeAny' = \i dyn -> case fromDynamic @(s a) dyn of-        Just s' -> let !(a, b) = S.remove i s' in (fmap (dynStorage . S.singleton @s i) a, toDyn b)-        Nothing -> (Nothing, dyn),-      entitiesDyn' = \dyn -> case fromDynamic @(s a) dyn of-        Just s' -> map fst $ S.toList s'-        Nothing -> [],-      storageRnf = \dyn -> maybe () rnf (fromDynamic @(s a) dyn)+      singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic,+      toAscListDyn' = \d -> map toDyn (S.toAscList @a @s (fromMaybe (error "TODO") $ fromDynamic d)),+      fromAscListDyn' = toDyn . S.fromAscList @a @s . map (fromMaybe (error "TODO") . fromDynamic),+      storageRnf = maybe () rnf . fromDynamic @s     } -insertDyn :: Int -> Dynamic -> DynamicStorage -> DynamicStorage-insertDyn i c s = s {storageDyn = insertDyn' s i c (storageDyn s)}--removeDyn :: Int -> DynamicStorage -> (Maybe Dynamic, DynamicStorage)-removeDyn i s = let (a, s') = removeDyn' s i (storageDyn s) in (a, s {storageDyn = s'})+singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage+singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} -removeAny :: Int -> DynamicStorage -> (Maybe DynamicStorage, DynamicStorage)-removeAny i s = let (a, s') = removeAny' s i (storageDyn s) in (a, s {storageDyn = s'})+fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage+fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns} -entitiesDyn :: DynamicStorage -> [Int]-entitiesDyn s = entitiesDyn' s (storageDyn s)+toAscListDyn :: DynamicStorage -> [Dynamic]+toAscListDyn = toAscListDyn' <*> storageDyn

@@ -1,18 +1,23 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  module Main (main) where  import Aztecs+import Aztecs.ECS.Component (ComponentID (ComponentID)) import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S import qualified Aztecs.ECS.World as W import Aztecs.Hierarchy (Children (..), Parent (..)) import qualified Aztecs.Hierarchy as Hierarchy-import Control.Arrow (returnA, (&&&))+import Control.Arrow (Arrow (..), returnA, (&&&)) import Control.DeepSeq import qualified Data.Set as Set import GHC.Generics@@ -34,36 +39,69 @@ main :: IO () main = hspec $ do   describe "Aztecs.ECS.Query.all" $ do-    it "queries a single component" $ property prop_queryOneComponent-    it "queries two components" $ property prop_queryTwoComponents-    it "queries three components" $ property prop_queryThreeComponents+    it "queries dynamic components" $ property prop_queryDyn+    it "queries a typed component" $ property prop_queryTypedComponent+    it "queries 2 typed components" $ property prop_queryTwoTypedComponents+    it "queries 3 typed components" $ property prop_queryThreeTypedComponents   describe "Aztecs.ECS.Hierarchy.update" $ do     it "adds Parent components to children" $ property prop_addParents     it "removes Parent components from removed children" $ property prop_removeParents   describe "Aztecs.ECS.Schedule" $ do-    it "increments components" prop_quit+    it "queries entities" $ property prop_scheduleQueryEntity+    it "updates components" prop_scheduleUpdate -prop_queryOneComponent :: [X] -> Expectation-prop_queryOneComponent xs =+-- | Query all components from a list of `ComponentID`s.+queryComponentIds ::+  forall q a.+  (ArrowDynamicQueryReader q, Component a) =>+  [ComponentID] ->+  q () (EntityID, [a])+queryComponentIds =+  let go cId qAcc = proc () -> do+        x' <- Q.fetchDyn @_ @a cId -< ()+        (e, xs) <- qAcc -< ()+        returnA -< (e, x' : xs)+   in foldr go (Q.entity &&& arr (const []))++prop_queryDyn :: [[X]] -> Expectation+prop_queryDyn xs =+  let spawn xs' (acc, wAcc) =+        let spawn' x (bAcc, cAcc, idAcc) =+              ( dynBundle (ComponentID idAcc) x <> bAcc,+                (x, ComponentID idAcc) : cAcc,+                idAcc + 1+              )+            (b, cs, _) = foldr spawn' (mempty, [], 0) xs'+            (e, wAcc') = W.spawn b wAcc+         in ((e, cs) : acc, wAcc')+      (es, w) = foldr spawn ([], W.empty) xs+      go (e, cs) =+        let q = queryComponentIds $ map snd cs+            (res, _) = Q.all () q $ W.entities w+         in res `shouldContain` [(e, map fst cs)]+   in mapM_ go es++prop_queryTypedComponent :: [X] -> Expectation+prop_queryTypedComponent xs =   let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs-      (res, _) = Q.all Q.fetch $ W.entities w+      (res, _) = Q.all () Q.fetch $ W.entities w    in res `shouldMatchList` xs -prop_queryTwoComponents :: [(X, Y)] -> Expectation-prop_queryTwoComponents xys =+prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation+prop_queryTwoTypedComponents xys =   let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys-      (res, _) = Q.all (Q.fetch &&& Q.fetch) $ W.entities w+      (res, _) = Q.all () (Q.fetch &&& Q.fetch) $ W.entities w    in res `shouldMatchList` xys -prop_queryThreeComponents :: [(X, Y, Z)] -> Expectation-prop_queryThreeComponents xyzs =+prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation+prop_queryThreeTypedComponents xyzs =   let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs       q = do         x <- Q.fetch         y <- Q.fetch         z <- Q.fetch         pure (x, y, z)-      (res, _) = Q.all q $ W.entities w+      (res, _) = Q.all () q $ W.entities w    in res `shouldMatchList` xyzs  prop_addParents :: Expectation@@ -71,7 +109,7 @@   let (_, w) = W.spawnEmpty W.empty       (e, w') = W.spawn (bundle . Children $ Set.singleton e) w   (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()-  let (res, _) = Q.all Q.fetch $ W.entities w''+  let (res, _) = Q.all () Q.fetch $ W.entities w''   res `shouldMatchList` [Parent e]  prop_removeParents :: Expectation@@ -81,18 +119,25 @@   (_, _, w'') <- runSchedule (system Hierarchy.update) w' ()   let w''' = W.insert e (Children Set.empty) w''   (_, _, w'''') <- runSchedule (system Hierarchy.update) w''' ()-  let (res, _) = Q.all (Q.fetch @_ @Parent) $ W.entities w''''+  let (res, _) = Q.all () (Q.fetch @_ @Parent) $ W.entities w''''   res `shouldMatchList` [] -prop_quit :: Expectation-prop_quit = do+prop_scheduleQueryEntity :: [X] -> Expectation+prop_scheduleQueryEntity xs = do+  let go x (eAcc, wAcc) = let (e, wAcc') = W.spawn (bundle x) wAcc in (e : eAcc, wAcc')+      (es, w) = foldr go ([], W.empty) xs+  (res, _, _) <- runSchedule (reader $ S.all Q.entity) w ()+  res `shouldMatchList` es++prop_scheduleUpdate :: Expectation+prop_scheduleUpdate = do   let (_, w) = W.spawn (bundle $ X 1) W.empty-  (_, _, w') <- runSchedule quit w ()-  (x, _, _) <- runSchedule quit w' ()+  (_, _, w') <- runSchedule update w ()+  (x, _, _) <- runSchedule update w' ()   x `shouldBe` True -quit :: Schedule IO () Bool-quit = proc () -> do+update :: Schedule IO () Bool+update = proc () -> do   rec lastShouldQuit <- delay False -< shouldQuit       x <-         system $