aztecs 0.2.0.0 → 0.3.0.0

raw patch · 19 files changed

+1352/−443 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• aztecs.cabal +75/−60
• bench/Iter.hs +2/−5
• examples/ECS.hs +16/−16
• src/Data/Aztecs.hs +10/−2
• src/Data/Aztecs/Access.hs +64/−4
• src/Data/Aztecs/Archetype.hs +0/−104
• src/Data/Aztecs/Component.hs +19/−0
• src/Data/Aztecs/Core.hs +0/−60
• src/Data/Aztecs/Entity.hs +54/−1
• src/Data/Aztecs/Query.hs +174/−111
• src/Data/Aztecs/Scheduler.hs +231/−0
• src/Data/Aztecs/Storage.hs +13/−1
• src/Data/Aztecs/System.hs +137/−0
• src/Data/Aztecs/View.hs +80/−0
• src/Data/Aztecs/World.hs +144/−78
• src/Data/Aztecs/World/Archetype.hs +138/−0
• src/Data/Aztecs/World/Archetypes.hs +114/−0
• src/Data/Aztecs/World/Components.hs +55/−0
• test/Main.hs +26/−1

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

@@ -3,7 +3,6 @@ 
 import Criterion.Main
 import Data.Aztecs
-import Data.Aztecs.Entity
 import qualified Data.Aztecs.Query as Q
 import Data.Aztecs.World (World)
 import qualified Data.Aztecs.World as W
@@ -17,13 +16,11 @@ instance Component Velocity
 
 run :: World -> World
-run w =
-  let !(_, w') = Q.mapWith Q.fetch Q.fetch (\(Velocity v :& Position x) -> Position (x + v)) w
-   in w'
+run w = let !(_, w') = Q.mapWorld (\(Velocity v :& Position x) -> Position (x + v)) w in w'
 
 main :: IO ()
 main = do
-  let w =
+  let !w =
         foldr
           ( \_ wAcc ->
               let (e, wAcc') = W.spawn (Position 0) wAcc

@@ -1,13 +1,12 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Main where
 
-import Control.Monad.IO.Class (MonadIO (..))
+import Control.Arrow ((>>>))
 import Data.Aztecs
 import qualified Data.Aztecs.Access as A
-import qualified Data.Aztecs.Query as Q
-import qualified Data.Aztecs.World as W
+import qualified Data.Aztecs.System as S
 
 newtype Position = Position Int deriving (Show)
 
@@ -17,17 +16,18 @@ 
 instance Component Velocity
 
-app :: Access IO ()
-app = do
-  -- Spawn an entity with position and velocity components
-  e <- A.spawn (Position 0)
-  A.insert e (Velocity 1)
+data Setup
 
-  -- Query for and update all matching entities
-  q <- Q.map (\(Velocity v :& Position x) -> Position (x + v))
-  liftIO $ print q
+instance System IO Setup where
+  task = S.queue (A.spawn_ (Position 0 :& Velocity 1))
 
+data Movement
+
+instance System IO Movement where
+  task = S.map (\(Position x :& Velocity v) -> Position (x + v)) >>> S.run print
+
+app :: Scheduler IO
+app = schedule @_ @Startup @Setup [] <> schedule @_ @Update @Movement []
+
 main :: IO ()
-main = do
-  _ <- runAccess app W.empty
-  return ()
+main = run app

@@ -5,9 +5,17 @@     EntityID,
     Entity,
     (:&) (..),
+    System (..),
+    Scheduler,
+    Startup,
+    Update,
+    run,
+    schedule,
   )
 where
 
 import Data.Aztecs.Access (Access, runAccess)
-import Data.Aztecs.Core (Component (..), EntityID)
-import Data.Aztecs.Entity (Entity, (:&) (..))
+import Data.Aztecs.Component (Component (..))
+import Data.Aztecs.Entity (Entity, EntityID, (:&) (..))
+import Data.Aztecs.Scheduler (Scheduler, Startup, Update, run, schedule)
+import Data.Aztecs.System (System (..))

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

@@ -1,104 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Data.Aztecs.Archetype where
-
-import Data.Aztecs.Core (Component (..), ComponentID, EntityID (..))
-import qualified Data.Aztecs.Storage as S
-import Data.Bifunctor (Bifunctor (..))
-import Data.Dynamic (Dynamic, fromDynamic, toDyn)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Prelude hiding (all, lookup)
-
-data AnyStorage = AnyStorage
-  { storageDyn :: Dynamic,
-    insertDyn :: Int -> Dynamic -> Dynamic -> Dynamic,
-    removeDyn :: Int -> Dynamic -> (Maybe Dynamic, Dynamic),
-    removeAny :: Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
-  }
-
-instance Show AnyStorage where
-  show s = "AnyStorage " ++ show (storageDyn s)
-
-anyStorage :: forall s a. (S.Storage s a) => s a -> AnyStorage
-anyStorage s =
-  AnyStorage
-    { storageDyn = toDyn s,
-      insertDyn = \i cDyn sDyn ->
-        fromMaybe sDyn $ do
-          s' <- fromDynamic @(s a) sDyn
-          c <- fromDynamic cDyn
-          return . toDyn $ S.insert i c s',
-      removeDyn = \i dyn -> case fromDynamic @(s a) dyn of
-        Just s' -> let (a, b) = S.remove i s' in (fmap toDyn a, toDyn b)
-        Nothing -> (Nothing, dyn),
-      removeAny = \i dyn -> case fromDynamic @(s a) dyn of
-        Just s' -> let (a, b) = S.remove i s' in (fmap (anyStorage . S.singleton @s i) a, toDyn b)
-        Nothing -> (Nothing, dyn)
-    }
-
-newtype Archetype = Archetype {storages :: Map ComponentID AnyStorage}
-  deriving (Show)
-
-empty :: Archetype
-empty = Archetype {storages = Map.empty}
-
-lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a a)
-lookupStorage cId w = do
-  dynS <- Map.lookup cId (storages w)
-  fromDynamic (storageDyn dynS)
-
-insert :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype
-insert e cId c arch =
-  let storage = case lookupStorage cId arch of
-        Just s -> S.insert (unEntityId e) c s
-        Nothing -> S.singleton @(StorageT a) @a (unEntityId e) c
-   in arch {storages = Map.insert cId (anyStorage storage) (storages arch)}
-
-all :: (Component a) => ComponentID -> Archetype -> [(EntityID, a)]
-all cId arch = fromMaybe [] $ do
-  s <- lookupStorage cId arch
-  return . map (first EntityID) $ S.all s
-
-lookup :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a
-lookup e cId w = lookupStorage cId w >>= S.lookup (unEntityId e)
-
-insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype
-insertAscList cId as arch = arch {storages = Map.insert cId (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as)) (storages arch)}
-
-remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
-remove e arch =
-  foldr
-    ( \(cId, s) (dynAcc, archAcc) ->
-        let (dynA, dynS) = removeDyn s (unEntityId e) (storageDyn s)
-            dynAcc' = case dynA of
-              Just d -> Map.insert cId d dynAcc
-              Nothing -> dynAcc
-         in ( dynAcc',
-              archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}
-            )
-    )
-    (Map.empty, arch)
-    (Map.toList $ storages arch)
-
-removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)
-removeStorages e arch =
-  foldr
-    ( \(cId, s) (dynAcc, archAcc) ->
-        let (dynA, dynS) = removeAny s (unEntityId e) (storageDyn s)
-            dynAcc' = case dynA of
-              Just d -> Map.insert cId d dynAcc
-              Nothing -> dynAcc
-         in ( dynAcc',
-              archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}
-            )
-    )
-    (Map.empty, arch)
-    (Map.toList $ storages arch)

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

