aztecs 0.4.0.1 → 0.5.0.0

raw patch · 14 files changed

+325/−319 lines, 14 filesdep +parallel-iodep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: parallel-io

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• aztecs.cabal +9/−8
• examples/ECS.hs +5/−4
• src/Data/Aztecs.hs +9/−5
• src/Data/Aztecs/Access.hs +9/−8
• src/Data/Aztecs/Component.hs +1/−1
• src/Data/Aztecs/Query.hs +14/−13
• src/Data/Aztecs/Schedule.hs +70/−0
• src/Data/Aztecs/Storage.hs +2/−2
• src/Data/Aztecs/System.hs +110/−204
• src/Data/Aztecs/View.hs +12/−7
• src/Data/Aztecs/World.hs +27/−21
• src/Data/Aztecs/World/Archetype.hs +30/−26
• src/Data/Aztecs/World/Archetypes.hs +21/−15
• src/Data/Aztecs/World/Components.hs +6/−5

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          aztecs-version:       0.4.0.1+version:       0.5.0.0 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me@@ -26,6 +26,7 @@         Data.Aztecs.Component         Data.Aztecs.Entity         Data.Aztecs.Query+        Data.Aztecs.Schedule         Data.Aztecs.Storage         Data.Aztecs.System         Data.Aztecs.View@@ -33,14 +34,14 @@         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+        base >=4.6 && <5,+        containers >=0.6,+        mtl >=2,+        parallel-io >=0.3.5  executable ecs     main-is:          ECS.hs@@ -48,7 +49,7 @@     default-language: Haskell2010     ghc-options:      -Wall     build-depends:-        base >=4 && <5,+        base >=4.6 && <5,         aztecs  test-suite aztecs-test@@ -58,7 +59,7 @@     default-language: Haskell2010     ghc-options:      -Wall     build-depends:-        base >=4 && <5,+        base >=4.6 && <5,         aztecs,         hspec >=2,         QuickCheck >=2@@ -70,6 +71,6 @@     default-language: Haskell2010     ghc-options:      -Wall     build-depends:-        base >=4 && <5,+        base >=4.6 && <5,         aztecs,         criterion >=1

@@ -1,6 +1,4 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}  module Main where @@ -29,7 +27,10 @@         Position p <- Q.fetch -< ()         Q.set -< Position $ p + v     )-    >>> S.run print+    >>> S.task print +app :: Schedule IO () ()+app = schedule setup >>> forever (schedule move)+ main :: IO ()-main = runSystem_ $ setup >>> S.forever move+main = runSchedule_ $ app