@@ -1,60 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Data.Aztecs.Core
-  ( EntityID (..),
-    Component (..),
-    ComponentID (..),
-    Components (..),
-    emptyComponents,
-    insertComponentId,
-    lookupComponentId,
-  )
-where
-
-import Data.Aztecs.Storage (Storage)
-import Data.IntMap (IntMap)
-import Data.Kind (Type)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Typeable (Proxy (..), TypeRep, Typeable, typeOf)
-
-newtype EntityID = EntityID {unEntityId :: Int}
-  deriving (Eq, Ord, Show)
-
-newtype ComponentID = ComponentID {unComponentId :: Int}
-  deriving (Eq, Ord, Show)
-
-class (Typeable a, Storage (StorageT a) a) => Component a where
-  type StorageT a :: Type -> Type
-  type StorageT a = IntMap
-
-data Components = Components
-  { componentIds :: Map TypeRep ComponentID,
-    nextComponentId :: ComponentID
-  }
-  deriving (Show)
-
-emptyComponents :: Components
-emptyComponents =
-  Components
-    { componentIds = mempty,
-      nextComponentId = ComponentID 0
-    }
-
-lookupComponentId :: forall a. (Typeable a) => Components -> Maybe ComponentID
-lookupComponentId cs = Map.lookup (typeOf (Proxy @a)) (componentIds cs)
-
-insertComponentId :: forall c. (Component c) => Components -> (ComponentID, Components)
-insertComponentId cs =
-  let cId = nextComponentId cs
-   in ( cId,
-        cs
-          { componentIds = Map.insert (typeOf (Proxy @c)) cId (componentIds cs),
-            nextComponentId = ComponentID (unComponentId cId + 1)
-          }
-      )

@@ -12,7 +12,8 @@ {-# LANGUAGE UndecidableInstances #-}
 
 module Data.Aztecs.Entity
-  ( Entity (..),
+  ( EntityID (..),
+    Entity (..),
     EntityT,
     FromEntity (..),
     ToEntity (..),
@@ -23,15 +24,27 @@     Difference (..),
     SplitT,
     Split (..),
+    Has (..),
+    Sort (..),
+    ComponentIds(..),
     concat,
     (<&>),
     (:&) (..),
   )
 where
 
+import Data.Aztecs.Component (Component, ComponentID)
+import Data.Aztecs.World.Components (Components)
+import qualified Data.Aztecs.World.Components as CS
 import Data.Kind (Type)
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Prelude hiding (concat)
 
+-- | Entity ID.
+newtype EntityID = EntityID {unEntityId :: Int}
+  deriving (Eq, Ord, Show)
+
 data Entity (ts :: [Type]) where
   ENil :: Entity '[]
   ECons :: t -> Entity ts -> Entity (t ': ts)
@@ -51,6 +64,12 @@ instance (Show a, Show' (Entity as)) => Show' (Entity (a ': as)) where
   showRow (ECons x xs) = ", " ++ show x ++ showRow xs
 
+instance Eq (Entity '[]) where
+  ENil == ENil = True
+
+instance (Eq a, Eq (Entity as)) => Eq (Entity (a ': as)) where
+  ECons x xs == ECons y ys = x == y && xs == ys
+
 (<&>) :: Entity as -> a -> Entity (a : as)
 (<&>) es c = ECons c es
 
@@ -160,3 +179,37 @@ 
 instance (Difference' (ElemT a bs) (a ': as) bs) => Difference (a ': as) bs where
   difference = difference' @(ElemT a bs)
+
+class Has a e where
+  component :: e -> a
+  setComponent :: a -> e -> e
+
+instance {-# OVERLAPPING #-} Has a (Entity (a ': ts)) where
+  component (ECons x _) = x
+  setComponent x (ECons _ xs) = ECons x xs
+
+instance {-# OVERLAPPING #-} (Has a (Entity ts)) => Has a (Entity (b ': ts)) where
+  component (ECons _ xs) = component xs
+  setComponent x (ECons y xs) = ECons y (setComponent x xs)
+
+class Sort (a :: [Type]) (b :: [Type]) where
+  sort :: Entity a -> Entity b
+
+instance Sort as '[] where
+  sort _ = ENil
+
+instance (Has b (Entity as), Sort as bs) => Sort as (b ': bs) where
+  sort es = ECons (component es) (sort es)
+
+class ComponentIds (a :: [Type]) where
+  componentIds :: Components -> (Set ComponentID, Components)
+
+instance ComponentIds '[] where
+  componentIds cs = (Set.empty, cs)
+
+instance (Component a, ComponentIds as) => ComponentIds (a ': as) where
+  componentIds cs =
+    let (cId, cs') = CS.insert @a cs
+        (cIds, cs'') = componentIds @as cs'
+     in (Set.insert cId cIds, cs'')
+

@@ -3,41 +3,59 @@ {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Data.Aztecs.Query
   ( Query (..),
     (<?>),
     fetch,
+    fetchId,
     all,
-    allWorld,
+    queryAll,
+    queryAll',
     map,
-    mapWorld,
-    mapWith,
+    Queryable (..),
+    lookup,
+    lookupQuery,
+    alter,
+    QueryState (..),
+    IsEq,
+    Map (..),
   )
 where
 
-import Control.Monad.State (MonadState (..), gets)
-import Data.Aztecs.Access (Access (Access))
-import Data.Aztecs.Archetype (Archetype)
-import qualified Data.Aztecs.Archetype as A
-import Data.Aztecs.Core
-import Data.Aztecs.Entity (ConcatT, Difference, DifferenceT, Entity (..), EntityT, FromEntity (..), Intersect, IntersectT, ToEntity (..))
+import Data.Aztecs.Component
+import Data.Aztecs.Entity (ConcatT, Difference, DifferenceT, Entity (..), EntityID, EntityT, FromEntity (..), Intersect, IntersectT, Sort, ToEntity (..))
 import qualified Data.Aztecs.Entity as E
 import Data.Aztecs.World (World (..))
+import Data.Aztecs.World.Archetype (Archetype)
+import qualified Data.Aztecs.World.Archetype as A
+import Data.Aztecs.World.Archetypes (Archetypes, Node (nodeArchetype))
+import qualified Data.Aztecs.World.Archetypes as AS
+import Data.Aztecs.World.Components (Components)
+import qualified Data.Aztecs.World.Components as CS
 import Data.Data (Typeable)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Prelude hiding (all, map)
+import Prelude hiding (all, lookup, map)
 
+data QueryState a = QueryState
+  { queryStateComponentIds :: Set ComponentID,
+    queryStateAll :: Archetype -> ([Entity a], [Entity a] -> Archetype -> Archetype),
+    queryStateLookup :: EntityID -> Archetype -> Maybe (Entity a),
+    queryStateInsert :: EntityID -> Archetype -> Entity a -> Archetype
+  }
+
 -- | Query into the `World`.
-newtype Query a
-  = Query {runQuery' :: Components -> (Set ComponentID, Archetype -> ([Entity a], [Entity a] -> Archetype -> Archetype))}
+newtype Query a = Query {runQuery' :: Components -> QueryState a}
 
 (<?>) ::
   (E.Split a (ConcatT a b), E.SplitT a (ConcatT a b) ~ b) =>
@@ -45,124 +63,169 @@   Query b ->
   Query (ConcatT a b)
 (Query a) <?> (Query b) = Query $ \cs ->
-  let (aIds, a') = a cs
-      (bIds, b') = b cs
-   in ( aIds <> bIds,
-        \arch ->
-          let (a'', aF) = a' arch
-              (b'', bF) = b' arch
-           in ( uncurry E.concat <$> zip a'' b'',
-                \new newArch -> let (as, bs) = unzip $ fmap E.split new in bF bs $ aF as newArch
-              )
-      )
+  let aQS = a cs
+      bQS = b cs
+   in QueryState
+        { queryStateComponentIds = queryStateComponentIds aQS <> queryStateComponentIds bQS,
+          queryStateAll = \arch ->
+            let (a'', aF) = queryStateAll aQS arch
+                (b'', bF) = queryStateAll bQS arch
+             in ( uncurry E.concat <$> zip a'' b'',
+                  \new newArch -> let (as, bs) = unzip $ fmap E.split new in bF bs $ aF as newArch
+                ),
+          queryStateLookup = \eId arch -> do
+            aE <- queryStateLookup aQS eId arch
+            bE <- queryStateLookup bQS eId arch
+            return $ E.concat aE bE,
+          queryStateInsert = \eId arch e ->
+            let (aE, bE) = E.split e
+                arch' = queryStateInsert aQS eId arch aE
+             in queryStateInsert bQS eId arch' bE
+        }
 
+-- | Fetch a `Component` by its type.
 fetch :: forall a. (Component a, Typeable (StorageT a)) => Query '[a]
 fetch = Query $ \cs ->
-  let cId = fromMaybe (error "TODO") (lookupComponentId @a cs)
-   in ( Set.singleton cId,
-        \arch ->
-          let as = A.all cId arch
-           in ( fmap (\x -> ECons (snd x) ENil) as,
-                A.insertAscList cId . fmap (\((e, _), ECons a ENil) -> (e, a)) . zip as
-              )
-      )
+  let cId = fromMaybe (error "TODO") (CS.lookup @a cs)
+   in QueryState
+        { queryStateComponentIds = Set.singleton cId,
+          queryStateAll = \arch ->
+            let as = A.all cId arch
+             in ( fmap (\x -> ECons (snd x) ENil) as,
+                  A.insertAscList cId . fmap (\((e, _), ECons a ENil) -> (e, a)) . zip as
+                ),
+          queryStateLookup = \eId arch -> do
+            a <- A.lookup eId cId arch
+            return $ ECons a ENil,
+          queryStateInsert = \eId arch e -> let (_, arch', _) = A.insert eId e arch cs in arch'
+        }
 
-all :: forall m a. (Monad m, ToEntity a, FromEntity a, ToQuery (EntityT a)) => Access m [a]
-all = Access $ gets (fmap fromEntity . allWorld (query @(EntityT a)))
+-- | Fetch a `Component` by its `ComponentID`.
+fetchId :: forall a. (Component a, Typeable (StorageT a)) => ComponentID -> Query '[a]
+fetchId cId = fetch' @a (const cId)
 
-allWorld :: Query a -> World -> [Entity a]
-allWorld q w =
-  let (cIds, g) = runQuery' q (components w)
-      res = do
-        aId <- Map.lookup cIds (archetypeIds w)
-        Map.lookup aId (archetypes w)
-   in case res of
-        Just arch -> fst $ g arch
-        Nothing -> []
+fetch' :: forall a. (Component a, Typeable (StorageT a)) => (Components -> ComponentID) -> Query '[a]
+fetch' f = Query $ \cs ->
+  let cId = f cs
+   in QueryState
+        { queryStateComponentIds = Set.singleton cId,
+          queryStateAll = \arch ->
+            let as = A.all cId arch
+             in ( fmap (\x -> ECons (snd x) ENil) as,
+                  A.insertAscList cId . fmap (\((e, _), ECons a ENil) -> (e, a)) . zip as
+                ),
+          queryStateLookup = \eId arch -> do
+            a <- A.lookup eId cId arch
+            return $ ECons a ENil,
+          queryStateInsert = \eId arch e -> let (_, arch', _) = A.insert eId e arch cs in arch'
+        }
 
-mapWith ::
-  (FromEntity i, ToEntity o, EntityT i ~ ConcatT a b, EntityT o ~ b) =>
-  Query a ->
-  Query b ->
-  (i -> o) ->
-  World ->
-  ([o], World)
-mapWith a b f w =
-  let (aCIds, aG) = runQuery' a (components w)
-      (bCIds, bG) = runQuery' b (components w)
-      res = do
-        aId <- Map.lookup (aCIds <> bCIds) (archetypeIds w)
-        arch <- Map.lookup aId (archetypes w)
-        return (aId, arch)
-   in case res of
-        Just (aId, arch) ->
-          let (as, _) = aG arch
-              (bs, bH) = bG arch
-              es = fmap (\(aE, bE) -> f $ fromEntity (E.concat aE bE)) (zip as bs)
-              arch' = bH (fmap (toEntity . toEntity) es) arch
-           in (es, w {archetypes = Map.insert aId arch' (archetypes w)})
-        Nothing -> ([], w)
+all :: forall a. (ToEntity a, FromEntity a, Queryable (EntityT a)) => World -> [a]
+all = fmap fromEntity . queryAll (query @(EntityT a))
 
-class ToQuery a where
-  query :: Query a
+queryAll :: Query a -> World -> [Entity a]
+queryAll q w = fromMaybe [] $ do
+  let qS = runQuery' q (components w)
+  return $ concatMap (fst . queryStateAll qS) (AS.lookup (queryStateComponentIds qS) (archetypes w))
 
-instance ToQuery '[] where
-  query = Query $ const (Set.empty, const ([], \_ arch' -> arch'))
+queryAll' :: Query a -> Archetypes -> Components -> [Entity a]
+queryAll' q as cs = fromMaybe [] $ do
+  let qS = runQuery' q cs
+  return $ concatMap (fst . queryStateAll qS) (AS.lookup (queryStateComponentIds qS) as)
 
-instance {-# OVERLAPPING #-} (Component a, Typeable (StorageT a)) => ToQuery '[a] where
+class Queryable a where
+  query :: Query a
+
+instance {-# OVERLAPPING #-} (Component a, Typeable (StorageT a)) => Queryable '[a] where
   query = fetch @a
 
-instance (Component a, Typeable (StorageT a), ToQuery as) => ToQuery (a ': as) where
+instance (Component a, Typeable (StorageT a), Queryable as) => Queryable (a ': as) where
   query = fetch @a <?> query @as
 
-mapWorld ::
+-- | Map over all entities that match this query,
+-- storing the resulting components in the @World@.
+map ::
   forall i o.
-  ( FromEntity i,
-    ToEntity o,
-    Intersect (EntityT i) (EntityT o),
-    ToQuery (IntersectT (EntityT i) (EntityT o)),
-    Difference (EntityT i) (EntityT o),
-    ToQuery (DifferenceT (EntityT i) (EntityT o)),
-    ConcatT (DifferenceT (EntityT i) (EntityT o)) (IntersectT (EntityT i) (EntityT o)) ~ EntityT i,
-    IntersectT (EntityT i) (EntityT o) ~ EntityT o
-  ) =>
+  (Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o) =>
   (i -> o) ->
   World ->
   ([o], World)
-mapWorld f w =
-  let i = query @(IntersectT (EntityT i) (EntityT o))
-      o = query @(DifferenceT (EntityT i) (EntityT o))
-      (aCIds, aG) = runQuery' i (components w)
-      (bCIds, bG) = runQuery' o (components w)
-      res = do
-        aId <- Map.lookup (aCIds <> bCIds) (archetypeIds w)
-        arch <- Map.lookup aId (archetypes w)
-        return (aId, arch)
-   in case res of
-        Just (aId, arch) ->
-          let (as, aH) = aG arch
-              (bs, _) = bG arch
-              es = fmap (\(aE, bE) -> f $ fromEntity @i (E.concat bE aE)) (zip as bs)
-              arch' = aH (fmap (\x -> let e = toEntity x in e) es) arch
-           in (es, w {archetypes = Map.insert aId arch' (archetypes w)})
-        Nothing -> ([], w)
+map f w =
+  let (o, arches) = map' @(IsEq (Entity (EntityT i)) (Entity (EntityT o))) f (components w) AS.map (archetypes w)
+   in (o, w {archetypes = arches})
 
-map ::
-  forall m i o.
-  ( Monad m,
-    FromEntity i,
+-- Returns @True@ if @a@ and @b@ are the same type.
+type family IsEq a b :: Bool where
+  IsEq a a = 'True
+  IsEq a b = 'False
+
+-- Map over an entity's components.
+--
+-- @flag@ indicates if the input and output entities are the same,
+-- in order to specialize at compile-time.
+--
+-- If the input and output entities are different, a reader and writer query are combined into one.
+-- Otherwise, if the input and output entities are the same, we can use a more efficient implementation.
+class Map (flag :: Bool) i o where
+  map' :: (i -> o) -> Components -> (Set ComponentID -> (Archetype -> ([o], Archetype)) -> a -> ([[o]], a)) -> a -> ([o], a)
+
+instance (FromEntity i, ToEntity o, EntityT i ~ a, EntityT o ~ a, Queryable a) => Map 'True i o where
+  map' f cs mapArches arches = fromMaybe ([], arches) $ do
+    let qS = runQuery' (query @a) cs
+        go arch =
+          let (as, h) = queryStateAll qS arch
+              as' = fmap (f . fromEntity) as
+              arch' = h (fmap toEntity as') arch
+           in (as', arch')
+    let (es, arches') = mapArches (queryStateComponentIds qS) go arches'
+    return (concat es, arches')
+
+instance
+  ( FromEntity i,
     ToEntity o,
     Intersect (EntityT i) (EntityT o),
-    ToQuery (IntersectT (EntityT i) (EntityT o)),
+    Queryable (IntersectT (EntityT i) (EntityT o)),
     Difference (EntityT i) (EntityT o),
-    ToQuery (DifferenceT (EntityT i) (EntityT o)),
-    ConcatT (DifferenceT (EntityT i) (EntityT o)) (IntersectT (EntityT i) (EntityT o)) ~ EntityT i,
-    IntersectT (EntityT i) (EntityT o) ~ EntityT o
+    Queryable (DifferenceT (EntityT i) (EntityT o)),
+    Sort (ConcatT (DifferenceT (EntityT i) (EntityT o)) (IntersectT (EntityT i) (EntityT o))) (EntityT i),
+    Sort (EntityT o) (IntersectT (EntityT i) (EntityT o))
   ) =>
-  (i -> o) ->
-  Access m [o]
-map f = Access $ do
-  w <- get
-  let (out, w') = mapWorld @i @o f w
-  put w'
-  return out
+  Map 'False i o
+  where
+  map' f cs mapArches arches = fromMaybe ([], arches) $ do
+    let i = query @(IntersectT (EntityT i) (EntityT o))
+        o = query @(DifferenceT (EntityT i) (EntityT o))
+        aQS = runQuery' i cs
+        bQS = runQuery' o cs
+        g arch =
+          let (as, aH) = queryStateAll aQS arch
+              (bs, _) = queryStateAll bQS arch
+              es = fmap (\(aE, bE) -> f $ fromEntity @i (E.sort $ E.concat bE aE)) (zip as bs)
+              arch' = aH (fmap (\x -> let e = E.sort $ toEntity x in e) es) arch
+           in (es, arch')
+        (es', arches') = mapArches (queryStateComponentIds aQS <> queryStateComponentIds bQS) g arches
+    return (concat es', arches')
+
+lookup :: forall a. (FromEntity a, Queryable (EntityT a)) => EntityID -> World -> Maybe a
+lookup eId w = fromEntity <$> lookupQuery eId (query @(EntityT a)) w
+
+lookupQuery :: EntityID -> Query a -> World -> Maybe (Entity a)
+lookupQuery eId q w = do
+  let qS = runQuery' q (components w)
+  aId <- Map.lookup eId (entities w)
+  node <- AS.lookupNode aId (archetypes w)
+  queryStateLookup qS eId (nodeArchetype node)
+
+alter :: forall a. (FromEntity a, ToEntity a, Queryable (EntityT a)) => EntityID -> (a -> a) -> World -> World
+alter eId f w = fromMaybe w $ do
+  let qS = runQuery' (query @(EntityT a)) (components w)
+  aId <- Map.lookup eId (entities w)
+  node <- AS.lookupNode aId (archetypes w)
+  e <- queryStateLookup qS eId (nodeArchetype node)
+  let e' = f (fromEntity e)
+      arch' = queryStateInsert qS eId (nodeArchetype node) (toEntity e')
+  return $
+    w
+      { archetypes =
+          (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}
+      }

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

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

@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Data.Aztecs.System where
+
+import Control.Arrow (Arrow (..))
+import Control.Category (Category (..))
+import Data.Aztecs.Access (Access, runAccess)
+import Data.Aztecs.Entity (ComponentIds (componentIds), Entity, EntityT)
+import Data.Aztecs.Query (IsEq, Queryable)
+import qualified Data.Aztecs.Query as Q
+import Data.Aztecs.View (View (..))
+import qualified Data.Aztecs.View as V
+import Data.Aztecs.World (World (..))
+import Data.Aztecs.World.Components (ComponentID, Components)
+import Data.Data (Typeable)
+import Data.Set (Set)
+
+class (Typeable a) => System m a where
+  task :: Task m () ()
+
+runSystem :: forall m s. (System m s, Monad m) => World -> m World
+runSystem w = do
+  let (cs, _, f) = runTask (task @m @s) (components w)
+      w' = w {components = cs}
+  (_, g, access) <- f () w'
+  (_, w'') <- runAccess access w'
+  return $ g w''
+
+-- | System task.
+newtype Task m i o = Task
+  { runTask ::
+      Components ->
+      ( Components,
+        [Set ComponentID],
+        i -> World -> m (o, World -> World, Access m ())
+      )
+  }
+  deriving (Functor)
+
+instance (Monad m) => Applicative (Task m i) where
+  pure a = Task (,[],\_ _ -> pure (a, Prelude.id, pure ()))
+  f <*> a =
+    Task $ \w ->
+      let (w', cIds, f') = runTask f w
+          (w'', cIds', a') = runTask a w'
+       in ( w'',
+            cIds <> cIds',
+            \i cs -> do
+              (f'', fG, access) <- f' i cs
+              (a'', aG, access') <- a' i cs
+              return (f'' a'', fG Prelude.. aG, access >> access')
+          )
+
+instance (Monad m) => Category (Task m) where
+  id = Task (,[],\i _ -> pure (i, Prelude.id, pure ()))
+  (.) t1 t2 = Task $ \w ->
+    let (w', cIds, f) = runTask t2 w
+        (w'', cIds', g) = runTask t1 w'
+     in ( w'',
+          cIds <> cIds',
+          \i cs -> do
+            (o, f', access) <- f i cs
+            (a, g', access') <- g o cs
+            return (a, g' Prelude.. f', access >> access')
+        )
+
+instance (Monad m) => Arrow (Task m) where
+  arr f = Task (,[],\i _ -> pure (f i, Prelude.id, pure ()))
+  first t =
+    Task $ \w ->
+      let (w', cIds, f) = runTask t w
+       in ( w',
+            cIds,
+            \(i, x) cs -> do
+              (o, f', access) <- f i cs
+              return ((o, x), f', access)
+          )
+
+all :: forall m v. (Monad m, ComponentIds v, Queryable v) => Task m () [Entity v]
+all = view @_ @v (\v cs -> pure $ V.queryAll v cs)
+
+map ::
+  forall m i o.
+  ( Monad m,
+    ComponentIds (EntityT i),
+    Queryable (EntityT i),
+    Q.Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o
+  ) =>
+  (i -> o) ->
+  Task m () [o]
+map f = mapView (\v cs -> pure $ V.map f v cs)
+
+view ::
+  forall m v a.
+  (Monad m, ComponentIds v, Queryable v) =>
+  (View v -> Components -> m a) ->
+  Task m () a
+view f = Task $ \cs ->
+  let (cIds, cs') = componentIds @v cs
+   in ( cs',
+        [cIds],
+        \_ w ->
+          let (v, w') = V.view @v w
+           in (,Prelude.id,pure ()) <$> f v (components w')
+      )
+
+mapView ::
+  forall m v a.
+  (Monad m, ComponentIds v, Queryable v) =>
+  (View v -> Components -> m (a, View v)) ->
+  Task m () a
+mapView f = Task $ \cs ->
+  let (cIds, cs') = componentIds @v cs
+   in ( cs',
+        [cIds],
+        \_ w ->
+          let (v, w') = V.view @v w
+           in (\(a, v') -> (a, V.unview v', pure ())) <$> f v (components w')
+      )
+
+-- | Queue an `Access` to alter the world after this task is complete.
+queue :: (Monad m) => Access m () -> Task m () ()
+queue a = Task (,[],\_ _ -> pure ((), Prelude.id, a))
+
+run :: (Monad m) => (i -> m o) -> Task m i o
+run f =
+  Task
+    (,[],\i _ -> do
+           o <- f i
+           return (o, Prelude.id, pure ()))

@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Data.Aztecs.View where
+
+import Data.Aztecs.Entity (ComponentIds, EntityT, componentIds, Entity)
+import Data.Aztecs.Query (IsEq, Query (..), QueryState (..), Queryable (..))
+import qualified Data.Aztecs.Query as Q
+import Data.Aztecs.World (ArchetypeID, World)
+import qualified Data.Aztecs.World as W
+import Data.Aztecs.World.Archetype (Archetype)
+import Data.Aztecs.World.Archetypes (Archetypes)
+import qualified Data.Aztecs.World.Archetypes as AS
+import Data.Aztecs.World.Components (Components)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+
+data View a = View
+  { viewArchetypes :: Map ArchetypeID Archetype,
+    viewQuery :: Query a
+  }
+
+view :: forall a. (ComponentIds a, Queryable a) => World -> (View a, World)
+view w =
+  let (v, cs') = view' @a (W.components w) (W.archetypes w)
+   in (v, w {W.components = cs'})
+
+view' :: forall a. (ComponentIds a, Queryable a) => Components -> Archetypes -> (View a, Components)
+view' cs as =
+  let (cIds, cs') = componentIds @a cs
+   in ( View
+          { viewArchetypes = AS.lookup cIds as,
+            viewQuery = query @a
+          },
+        cs'
+      )
+
+unview :: View a -> World -> World
+unview v w =
+  w
+    { W.archetypes =
+        foldr
+          (\(aId, arch) as -> AS.adjustArchetype aId (const arch) as)
+          (W.archetypes w)
+          (Map.toList $ viewArchetypes v)
+    }
+
+queryAll :: View a -> Components -> [Entity a]
+queryAll v cs = fromMaybe [] $ do
+  let qS = runQuery' (viewQuery v) cs
+  return $ concatMap (fst . queryStateAll qS) (Map.elems $ viewArchetypes v)
+
+-- | Map over all entities that match this query,
+-- storing the resulting components in the @View@.
+map ::
+  forall i o.
+  (Q.Map (IsEq (Entity (EntityT i)) (Entity (EntityT o))) i o) =>
+  (i -> o) ->
+  View (EntityT i) ->
+  Components ->
+  ([o], View (EntityT i))
+map f v cs =
+  let (o, arches) =
+        Q.map' @(IsEq (Entity (EntityT i)) (Entity (EntityT o)))
+          f
+          cs
+          ( \_ g arches' ->
+              foldr
+                ( \(aId, arch) (acc, archAcc) ->
+                    let (os, arch') = g arch
+                     in (os : acc, Map.insert aId arch' archAcc)
+                )
+                ([], Map.empty)
+                (Map.toList arches')
+          )
+          (viewArchetypes v)
+   in (o, v {viewArchetypes = arches})

@@ -9,35 +9,38 @@     World (..),
     empty,
     spawn,
+    spawnComponent,
     spawnWithId,
     spawnWithArchetypeId,
     spawnEmpty,
     insert,
     insertWithId,
-    insertArchetype,
     despawn,
   )
 where
 
-import Data.Aztecs.Archetype (Archetype (..))
-import qualified Data.Aztecs.Archetype as A
-import Data.Aztecs.Core (Component (..), ComponentID, Components (..), EntityID (..), emptyComponents, insertComponentId)
+import Data.Aztecs.Component
+  ( Component (..),
+    ComponentID,
+  )
+import Data.Aztecs.Entity (ComponentIds, Entity, EntityID (..), ToEntity (..), EntityT)
+import qualified Data.Aztecs.Entity as E
+import Data.Aztecs.World.Archetype (Archetype (..), Insert)
+import qualified Data.Aztecs.World.Archetype as A
+import Data.Aztecs.World.Archetypes (ArchetypeID, Archetypes, Node (..))
+import qualified Data.Aztecs.World.Archetypes as AS
+import Data.Aztecs.World.Components (Components (..))
+import qualified Data.Aztecs.World.Components as CS
 import Data.Dynamic (Dynamic)
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Set (Set)
+import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
 import Data.Typeable (Proxy (..), Typeable, typeOf)
 
-newtype ArchetypeID = ArchetypeID {unArchetypeId :: Int}
-  deriving (Eq, Ord, Show)
-
 -- | World of entities and their components.
 data World = World
-  { archetypes :: Map ArchetypeID Archetype,
-    archetypeIds :: Map (Set ComponentID) ArchetypeID,
-    archetypeComponents :: Map ArchetypeID (Set ComponentID),
-    nextArchetypeId :: ArchetypeID,
+  { archetypes :: Archetypes,
     components :: Components,
     entities :: Map EntityID ArchetypeID,
     nextEntityId :: EntityID
@@ -48,21 +51,60 @@ empty :: World
 empty =
   World
-    { archetypes = mempty,
-      archetypeIds = mempty,
-      archetypeComponents = mempty,
-      nextArchetypeId = ArchetypeID 0,
-      components = emptyComponents,
+    { archetypes = AS.empty,
+      components = CS.empty,
       entities = mempty,
       nextEntityId = EntityID 0
     }
 
+spawn ::
+  forall a.
+  (ComponentIds (EntityT a), ToEntity a, Insert (Entity (EntityT a))) =>
+   a ->
+  World ->
+  (EntityID, World)
+spawn e w =
+  let (eId, w') = spawnEmpty w
+      (cIds, components') = E.componentIds @(EntityT a) (components w)
+   in case AS.lookupArchetypeId cIds (archetypes w) of
+        Just aId -> fromMaybe (eId, w') $ do
+          node <- AS.lookupNode aId (archetypes w)
+          let (_, arch', components'') = A.insert eId (toEntity e) (nodeArchetype node) components'
+          return
+            ( eId,
+              w
+                { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},
+                  components = components'',
+                  entities = Map.insert eId aId (entities w)
+                }
+            )
+        Nothing ->
+          let (_, arch, components'') = A.insert eId (toEntity e) A.empty components'
+              (aId, arches) =
+                AS.insertArchetype
+                  cIds
+                  ( Node
+                      { nodeComponentIds = cIds,
+                        nodeArchetype = arch,
+                        nodeAdd = Map.empty,
+                        nodeRemove = Map.empty
+                      }
+                  )
+                  (archetypes w')
+           in ( eId,
+                w'
+                  { archetypes = arches,
+                    entities = Map.insert eId aId (entities w),
+                    components = components''
+                  }
+              )
+
 -- | Spawn an entity with a component.
-spawn :: forall a. (Component a, Typeable (StorageT a)) => a -> World -> (EntityID, World)
-spawn c w = case Map.lookup (typeOf (Proxy @a)) (componentIds (components w)) of
+spawnComponent :: forall a. (Component a, Typeable (StorageT a)) => a -> World -> (EntityID, World)
+spawnComponent c w = case Map.lookup (typeOf (Proxy @a)) (componentIds (components w)) of
   Just cId -> spawnWithId cId c w
   Nothing ->
-    let (cId, cs) = insertComponentId @a (components w)
+    let (cId, cs) = CS.insert @a (components w)
      in spawnWithId cId c w {components = cs}
 
 -- | Spawn an empty entity.
@@ -79,16 +121,21 @@   (EntityID, World)
 spawnWithId cId c w =
   let (e, w') = spawnEmpty w
-   in case Map.lookup (Set.singleton cId) (archetypeIds w) of
+   in case AS.lookupArchetypeId (Set.singleton cId) (archetypes w) of
         Just aId -> (e, spawnWithArchetypeId' e aId cId c w')
         Nothing ->
-          ( e,
-            snd $
-              insertArchetype
-                (Set.singleton cId)
-                (A.insert e cId c A.empty)
-                w' {entities = Map.insert e (nextArchetypeId w) (entities w)}
-          )
+          let (aId, arches) =
+                AS.insertArchetype
+                  (Set.singleton cId)
+                  ( Node
+                      { nodeComponentIds = Set.singleton cId,
+                        nodeArchetype = A.insertComponent e cId c A.empty,
+                        nodeAdd = Map.empty,
+                        nodeRemove = Map.empty
+                      }
+                  )
+                  (archetypes w')
+           in (e, w' {archetypes = arches, entities = Map.insert e aId (entities w)})
 
 -- | Spawn an entity with a component and its `ComponentID` directly into an archetype.
 spawnWithArchetypeId ::
@@ -113,78 +160,97 @@   World ->
   World
 spawnWithArchetypeId' e aId cId c w =
-  let f = A.insert e cId c
+  let f n = n {nodeArchetype = A.insertComponent e cId c (nodeArchetype n)}
    in w
-        { archetypes = Map.adjust f aId (archetypes w),
+        { archetypes = (archetypes w) {AS.nodes = Map.adjust f aId (AS.nodes $ archetypes w)},
           entities = Map.insert e aId (entities w)
         }
 
--- | Insert an archetype by its set of `ComponentID`s.
-insertArchetype :: Set ComponentID -> Archetype -> World -> (ArchetypeID, World)
-insertArchetype cIds a w =
-  let aId = nextArchetypeId w
-   in ( aId,
-        w
-          { archetypes = Map.insert aId a (archetypes w),
-            archetypeIds = Map.insert cIds aId (archetypeIds w),
-            archetypeComponents = Map.insert aId cIds (archetypeComponents w),
-            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1)
-          }
-      )
-
+-- | 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') = insertComponentId @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`.
 insertWithId :: (Component a, Typeable (StorageT a)) => EntityID -> ComponentID -> a -> World -> World
 insertWithId e cId c w = case Map.lookup e (entities w) of
-  Just aId -> case Map.lookup aId (archetypeComponents w) of
-    Just cIds ->
-      if Set.member cId cIds
-        then w {archetypes = Map.adjust (A.insert e cId c) aId (archetypes w)}
-        else
-          let arch = archetypes w Map.! aId
-           in case Map.lookup (Set.insert cId cIds) (archetypeIds w) of
-                Just nextAId ->
-                  let (cs, arch') = A.remove e arch
-                      w' = w {archetypes = Map.insert aId arch' (archetypes w)}
-                      f (itemCId, dyn) archAcc =
-                        archAcc
-                          { A.storages =
-                              Map.adjust
-                                (\s -> s {A.storageDyn = A.insertDyn s (unEntityId e) dyn (A.storageDyn s)})
-                                itemCId
-                                (A.storages archAcc)
-                          }
-                   in w'
-                        { archetypes =
+  Just aId -> case AS.lookupNode aId (archetypes w) of
+    Just node ->
+      if Set.member cId (nodeComponentIds node)
+        then w {archetypes = (archetypes w) {AS.nodes = Map.adjust (\n -> n {nodeArchetype = A.insertComponent e cId c (nodeArchetype n)}) aId (AS.nodes $ archetypes w)}}
+        else case AS.lookupArchetypeId (Set.insert cId (nodeComponentIds node)) (archetypes w) of
+          Just nextAId ->
+            let (cs, arch') = A.remove e (nodeArchetype node)
+                w' = w {archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)}}
+                f (itemCId, dyn) archAcc =
+                  archAcc
+                    { A.storages =
+                        Map.adjust
+                          (\s -> s {A.storageDyn = A.insertDyn s (unEntityId e) dyn (A.storageDyn s)})
+                          itemCId
+                          (A.storages archAcc)
+                    }
+             in w'
+                  { archetypes =
+                      (archetypes w')
+                        { AS.nodes =
                             Map.adjust
-                              (\nextArch -> foldr f nextArch (Map.toList cs))
+                              ( \nextNode ->
+                                  nextNode
+                                    { nodeArchetype =
+                                        A.insertComponent e cId c $
+                                          foldr
+                                            f
+                                            (nodeArchetype nextNode)
+                                            (Map.toList cs)
+                                    }
+                              )
                               nextAId
-                              (archetypes w')
-                        }
-                Nothing ->
-                  let (s, arch') = A.removeStorages e arch
-                      w' = w {archetypes = Map.insert aId arch' (archetypes w)}
-                      newArch = Archetype {A.storages = s}
-                      newArch' = A.insert e cId c newArch
-                   in snd $ insertArchetype (Set.insert cId cIds) newArch' w'
+                              (AS.nodes $ archetypes w')
+                        },
+                    entities = Map.insert e aId (entities w)
+                  }
+          Nothing ->
+            let (s, arch') = A.removeStorages e (nodeArchetype node)
+                n =
+                  Node
+                    { nodeComponentIds = Set.insert cId (nodeComponentIds node),
+                      nodeArchetype = A.insertComponent e cId c (Archetype {A.storages = s}),
+                      nodeAdd = Map.empty,
+                      nodeRemove = Map.singleton cId aId
+                    }
+                (nextAId, arches) = AS.insertArchetype (Set.insert cId (nodeComponentIds node)) n (archetypes w)
+             in w
+                  { archetypes =
+                      arches
+                        { AS.nodes =
+                            Map.insert
+                              aId
+                              node
+                                { nodeArchetype = arch',
+                                  nodeAdd = Map.insert cId nextAId (nodeAdd node)
+                                }
+                              (AS.nodes arches)
+                        },
+                    entities = Map.insert e nextAId (entities w)
+                  }
     Nothing -> w
   Nothing -> w
 
+-- | Despawn an entity, returning its components.
 despawn :: EntityID -> World -> (Map ComponentID Dynamic, World)
 despawn e w =
   let res = do
         aId <- Map.lookup e (entities w)
-        arch <- Map.lookup aId (archetypes w)
-        return (aId, arch)
+        node <- AS.lookupNode aId (archetypes w)
+        return (aId, node)
    in case res of
-        Just (aId, arch) ->
-          let (dynAcc, arch') = A.remove e arch
+        Just (aId, node) ->
+          let (dynAcc, arch') = A.remove e (nodeArchetype node)
            in ( dynAcc,
                 w
-                  { archetypes = Map.insert aId arch' (archetypes w),
+                  { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},
                     entities = Map.delete e (entities w)
                   }
               )

@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Aztecs.World.Archetype
+  ( Archetype (..),
+    empty,
+    all,
+    lookup,
+    lookupStorage,
+    remove,
+    removeStorages,
+    insertComponent,
+    insertAscList,
+    Insert (..),
+    AnyStorage (..),
+    anyStorage,
+  )
+where
+
+import Data.Aztecs.Component (Component (..), ComponentID)
+import Data.Aztecs.Entity (Entity (..), EntityID (..))
+import qualified Data.Aztecs.Storage as S
+import Data.Aztecs.World.Components (Components)
+import qualified Data.Aztecs.World.Components as CS
+import Data.Bifunctor (Bifunctor (..))
+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Prelude hiding (all, lookup)
+
+data AnyStorage = AnyStorage
+  { storageDyn :: Dynamic,
+    insertDyn :: Int -> Dynamic -> Dynamic -> Dynamic,
+    removeDyn :: Int -> Dynamic -> (Maybe Dynamic, Dynamic),
+    removeAny :: Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
+  }
+
+instance Show AnyStorage where
+  show s = "AnyStorage " ++ show (storageDyn s)
+
+anyStorage :: forall s a. (S.Storage s a) => s a -> AnyStorage
+anyStorage s =
+  AnyStorage
+    { storageDyn = toDyn s,
+      insertDyn = \i cDyn sDyn ->
+        fromMaybe sDyn $ do
+          s' <- fromDynamic @(s a) sDyn
+          c <- fromDynamic cDyn
+          return . toDyn $ S.insert i c s',
+      removeDyn = \i dyn -> case fromDynamic @(s a) dyn of
+        Just s' -> let (a, b) = S.remove i s' in (fmap toDyn a, toDyn b)
+        Nothing -> (Nothing, dyn),
+      removeAny = \i dyn -> case fromDynamic @(s a) dyn of
+        Just s' -> let (a, b) = S.remove i s' in (fmap (anyStorage . S.singleton @s i) a, toDyn b)
+        Nothing -> (Nothing, dyn)
+    }
+
+newtype Archetype = Archetype {storages :: Map ComponentID AnyStorage}
+  deriving (Show)
+
+empty :: Archetype
+empty = Archetype {storages = Map.empty}
+
+lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a a)
+lookupStorage cId w = do
+  dynS <- Map.lookup cId (storages w)
+  fromDynamic (storageDyn dynS)
+
+insertComponent :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype
+insertComponent e cId c arch =
+  let storage = case lookupStorage cId arch of
+        Just s -> S.insert (unEntityId e) c s
+        Nothing -> S.singleton @(StorageT a) @a (unEntityId e) c
+   in arch {storages = Map.insert cId (anyStorage storage) (storages arch)}
+
+all :: (Component a) => ComponentID -> Archetype -> [(EntityID, a)]
+all cId arch = fromMaybe [] $ do
+  s <- lookupStorage cId arch
+  return . map (first EntityID) $ S.all s
+
+lookup :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a
+lookup e cId w = lookupStorage cId w >>= S.lookup (unEntityId e)
+
+insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype
+insertAscList cId as arch = arch {storages = Map.insert cId (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as)) (storages arch)}
+
+remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
+remove e arch =
+  foldr
+    ( \(cId, s) (dynAcc, archAcc) ->
+        let (dynA, dynS) = removeDyn s (unEntityId e) (storageDyn s)
+            dynAcc' = case dynA of
+              Just d -> Map.insert cId d dynAcc
+              Nothing -> dynAcc
+         in ( dynAcc',
+              archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}
+            )
+    )
+    (Map.empty, arch)
+    (Map.toList $ storages arch)
+
+removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)
+removeStorages e arch =
+  foldr
+    ( \(cId, s) (dynAcc, archAcc) ->
+        let (dynA, dynS) = removeAny s (unEntityId e) (storageDyn s)
+            dynAcc' = case dynA of
+              Just d -> Map.insert cId d dynAcc
+              Nothing -> dynAcc
+         in ( dynAcc',
+              archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}
+            )
+    )
+    (Map.empty, arch)
+    (Map.toList $ storages arch)
+
+class Insert a where
+  insert :: EntityID -> a -> Archetype -> Components -> (Set ComponentID, Archetype, Components)
+
+instance Insert (Entity '[]) where
+  insert _ ENil arch cs = (Set.empty, arch, cs)
+
+instance (Component a, Insert (Entity as)) => Insert (Entity (a ': as)) where
+  insert eId (ECons e es) arch cs =
+    let (cId, cs') = CS.insert @a cs
+        arch' = insertComponent eId cId e arch
+        (cIds, arch'', cs'') = insert eId es arch' cs'
+     in (Set.insert cId cIds, arch'', cs'')

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

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

@@ -1,6 +1,10 @@ module Main (main) where
 
 import Data.Aztecs
+import Data.Aztecs.Entity (ToEntity (toEntity))
+import qualified Data.Aztecs.Query as Q
+import qualified Data.Aztecs.World as W
+import Test.Hspec
 
 newtype X = X Int deriving (Eq, Show)
 
@@ -10,5 +14,26 @@ 
 instance Component Y
 
+newtype Z = Z Int deriving (Eq, Show)
+
+instance Component Z
+
 main :: IO ()
-main = return ()
+main = hspec $ do
+  describe "Data.Aztecs.Query.all" $ do
+    it "queries multiple components" $ do
+      let (_, w) = W.spawn (X 0) W.empty
+          (_, w') = W.spawn (X 1) w
+          xs = Q.all w'
+      xs `shouldMatchList` [X 0, X 1]
+    it "queries a group of components" $ do
+      let (e, w) = W.spawn (X 0) W.empty
+          w' = W.insert e (Y 1) w
+          xs = Q.all w'
+      xs `shouldMatchList` [toEntity (X 0 :& Y 1)]
+    it "queries a fragmented group of components" $ do
+      let (e, w) = W.spawn (X 0) W.empty
+          w' = W.insert e (Y 1) w
+          w'' = W.insert e (Z 2) w'
+          xs = Q.all w''
+      xs `shouldMatchList` [toEntity (Y 1 :& Z 2)]