@@ -56,14 +56,17 @@     bundle,     Component (..),     EntityID,-    System,-    SystemT (..),     Query,     QueryFilter,     with,     without,-    runSystem,-    runSystem_,+    System,+    SystemT,+    Schedule,+    schedule,+    forever,+    runSchedule,+    runSchedule_,     World,   ) where@@ -72,6 +75,7 @@ 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.Schedule (Schedule, forever, runSchedule, runSchedule_, schedule)+import Data.Aztecs.System (System, SystemT) import Data.Aztecs.World (World) import Data.Aztecs.World.Archetype (Bundle, bundle)

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}@@ -16,7 +17,7 @@ where  import Control.Monad.IO.Class (MonadIO)-import Control.Monad.State (MonadState (..), StateT (..))+import Control.Monad.State.Strict (MonadState (..), StateT (..)) import Data.Aztecs.Component (Component (..)) import Data.Aztecs.Entity (EntityID (..)) import Data.Aztecs.World (World (..))@@ -39,8 +40,8 @@   Bundle ->   Access m EntityID spawn c = Access $ do-  w <- get-  let (e, w') = W.spawn c w+  !w <- get+  let !(e, w') = W.spawn c w   put w'   return e @@ -52,17 +53,17 @@ -- | 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+  !w <- get+  let !w' = W.insert e c w   put w'  lookup :: (Monad m, Component a) => EntityID -> Access m (Maybe a) lookup e = Access $ do-  w <- get+  !w <- get   return $ W.lookup e w  despawn :: (Monad m) => EntityID -> Access m () despawn e = Access $ do-  w <- get-  let (_, w') = W.despawn e w+  !w <- get+  let !(_, w') = W.despawn e w   put w'

@@ -4,7 +4,7 @@ module Data.Aztecs.Component (Component (..), ComponentID (..)) where  import Data.Aztecs.Storage (Storage)-import Data.IntMap (IntMap)+import Data.IntMap.Strict (IntMap) import Data.Kind (Type) import Data.Typeable (Typeable) 

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}@@ -11,7 +12,7 @@     fetch,     fetchMaybe,     set,-    run,+    task,     all,      -- * Filters@@ -45,7 +46,7 @@ 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 qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set import Prelude hiding (all, any, id, lookup, map, mapM, reads, (.))@@ -113,8 +114,8 @@    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 ->+task :: (Monad m) => (i -> m o) -> Query m i o+task f = Query $ \cs ->   ( mempty,     cs,     DynamicQuery@@ -129,7 +130,7 @@ -- >>> import Data.Aztecs -- >>> import qualified Data.Aztecs.World as W -- >>>--- >>> data X = X Int deriving (Show)+-- >>> newtype X = X Int deriving (Show) -- >>> instance Component X -- >>> -- >>> let (_, w) = W.spawn (bundle $ X 0) W.empty@@ -146,8 +147,8 @@   return (concat as, w {components = cs'})  data ReadsWrites = ReadsWrites-  { reads :: Set ComponentID,-    writes :: Set ComponentID+  { reads :: !(Set ComponentID),+    writes :: !(Set ComponentID)   }   deriving (Show) @@ -189,8 +190,8 @@   let (cId, cs') = CS.insert @a cs in (mempty {filterWithout = Set.singleton cId}, cs')  data DynamicQueryFilter = DynamicQueryFilter-  { filterWith :: Set ComponentID,-    filterWithout :: Set ComponentID+  { filterWith :: !(Set ComponentID),+    filterWithout :: !(Set ComponentID)   }  instance Semigroup DynamicQueryFilter where@@ -202,8 +203,8 @@  -- | 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)+  { dynQueryAll :: !([i] -> [EntityID] -> Archetype -> m ([o], Archetype)),+    dynQueryLookup :: !(i -> EntityID -> Archetype -> m (Maybe o, Archetype))   }  instance (Functor m) => Functor (DynamicQuery m i) where@@ -287,7 +288,7 @@ 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),+    { dynQueryAll = \_ _ arch -> let !as = A.all cId arch in pure (fmap snd as, arch),       dynQueryLookup = \_ eId arch -> pure $ (A.lookupComponent eId cId arch, arch)     } @@ -311,7 +312,7 @@   DynamicQuery m a a setDyn cId =   DynamicQuery-    { dynQueryAll = \is _ arch -> pure (is, A.withAscList cId is arch),+    { dynQueryAll = \is _ arch -> let !arch' = A.withAscList cId is arch in pure (is, arch'),       dynQueryLookup =         \i eId arch -> pure (A.lookupComponent eId cId arch, A.insertComponent eId cId i arch)     }

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

@@ -5,8 +5,8 @@ module Data.Aztecs.Storage (Storage (..)) where  import Data.Data (Typeable)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap  -- | Component storage, containing zero or many components of the same type. class (Typeable (s a), Typeable a) => Storage s a where

@@ -1,18 +1,14 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}  module Data.Aztecs.System   ( -- * Systems     System,     SystemT (..),-    forever,-    run,     queue,+    task,      -- ** Queries @@ -24,122 +20,91 @@     -- *** Writing     map,     map_,-    mapSingle,     filterMap,--    -- ** Running-    runSystem,-    runSystem_,-    runSystemWithWorld,+    mapSingle, -    -- * Dynamic systems-    DynamicSystem,+    -- * Dynamic SystemTs     DynamicSystemT (..),+    queueDyn,+    raceDyn,++    -- ** Queries++    -- *** Reading     allDyn,+    filterDyn,     singleDyn,++    -- *** Writing     mapDyn,-    mapDyn_,-    queueDyn,-    runDyn,+    filterMapDyn,   ) where -import Control.Arrow (Arrow (..), ArrowLoop (..))+import Control.Arrow (Arrow (..)) import Control.Category (Category (..))-import Control.Concurrent (forkIO)-import Data.Aztecs.Access (Access, runAccess)+import Control.Concurrent.ParallelIO.Global+import Data.Aztecs.Access (Access (..))+import Data.Aztecs.Component (ComponentID) import Data.Aztecs.Query (DynamicQuery, DynamicQueryFilter (..), Query (..), QueryFilter (..), ReadsWrites) import qualified Data.Aztecs.Query as Q+import Data.Aztecs.View (View) import qualified Data.Aztecs.View as V import Data.Aztecs.World (World (..))-import qualified Data.Aztecs.World 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 Data.Aztecs.World.Archetypes (Node (..))+import Data.Aztecs.World.Components (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, (.))+import Prelude hiding (all, filter, map, (.))+import qualified Prelude hiding (filter, map) -type System = SystemT IO+type System i o = SystemT IO i o --- | 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)-  }+newtype SystemT m i o = SystemT {runSystemT :: Components -> (DynamicSystemT m i o, ReadsWrites, Components)}   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+instance (Monad m) => Category (SystemT m) where+  id = SystemT $ \cs -> (DynamicSystemT $ \_ -> \i -> return (i, mempty, pure ()), mempty, cs)+  SystemT f . SystemT g = SystemT $ \cs ->+    let (f', rwsF, cs') = f cs+        (g', rwsG, cs'') = g cs'+     in (f' . g', rwsF <> rwsG, cs'') -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'''+instance Arrow (SystemT IO) where+  arr f = SystemT $ \cs -> (DynamicSystemT $ \_ -> \i -> return (f i, mempty, pure ()), mempty, cs)+  first (SystemT f) = SystemT $ \cs ->+    let (f', rwsF, cs') = f cs+     in (first f', rwsF, cs')+  a &&& b = SystemT $ \cs ->+    let (dynA, rwsA, cs') = runSystemT a cs+        (dynB, rwsB, cs'') = runSystemT b cs'+     in ( if Q.disjoint rwsA rwsB+            then dynA &&& dynB+            else raceDyn dynA dynB,+          rwsA <> rwsB,+          cs''+        )  -- | Query all matching entities.-all :: Query IO () a -> System () [a]+all :: (Monad m) => Query m i a -> SystemT m i [a] all q = SystemT $ \cs ->-  let (rws, cs', dynQ) = runQuery q cs-   in (cs', rws, allDyn (Q.reads rws <> Q.writes rws) dynQ)+  let !(rws, cs', dynQ) = runQuery q cs+   in (allDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs')  -- | Query all matching entities with a `QueryFilter`.-filter :: Query IO () a -> QueryFilter -> System () [a]+filter :: (Monad m) => Query m () a -> QueryFilter -> SystemT m () [a] filter q qf = SystemT $ \cs ->-  let (rws, cs', dynQ) = runQuery q cs-      (dynQf, cs'') = runQueryFilter qf cs'+  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')+   in (filterDyn (Q.reads rws <> Q.writes rws) dynQ qf', rws, cs'')  -- | Query a single matching entity. -- If there are zero or multiple matching entities, an error will be thrown.-single :: Query IO () a -> System () a+single :: (Monad m) => Query m () a -> SystemT m () a single q =   fmap     ( \as -> case as of@@ -148,28 +113,28 @@     )     (all q) --- | Map all matching entities, storing the updated entities.-map :: Query IO i a -> System i [a]+-- | Query all matching entities.+map :: (Monad m) => Query m i a -> SystemT m i [a] map q = SystemT $ \cs ->-  let (rws, cs', dynS) = runQuery q cs in (cs', rws, mapDyn (Q.reads rws <> Q.writes rws) dynS)+  let !(rws, cs', dynQ) = runQuery q cs+   in (mapDyn (Q.reads rws <> Q.writes rws) dynQ, rws, cs') --- | Map all matching entities and ignore the output, storing the updated entities.-map_ :: Query IO i a -> System i ()+map_ :: (Monad m) => Query m i o -> SystemT m i () map_ q = const () <$> map q  -- | Map all matching entities with a `QueryFilter`, storing the updated entities.-filterMap :: Query IO i a -> QueryFilter -> System i [a]+filterMap :: (Monad m) => Query m i a -> QueryFilter -> SystemT m i [a] filterMap q qf = SystemT $ \cs ->-  let (rws, cs', dynQ) = runQuery q cs-      (dynQf, cs'') = runQueryFilter qf cs'+  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')+   in (filterMapDyn (Q.reads rws <> Q.writes rws) dynQ f', rws, cs'')  -- | Map a single matching entity, storing the updated components. -- If there are zero or multiple matching entities, an error will be thrown.-mapSingle :: Query IO i a -> System i a+mapSingle :: (Monad m) => Query m i a -> SystemT m i a mapSingle q =   fmap     ( \as -> case as of@@ -178,98 +143,46 @@     )     (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)+queue f = SystemT $ \cs -> (queueDyn f, mempty, cs) -type DynamicSystem = DynamicSystemT IO+task :: (Monad m) => (i -> m o) -> SystemT m i o+task f = SystemT $ \cs ->+  ( DynamicSystemT $ \_ -> \i -> do+      o <- f i+      return (o, mempty, pure ()),+    mempty,+    cs+  ) --- | Dynamic system that can access and alter a `World`.-newtype DynamicSystemT m i o = DynamicSystemT-  {runSystemDyn :: i -> TVar World -> m (o, Access m ())}+newtype DynamicSystemT m i o = DynamicSystemT {runSystemTDyn :: World -> (i -> m (o, View, 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+instance (Monad m) => Category (DynamicSystemT m) where+  id = DynamicSystemT $ \_ -> \i -> return (i, mempty, pure ())+  DynamicSystemT f . DynamicSystemT g = DynamicSystemT $ \w -> \i -> do+    (b, gView, gAccess) <- g w i+    (a, fView, fAccess) <- f w b+    return (a, gView <> fView, gAccess >> fAccess) --- | 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+instance (Monad m) => Arrow (DynamicSystemT m) where+  arr f = DynamicSystemT $ \_ -> \i -> return (f i, mempty, pure ())+  first (DynamicSystemT f) = DynamicSystemT $ \w -> \(i, x) -> do+    (a, v, access) <- f w i+    return ((a, x), v, access)  -- | Query all matching entities.-allDyn :: 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)+allDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> DynamicSystemT m i [o]+allDyn cIds q = DynamicSystemT $ \w ->+  let !v = V.view cIds $ archetypes w+   in \i -> fmap (\(a, _) -> (a, mempty, pure ())) (V.allDyn i q v) -filterDyn :: 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 ())+filterDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> (Node -> Bool) -> DynamicSystemT m i [o]+filterDyn cIds q f = DynamicSystemT $ \w ->+  let !v = V.filterView cIds f $ archetypes w+   in \i -> fmap (\(a, _) -> (a, mempty, pure ())) (V.allDyn i q v) --- | 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 :: (Monad m) => Set ComponentID -> DynamicQuery m () a -> DynamicSystemT m () a singleDyn cIds q =   fmap     ( \as -> case as of@@ -279,30 +192,23 @@     (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 ())+mapDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> DynamicSystemT m i [o]+mapDyn cIds q = DynamicSystemT $ \w ->+  let !v = V.view cIds $ archetypes w+   in \i -> fmap (\(a, v') -> (a, v', pure ())) (V.allDyn i q v) --- | 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+filterMapDyn :: (Monad m) => Set ComponentID -> DynamicQuery m i o -> (Node -> Bool) -> DynamicSystemT m i [o]+filterMapDyn cIds q f = DynamicSystemT $ \w ->+  let !v = V.filterView cIds f $ archetypes w+   in \i -> fmap (\(a, v') -> (a, v', pure ())) (V.allDyn i q v) --- | 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)+queueDyn :: (Monad m) => (i -> Access m ()) -> DynamicSystemT m i ()+queueDyn f = DynamicSystemT $ \_ -> \i -> return ((), mempty, f i) --- | Run a monadic task.-runDyn :: (Monad m) => (i -> m o) -> DynamicSystemT m i o-runDyn f = DynamicSystemT $ \i _ -> fmap (,pure ()) (f i)+raceDyn :: DynamicSystemT IO i a -> DynamicSystemT IO i b -> DynamicSystemT IO i (a, b)+raceDyn (DynamicSystemT f) (DynamicSystemT g) = DynamicSystemT $ \w -> \i -> do+  results <- parallel [fmap (\a -> (Just a, Nothing)) $ f w i, fmap (\b -> (Nothing, Just b)) $ g w i]+  ((a, v, fAccess), (b, v', gAccess)) <- case results of+    [(Just a, _), (_, Just b)] -> return (a, b)+    _ -> error "joinDyn: exception"+  return ((a, b), v <> v', fAccess >> gAccess)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}@@ -20,11 +21,15 @@ 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.Foldable (foldlM)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Set (Set) +#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ -- | View into a `World`, containing a subset of archetypes. newtype View = View {viewArchetypes :: Map ArchetypeID Node}   deriving (Show, Semigroup, Monoid)@@ -46,8 +51,8 @@ unview v w =   w     { W.archetypes =-        foldr-          (\(aId, n) as -> as {AS.nodes = Map.insert aId n (AS.nodes as)})+        foldl'+          (\as (aId, n) -> as {AS.nodes = Map.insert aId n (AS.nodes as)})           (W.archetypes w)           (Map.toList $ viewArchetypes v)     }@@ -56,8 +61,8 @@ 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+    foldlM+      ( \(acc, archAcc) (aId, n) -> do           (as, arch') <- dynQueryAll q (repeat i) (A.entities (nodeArchetype n)) (nodeArchetype n)           return (as ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc)       )

@@ -1,8 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE BangPatterns #-}  module Data.Aztecs.World   ( World (..),@@ -38,12 +40,16 @@ import Data.Typeable (Proxy (..), Typeable, typeOf) import Prelude hiding (lookup) +#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ -- | World of entities and their components. data World = World-  { archetypes :: Archetypes,-    components :: Components,-    entities :: Map EntityID ArchetypeID,-    nextEntityId :: EntityID+  { archetypes :: !Archetypes,+    components :: !Components,+    entities :: !(Map EntityID ArchetypeID),+    nextEntityId :: !EntityID   }   deriving (Show) @@ -115,11 +121,11 @@   World ->   (EntityID, World) spawnWithId cId c w =-  let (e, w') = spawnEmpty 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) =+          let !(aId, arches) =                 AS.insertArchetype                   (Set.singleton cId)                   ( Node@@ -142,7 +148,7 @@   World ->   (EntityID, World) spawnWithArchetypeId c cId aId w =-  let (e, w') = spawnEmpty w+  let !(e, w') = spawnEmpty w    in (e, spawnWithArchetypeId' e aId cId c w')  spawnWithArchetypeId' ::@@ -164,7 +170,7 @@ -- | 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)+  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`.@@ -176,9 +182,9 @@         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 =+            let !(cs, arch') = A.remove e (nodeArchetype node)+                !w' = w {archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}}+                f archAcc (itemCId, dyn) =                   archAcc                     { A.storages =                         Map.adjust@@ -195,7 +201,7 @@                                   nextNode                                     { nodeArchetype =                                         A.insertComponent e cId c $-                                          foldr+                                          foldl'                                             f                                             (nodeArchetype nextNode)                                             (Map.toList cs)@@ -207,15 +213,15 @@                     entities = Map.insert e nextAId (entities w')                   }           Nothing ->-            let (s, arch') = A.removeStorages e (nodeArchetype node)-                n =+            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)+                !(nextAId, arches) = AS.insertArchetype (Set.insert cId (nodeComponentIds node)) n (archetypes w)              in w                   { archetypes =                       arches@@ -249,21 +255,21 @@  lookup :: forall a. (Component a) => EntityID -> World -> Maybe a lookup e w = do-  cId <- CS.lookup @a (components w)-  aId <- Map.lookup e (entities w)-  node <- AS.lookupNode aId (archetypes w)+  !cId <- CS.lookup @a (components w)+  !aId <- Map.lookup e (entities w)+  !node <- AS.lookupNode aId (archetypes w)   A.lookupComponent e cId (nodeArchetype node)  -- | Despawn an entity, returning its components. despawn :: EntityID -> World -> (Map ComponentID Dynamic, World) despawn e w =   let res = do-        aId <- Map.lookup e (entities w)-        node <- AS.lookupNode aId (archetypes w)+        !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)+          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)},

@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -39,19 +41,23 @@ 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.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import Prelude hiding (all, lookup) +#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ data AnyStorage = AnyStorage-  { storageDyn :: Dynamic,-    insertDyn :: Int -> Dynamic -> Dynamic -> Dynamic,-    removeDyn :: Int -> Dynamic -> (Maybe Dynamic, Dynamic),-    removeAny :: Int -> Dynamic -> (Maybe AnyStorage, Dynamic),-    entitiesDyn :: Dynamic -> [Int]+  { 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@@ -63,14 +69,14 @@     { storageDyn = toDyn s,       insertDyn = \i cDyn sDyn ->         fromMaybe sDyn $ do-          s' <- fromDynamic @(s a) sDyn-          c <- fromDynamic cDyn+          !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)+        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)+        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'@@ -90,7 +96,7 @@  insertComponent :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype insertComponent e cId c arch =-  let storage = case lookupStorage cId arch of+  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)}@@ -120,32 +126,30 @@  insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype insertAscList cId as arch =-  arch-    { storages =+  let !storages' =         Map.insert           cId           (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as))           (storages arch)-    }+   in arch {storages = storages'}  withAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype withAscList cId as arch =-  arch-    { storages =+  let !storages' =         Map.adjust           ( \s ->               (anyStorage $ S.fromAscList @(StorageT a) (zip (entitiesDyn s (storageDyn s)) as))           )           cId           (storages arch)-    }+   in arch {storages = storages'}  remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype) remove e arch =-  foldr-    ( \(cId, s) (dynAcc, archAcc) ->-        let (dynA, dynS) = removeDyn s (unEntityId e) (storageDyn s)-            dynAcc' = case dynA of+  foldl'+    ( \(dynAcc, archAcc) (cId, s) ->+        let !(dynA, dynS) = removeDyn s (unEntityId e) (storageDyn s)+            !dynAcc' = case dynA of               Just d -> Map.insert cId d dynAcc               Nothing -> dynAcc          in ( dynAcc',@@ -157,8 +161,8 @@  removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype) removeStorages e arch =-  foldr-    ( \(cId, s) (dynAcc, archAcc) ->+  foldl'+    ( \(dynAcc, archAcc) (cId, s) ->         let (dynA, dynS) = removeAny s (unEntityId e) (storageDyn s)             dynAcc' = case dynA of               Just d -> Map.insert cId d dynAcc@@ -198,6 +202,6 @@  runBundle :: Bundle -> Components -> EntityID -> Archetype -> (Components, Archetype) runBundle b cs eId arch =-  let (_, cs', d) = unBundle b cs-      arch' = runDynamicBundle d eId arch+  let !(_, cs', d) = unBundle b cs+      !arch' = runDynamicBundle d eId arch    in (cs', arch')

@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -22,13 +24,17 @@  import Data.Aztecs.Component (ComponentID) import Data.Aztecs.World.Archetype hiding (empty)-import Data.Map (Map)-import qualified Data.Map as Map+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Prelude hiding (all, lookup, map) +#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ -- | `Archetype` ID. newtype ArchetypeID = ArchetypeID {unArchetypeId :: Int}   deriving (Eq, Ord, Show)@@ -36,26 +42,26 @@ -- | Node in `Archetypes`. data Node = Node   { -- | Unique set of `ComponentID`s of this `Node`.-    nodeComponentIds :: Set ComponentID,+    nodeComponentIds :: !(Set ComponentID),     -- | `Archetype` of this `Node`.-    nodeArchetype :: Archetype,+    nodeArchetype :: !Archetype,     -- | Edges to other `Archetype`s by adding a `ComponentID`.-    nodeAdd :: Map ComponentID ArchetypeID,+    nodeAdd :: !(Map ComponentID ArchetypeID),     -- | Edges to other `Archetype`s by removing a `ComponentID`.-    nodeRemove :: Map ComponentID ArchetypeID+    nodeRemove :: !(Map ComponentID ArchetypeID)   }   deriving (Show)  -- | `Archetype` graph. data Archetypes = Archetypes   { -- | Archetype nodes in the graph.-    nodes :: Map ArchetypeID Node,+    nodes :: !(Map ArchetypeID Node),     -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.-    archetypeIds :: Map (Set ComponentID) ArchetypeID,+    archetypeIds :: !(Map (Set ComponentID) ArchetypeID),     -- | Next unique `ArchetypeID`.-    nextArchetypeId :: ArchetypeID,+    nextArchetypeId :: !ArchetypeID,     -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.-    componentIds :: Map ComponentID (Set ArchetypeID)+    componentIds :: !(Map ComponentID (Set ArchetypeID))   }   deriving (Show) @@ -88,7 +94,7 @@ -- | 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'+  (aId : aIds') -> foldl' Set.intersection aId aIds'   [] -> Set.empty  -- | Lookup `Archetype`s containing a set of `ComponentID`s.@@ -101,10 +107,10 @@ -- | 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)+  foldl'+    ( \(acc, archAcc) aId ->+        let !node = nodes archAcc Map.! aId+            !(a, arch') = f (nodeArchetype node)          in (a : acc, archAcc {nodes = Map.insert aId (node {nodeArchetype = arch'}) (nodes archAcc)})     )     ([], arches)

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -13,15 +14,15 @@ where  import Data.Aztecs.Component (Component, ComponentID (..))-import Data.Map (Map)-import qualified Data.Map as Map+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Typeable (Proxy (..), TypeRep, Typeable, typeOf) import Prelude hiding (lookup)  -- | Component ID map. data Components = Components-  { componentIds :: Map TypeRep ComponentID,-    nextComponentId :: ComponentID+  { componentIds :: !(Map TypeRep ComponentID),+    nextComponentId :: !ComponentID   }   deriving (Show) @@ -46,7 +47,7 @@ -- | Insert a component ID by type. insert' :: forall c. (Component c) => Components -> (ComponentID, Components) insert' cs =-  let cId = nextComponentId cs+  let !cId = nextComponentId cs    in ( cId,         cs           { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs),