aztecs 0.1.0.1 → 0.2.0.0

raw patch · 19 files changed

+870/−1208 lines, 19 filesdep +hspecdep −asyncPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec

Dependencies removed: async

API changes (from Hackage documentation)

Files

• LICENSE +29/−29
• aztecs.cabal +7/−10
• bench/Iter.hs +34/−45
• examples/ECS.hs +33/−47
• src/Data/Aztecs.hs +13/−33
• src/Data/Aztecs/Access.hs +30/−0
• src/Data/Aztecs/Archetype.hs +104/−0
• src/Data/Aztecs/Command.hs +0/−43
• src/Data/Aztecs/Core.hs +60/−5
• src/Data/Aztecs/Entity.hs +162/−0
• src/Data/Aztecs/Query.hs +168/−134
• src/Data/Aztecs/Schedule.hs +0/−207
• src/Data/Aztecs/Storage.hs +25/−65
• src/Data/Aztecs/System.hs +0/−218
• src/Data/Aztecs/Task.hs +0/−29
• src/Data/Aztecs/World.hs +191/−71
• src/Data/Aztecs/World/Archetypes.hs +0/−181
• src/Data/Aztecs/World/Components.hs +0/−87
• test/Main.hs +14/−4

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

@@ -1,6 +1,6 @@ cabal-version: 3.0 name:          aztecs-version:       0.1.0.1+version:       0.2.0.0 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me@@ -12,23 +12,19 @@ library     exposed-modules:         Data.Aztecs+        Data.Aztecs.Access+        Data.Aztecs.Archetype         Data.Aztecs.Core-        Data.Aztecs.Command-        Data.Aztecs.Schedule-        Data.Aztecs.System-        Data.Aztecs.Storage-        Data.Aztecs.Task+        Data.Aztecs.Entity         Data.Aztecs.Query+        Data.Aztecs.Storage         Data.Aztecs.World-        Data.Aztecs.World.Archetypes-        Data.Aztecs.World.Components      hs-source-dirs:   src     default-language: Haskell2010     ghc-options:      -Wall     build-depends:         base >=4 && <5,-        async >=2,         containers >=0.7,         mtl >=2 @@ -49,7 +45,8 @@     ghc-options:      -Wall     build-depends:         base >=4 && <5,-        aztecs+        aztecs,+        hspec >=2  benchmark aztecs-bench     type:             exitcode-stdio-1.0

@@ -1,45 +1,34 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}--import Criterion.Main-import Data.Aztecs-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.System (runSystem)-import qualified Data.Aztecs.System as S-import qualified Data.Aztecs.World as W-import Data.Foldable (foldrM)--newtype Position = Position Int deriving (Show)--instance Component Position--newtype Velocity = Velocity Int deriving (Show)--instance Component Velocity--data S--instance System IO S where-  access = do-    _ <- S.all $ do-      Velocity y <- Q.read-      Q.write (\(Position x) -> Position (x + y))-    return ()--runner :: World -> IO ()-runner w = do-  !_ <- runSystem @S w-  return ()--main :: IO ()-main = do-  !w <--    foldrM-      ( \_ wAcc -> do-          (_, wAcc') <- W.spawn (Position 0) wAcc-          return wAcc'-      )-      W.newWorld-      [0 :: Int .. 10000]-  defaultMain [bench "iter" $ nfIO (runner w)]+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+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
+
+newtype Position = Position Int deriving (Show)
+
+instance Component Position
+
+newtype Velocity = Velocity Int deriving (Show)
+
+instance Component Velocity
+
+run :: World -> World
+run w =
+  let !(_, w') = Q.mapWith Q.fetch Q.fetch (\(Velocity v :& Position x) -> Position (x + v)) w
+   in w'
+
+main :: IO ()
+main = do
+  let w =
+        foldr
+          ( \_ wAcc ->
+              let (e, wAcc') = W.spawn (Position 0) wAcc
+               in W.insert e (Velocity 1) wAcc'
+          )
+          W.empty
+          [0 :: Int .. 10000]
+  defaultMain [bench "iter" $ whnf run w]

@@ -1,47 +1,33 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}--module Main where--import Control.Monad.IO.Class-import Data.Aztecs-import qualified Data.Aztecs.Command as C-import qualified Data.Aztecs.Query as Q-import qualified Data.Aztecs.System as S---- Components--newtype Position = Position Int deriving (Show)--instance Component Position--newtype Velocity = Velocity Int deriving (Show)--instance Component Velocity---- Systems--data A--instance System IO A where-  access = S.command $ do-    e <- C.spawn (Position 0)-    C.insert e (Velocity 1)--data B--instance System IO B where-  access = do-    -- Update all entities with a `Position` and `Velocity` component.-    positions <- S.all $ do-      Velocity v <- Q.read-      Q.write (\(Position p) -> Position (p + v))--    liftIO $ print positions--app :: Scheduler IO-app = schedule @Startup @_ @A [] <> schedule @Update @_ @B []--main :: IO ()-main = runScheduler app+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MonoLocalBinds #-}
+
+module Main where
+
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.Aztecs
+import qualified Data.Aztecs.Access as A
+import qualified Data.Aztecs.Query as Q
+import qualified Data.Aztecs.World as W
+
+newtype Position = Position Int deriving (Show)
+
+instance Component Position
+
+newtype Velocity = Velocity Int deriving (Show)
+
+instance Component Velocity
+
+app :: Access IO ()
+app = do
+  -- Spawn an entity with position and velocity components
+  e <- A.spawn (Position 0)
+  A.insert e (Velocity 1)
+
+  -- Query for and update all matching entities
+  q <- Q.map (\(Velocity v :& Position x) -> Position (x + v))
+  liftIO $ print q
+
+main :: IO ()
+main = do
+  _ <- runAccess app W.empty
+  return ()

@@ -1,33 +1,13 @@-module Data.Aztecs-  ( Entity,-    EntityComponent (..),-    Component (..),-    World,-    Query,-    Access (..),-    Task,-    System (..),-    Constraint (..),-    before,-    after,-    Schedule (..),-    Startup,-    Update,-    Scheduler (..),-    schedule,-    runScheduler,-  )-where--import Data.Aztecs.Query-  ( Query (..),-  )-import Data.Aztecs.Schedule-import Data.Aztecs.System-import Data.Aztecs.Task (Task (..))-import Data.Aztecs.World-  ( Component (..),-    Entity,-    EntityComponent (..),-    World,-  )+module Data.Aztecs
+  ( Access,
+    runAccess,
+    Component (..),
+    EntityID,
+    Entity,
+    (:&) (..),
+  )
+where
+
+import Data.Aztecs.Access (Access, runAccess)
+import Data.Aztecs.Core (Component (..), EntityID)
+import Data.Aztecs.Entity (Entity, (:&) (..))

@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.Aztecs.Access where
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.State (MonadState (..), StateT (..))
+import Data.Aztecs.Core (Component (..), EntityID)
+import Data.Aztecs.World (World)
+import qualified Data.Aztecs.World as W
+import Data.Data (Typeable)
+
+newtype Access m a = Access {unAccess :: StateT World m a}
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+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 c = Access $ do
+  w <- get
+  let (e, w') = W.spawn c w
+  put w'
+  return e
+
+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'

@@ -0,0 +1,104 @@+{-# 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)

@@ -1,43 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Data.Aztecs.Command-  ( Command (..),-    spawn,-    insert,-    Edit (..),-  )-where--import Control.Monad.IO.Class-import Control.Monad.State (StateT (..))-import qualified Control.Monad.State as S-import Data.Aztecs.World (Component, Entity, World)-import qualified Data.Aztecs.World as W-import Data.Dynamic (Typeable)-import Data.Proxy-import Prelude hiding (all)--data Edit where-  Spawn :: (Component c) => Entity -> (Proxy c) -> Edit-  Insert :: (Component c) => Entity -> (Proxy c) -> Edit---- | Command to update the `World`.-newtype Command m a = Command (StateT World m a)-  deriving (Functor, Applicative, Monad, MonadIO)---- | Spawn a `Component` and return its `Entity`.-spawn :: (Component a, Typeable a) => a -> Command IO Entity-spawn a = Command $ do-  w <- S.get-  (e, w') <- liftIO $ W.spawn a w-  S.put $ w'-  return e---- | Insert a `Component` into an `Entity`.-insert :: (Component a, Typeable a) => Entity -> a -> Command IO ()-insert e a =  Command $ do-  w <- S.get-  w' <- liftIO $ W.insert e a w-  S.put w'

@@ -1,5 +1,60 @@-module Data.Aztecs.Core (Entity (..), EntityComponent (..)) where--newtype Entity = Entity Int deriving (Eq, Ord, Show)--data EntityComponent a = EntityComponent Entity a deriving (Show)+{-# 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)
+          }
+      )

@@ -0,0 +1,162 @@+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Aztecs.Entity
+  ( Entity (..),
+    EntityT,
+    FromEntity (..),
+    ToEntity (..),
+    ConcatT,
+    IntersectT,
+    Intersect (..),
+    DifferenceT,
+    Difference (..),
+    SplitT,
+    Split (..),
+    concat,
+    (<&>),
+    (:&) (..),
+  )
+where
+
+import Data.Kind (Type)
+import Prelude hiding (concat)
+
+data Entity (ts :: [Type]) where
+  ENil :: Entity '[]
+  ECons :: t -> Entity ts -> Entity (t ': ts)
+
+instance Show (Entity '[]) where
+  show ENil = "[]"
+
+instance (Show a, Show' (Entity as)) => Show (Entity (a ': as)) where
+  show (ECons x xs) = "[" ++ show x ++ showRow xs
+
+class Show' a where
+  showRow :: a -> String
+
+instance Show' (Entity '[]) where
+  showRow ENil = "]"
+
+instance (Show a, Show' (Entity as)) => Show' (Entity (a ': as)) where
+  showRow (ECons x xs) = ", " ++ show x ++ showRow xs
+
+(<&>) :: Entity as -> a -> Entity (a : as)
+(<&>) es c = ECons c es
+
+type family ConcatT (a :: [Type]) (b :: [Type]) where
+  ConcatT '[] b = b
+  ConcatT (a ': as) b = a ': ConcatT as b
+
+concat :: Entity as -> Entity bs -> Entity (ConcatT as bs)
+concat ENil ys = ys
+concat (ECons x xs) ys = ECons x (concat xs ys)
+
+type family SplitT (a :: [Type]) (b :: [Type]) :: [Type] where
+  SplitT '[] bs = bs
+  SplitT (a ': as) (a ': bs) = SplitT as bs
+
+class Split (a :: [Type]) (b :: [Type]) where
+  split :: Entity b -> (Entity a, Entity (SplitT a b))
+
+instance Split '[] bs where
+  split e = (ENil, e)
+
+instance forall a as bs. (Split as bs) => Split (a ': as) (a ': bs) where
+  split (ECons x xs) =
+    let (as, bs) = split @as xs
+     in (ECons x as, bs)
+
+data a :& b = a :& b
+
+type family EntityT a where
+  EntityT (a :& b) = a ': EntityT b
+  EntityT (Entity ts) = ts
+  EntityT a = '[a]
+
+class FromEntity a where
+  fromEntity :: Entity (EntityT a) -> a
+
+instance {-# OVERLAPS #-} (EntityT a ~ '[a]) => FromEntity a where
+  fromEntity (ECons a ENil) = a
+
+instance FromEntity (Entity ts) where
+  fromEntity = id
+
+instance (FromEntity a, FromEntity b, EntityT (a :& b) ~ (a ': EntityT b)) => FromEntity (a :& b) where
+  fromEntity (ECons a rest) = a :& fromEntity rest
+
+class ToEntity a where
+  toEntity :: a -> Entity (EntityT a)
+
+instance {-# OVERLAPS #-} (EntityT a ~ '[a]) => ToEntity a where
+  toEntity a = ECons a ENil
+
+instance ToEntity (Entity ts) where
+  toEntity = id
+
+instance (ToEntity a, ToEntity b, EntityT (a :& b) ~ (a ': EntityT b)) => ToEntity (a :& b) where
+  toEntity (a :& b) = ECons a (toEntity b)
+
+type family ElemT (a :: Type) (b :: [Type]) :: Bool where
+  ElemT a '[] = 'False
+  ElemT a (a ': as) = 'True
+  ElemT a (b ': as) = ElemT a as
+
+type family If (cond :: Bool) (true :: [Type]) (false :: [Type]) :: [Type] where
+  If 'True true false = true
+  If 'False true false = false
+
+type family IntersectT (a :: [Type]) (b :: [Type]) :: [Type] where
+  IntersectT '[] b = '[]
+  IntersectT (a ': as) b = If (ElemT a b) (a ': IntersectT as b) (IntersectT as b)
+
+class Intersect' (flag :: Bool) (a :: [Type]) (b :: [Type]) where
+  intersect' :: Entity a -> Entity b -> Entity (IntersectT a b)
+
+instance (Intersect as b, ElemT a b ~ 'True) => Intersect' 'True (a ': as) b where
+  intersect' (ECons x xs) ys = ECons x (xs `intersect` ys)
+
+instance (Intersect as (b ': bs), ElemT a (b ': bs) ~ 'False) => Intersect' 'False (a ': as) (b ': bs) where
+  intersect' (ECons _ xs) = intersect xs
+
+class Intersect (a :: [Type]) (b :: [Type]) where
+  intersect :: Entity a -> Entity b -> Entity (IntersectT a b)
+
+instance Intersect '[] b where
+  intersect _ _ = ENil
+
+instance (Intersect' (ElemT a bs) (a ': as) bs) => Intersect (a ': as) bs where
+  intersect = intersect' @(ElemT a bs)
+
+type family DifferenceT (a :: [Type]) (b :: [Type]) :: [Type] where
+  DifferenceT '[] b = '[]
+  DifferenceT (a ': as) b = If (ElemT a b) (DifferenceT as b) (a ': DifferenceT as b)
+
+class Difference' (flag :: Bool) (a :: [Type]) (b :: [Type]) where
+  difference' :: Entity a -> Entity b -> Entity (DifferenceT a b)
+
+instance (Difference as b, DifferenceT (a ': as) b ~ DifferenceT as b) => Difference' 'True (a ': as) b where
+  difference' (ECons _ xs) ys = xs `difference` ys
+
+instance (Difference as (b ': bs), DifferenceT (a ': as) (b ': bs) ~ (a ': DifferenceT as (b ': bs))) => Difference' 'False (a ': as) (b ': bs) where
+  difference' (ECons x xs) ys = ECons x (xs `difference` ys)
+
+class Difference (a :: [Type]) (b :: [Type]) where
+  difference :: Entity a -> Entity b -> Entity (DifferenceT a b)
+
+instance Difference '[] b where
+  difference _ _ = ENil
+
+instance (Difference' (ElemT a bs) (a ': as) bs) => Difference (a ': as) bs where
+  difference = difference' @(ElemT a bs)

@@ -1,134 +1,168 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.Query-  ( ReadWrites (..),-    Query (..),-    entity,-    read,-    buildQuery,-    all,-    all',-    get,-    get',-    write,-  )-where--import Control.Monad.IO.Class (MonadIO (..))-import Data.Aztecs.World (Component, Entity, World (..))-import Data.Aztecs.World.Archetypes (Archetype, ArchetypeId, ArchetypeState (..), archetype)-import qualified Data.Aztecs.World.Archetypes as A-import Data.Foldable (foldrM)-import qualified Data.Map as Map-import Data.Set (Set)-import Data.Typeable-import Prelude hiding (all, read)---- | Component IDs to read and write.-data ReadWrites = ReadWrites (Set TypeRep) (Set TypeRep)--instance Semigroup ReadWrites where-  ReadWrites rs ws <> ReadWrites rs' ws' = ReadWrites (rs <> rs') (ws <> ws')--instance Monoid ReadWrites where-  mempty = ReadWrites mempty mempty---- | Builder for a `Query`.-data Query m a where-  PureQ :: a -> Query m a-  MapQ :: (a -> b) -> Query m a -> Query m b-  AppQ :: Query m (a -> b) -> Query m a -> Query m b-  BindQ :: Query m a -> (a -> Query m b) -> Query m b-  EntityQ :: Query m Entity-  ReadQ :: (Component c) => Archetype -> Query m c-  WriteQ :: (Component c) => (c -> c) -> Archetype -> Query m c-  LiftQ :: m a -> Query m a--instance Functor (Query m) where-  fmap = MapQ--instance Applicative (Query m) where-  pure = PureQ-  (<*>) = AppQ--instance Monad (Query m) where-  (>>=) = BindQ--entity :: Query m Entity-entity = EntityQ---- | Read a `Component`.-read :: forall m c. (Component c) => Query m c-read = ReadQ (archetype @c)---- | Alter a `Component`.-write :: forall m c. (Component c) => (c -> c) -> Query m c-write c = WriteQ c (archetype @c)--buildQuery :: Query m a -> Archetype-buildQuery (PureQ _) = mempty-buildQuery (MapQ _ qb) = buildQuery qb-buildQuery (AppQ f a) = buildQuery f <> buildQuery a-buildQuery EntityQ = mempty-buildQuery (ReadQ a) = a-buildQuery (WriteQ _ a) = a-buildQuery (BindQ a _) = buildQuery a-buildQuery (LiftQ _) = mempty--all :: (MonadIO m) => ArchetypeId -> Query m a -> World -> m [a]-all a qb w@(World _ as) = case A.getArchetype a as of-  Just s -> all' s qb w-  Nothing -> return []--all' :: (MonadIO m) => ArchetypeState -> Query m a -> World -> m [a]-all' es@(ArchetypeState _ m _) q w =-  foldrM-    ( \e acc -> do-        a <- get' e es q w-        return $ case a of-          Just a' -> (a' : acc)-          Nothing -> acc-    )-    []-    (Map.keys m)--get :: (MonadIO m) => ArchetypeId -> Query m a -> Entity -> World -> m (Maybe a)-get a qb e w@(World _ as) = case A.getArchetype a as of-  Just s -> get' e s qb w-  Nothing -> return Nothing--get' :: (MonadIO m) => Entity -> ArchetypeState -> Query m a -> World -> m (Maybe a)-get' _ _ (PureQ a) _ = return $ Just a-get' e es (MapQ f qb) w = do-  a <- get' e es qb w-  return $ fmap f a-get' e es (AppQ fqb aqb) w = do-  f <- get' e es fqb w-  a <- get' e es aqb w-  return $ f <*> a-get' e _ EntityQ _ = return $ Just e-get' e (ArchetypeState _ m _) (ReadQ _) _ = return $ do-  cs <- Map.lookup e m-  (c, _) <- A.getArchetypeComponent cs-  return c-get' e (ArchetypeState _ m _) (WriteQ f _) _ = do-  let res = do-        cs <- Map.lookup e m-        A.getArchetypeComponent cs-  case res of-    Just (c, g) -> do-      let c' = f c-      liftIO $ g c'-      return $ Just c'-    Nothing -> return Nothing-get' e es (BindQ qb f) w = do-  a <- get' e es qb w-  case a of-    Just a' -> get' e es (f a') w-    Nothing -> return Nothing-get' _ _ (LiftQ a) _ = fmap Just a+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Aztecs.Query
+  ( Query (..),
+    (<?>),
+    fetch,
+    all,
+    allWorld,
+    map,
+    mapWorld,
+    mapWith,
+  )
+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 qualified Data.Aztecs.Entity as E
+import Data.Aztecs.World (World (..))
+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)
+
+-- | Query into the `World`.
+newtype Query a
+  = Query {runQuery' :: Components -> (Set ComponentID, Archetype -> ([Entity a], [Entity a] -> Archetype -> Archetype))}
+
+(<?>) ::
+  (E.Split a (ConcatT a b), E.SplitT a (ConcatT a b) ~ b) =>
+  Query a ->
+  Query b ->
+  Query (ConcatT a b)
+(Query a) <?> (Query b) = Query $ \cs ->
+  let (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
+              )
+      )
+
+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
+              )
+      )
+
+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)))
+
+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 -> []
+
+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)
+
+class ToQuery a where
+  query :: Query a
+
+instance ToQuery '[] where
+  query = Query $ const (Set.empty, const ([], \_ arch' -> arch'))
+
+instance {-# OVERLAPPING #-} (Component a, Typeable (StorageT a)) => ToQuery '[a] where
+  query = fetch @a
+
+instance (Component a, Typeable (StorageT a), ToQuery as) => ToQuery (a ': as) where
+  query = fetch @a <?> query @as
+
+mapWorld ::
+  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
+  ) =>
+  (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 ::
+  forall m i o.
+  ( Monad m,
+    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
+  ) =>
+  (i -> o) ->
+  Access m [o]
+map f = Access $ do
+  w <- get
+  let (out, w') = mapWorld @i @o f w
+  put w'
+  return out

@@ -1,207 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.Schedule-  ( Node (..),-    Schedule (..),-    ScheduleNode (..),-    runSchedule,-    Startup,-    Update,-    Constraint (..),-    before,-    after,-    Scheduler (..),-    schedule,-    SchedulerGraph (..),-    buildScheduler,-    runSchedulerGraph,-    runScheduler,-  )-where--import Control.Concurrent.Async (mapConcurrently)-import Control.Monad.State (StateT (runStateT))-import Data.Aztecs.Command-import Data.Aztecs.System-import Data.Aztecs.World-  ( World,-    newWorld,-    union,-  )-import Data.Foldable (foldrM)-import Data.Functor ((<&>))-import Data.List (groupBy, sortBy)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Proxy-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Typeable-import Prelude hiding (all, read)--data Constraint = Before TypeRep | After TypeRep--before :: forall m a. (System m a) => Constraint-before = Before $ typeOf (Proxy :: Proxy a)--after :: forall m a. (System m a) => Constraint-after = After $ typeOf (Proxy :: Proxy a)--data Node m where-  Node :: (System m a) => Proxy a -> Cache -> Node m--data ScheduleNode m = ScheduleNode (Node m) [Constraint]--data Schedule m = Schedule (Map TypeRep (ScheduleNode m))--instance Semigroup (Schedule m) where-  Schedule a <> Schedule b = Schedule $ a <> b--instance Monoid (Schedule m) where-  mempty = Schedule mempty--data GraphNode m = GraphNode (Node m) (Set TypeRep) (Set TypeRep)--build :: (Monad m) => Schedule m -> [[GraphNode m]]-build (Schedule s) =-  let graph =-        fmap-          ( \(ScheduleNode node constraints) ->-              let (deps, befores) =-                    foldr-                      ( \c (depAcc, afterAcc) -> case c of-                          Before i -> (depAcc, [i])-                          After i -> (depAcc ++ [i], afterAcc)-                      )-                      ([], [])-                      constraints-               in GraphNode node (Set.fromList deps) (Set.fromList befores)-          )-          s-      graph' =-        foldr-          ( \(GraphNode _ _ befores) acc ->-              foldr-                ( \i acc' ->-                    Map.adjust-                      ( \(GraphNode n deps bs) ->-                          GraphNode n (Set.singleton i <> deps) bs-                      )-                      i-                      acc'-                )-                acc-                befores-          )-          graph-          graph-      nodes =-        sortBy-          ( \(GraphNode _ deps _) (GraphNode _ deps' _) ->-              compare (length deps') (length deps)-          )-          (Map.elems graph')-   in groupBy-        ( \(GraphNode a deps aBefores) (GraphNode b deps' bBefores) ->-            (length deps == length deps')-            -- TODO || hasConflict (GraphNode a deps aBefores) (GraphNode b deps' bBefores)-        )-        nodes--runNode :: Node IO -> World -> IO (Node IO, Maybe (Access IO ()), [Command IO ()], World)-runNode (Node p cache) w =-  runSystemProxy p cache w <&> (\(next, a', cmds, w') -> (Node p a', next, cmds, w'))--runSystemProxy :: forall a. (System IO a) => Proxy a -> Cache -> World -> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)-runSystemProxy _ = runSystem' @a---- | Run a `Command`, returning any temporary `Entity`s and the updated `World`.-runCommand :: Command IO () -> World -> IO (World)-runCommand (Command cmd) w = snd <$> runStateT cmd w--runSchedule :: [[GraphNode IO]] -> World -> IO ([[GraphNode IO]], World)-runSchedule nodes w =-  foldrM-    ( \nodeGroup (nodeAcc, w') -> do-        results <--          mapConcurrently-            ( \(GraphNode n as bs) -> do-                (n', next, cmds, w'') <- runNode n w-                return ((next, (GraphNode n' as bs)), cmds, w'')-            )-            nodeGroup-        let (nexts, cmdLists, worlds) =-              foldr-                ( \(n, b, c) (ns, bs, cs) ->-                    (n : ns, b : bs, c : cs)-                )-                ([], [], [])-                results-            finalWorld = foldr union w' worlds-            (cmds, w'') = (concat cmdLists, finalWorld)--        (w''', nodes', cmds') <--          foldrM-            ( \(a, (GraphNode (Node p cache) as bs)) (wAcc, nodeAcc', cmdAcc) -> case a of-                Just a' -> do-                  ((), wAcc', cache', cmdAcc') <- runAccess' a' wAcc cache-                  return (wAcc', (GraphNode (Node p cache') as bs) : nodeAcc', cmdAcc' ++ cmdAcc)-                Nothing -> return (w, (GraphNode (Node p cache) as bs) : nodeAcc', cmdAcc)-            )-            (w'', [], [])-            nexts--        w'''' <- foldrM (\cmd wAcc -> runCommand cmd wAcc) w''' (cmds ++ cmds')-        return (nodes' : nodeAcc, w'''')-    )-    ([], w)-    nodes--newtype Scheduler m = Scheduler (Map TypeRep (Schedule m))-  deriving (Monoid)--instance Semigroup (Scheduler m) where-  Scheduler a <> Scheduler b = Scheduler $ Map.unionWith (<>) a b--data Startup--data Update--schedule :: forall l m s. (Typeable l, System m s) => [Constraint] -> Scheduler m-schedule cs =-  Scheduler $-    Map.singleton-      (typeOf (Proxy :: Proxy l))-      ( Schedule $-          Map.singleton-            (typeOf (Proxy :: Proxy s))-            (ScheduleNode (Node (Proxy :: Proxy s) mempty) cs)-      )--newtype SchedulerGraph m = SchedulerGraph (Map TypeRep [[GraphNode m]])--buildScheduler :: (Monad m) => Scheduler m -> SchedulerGraph m-buildScheduler (Scheduler s) = SchedulerGraph $ fmap build s--runSchedulerGraph :: forall l. (Typeable l) => SchedulerGraph IO -> World -> IO (SchedulerGraph IO, World)-runSchedulerGraph (SchedulerGraph g) w = case Map.lookup (typeOf (Proxy :: Proxy l)) g of-  Just s -> do-    (nodes, w') <- runSchedule s w-    let g' = Map.insert (typeOf (Proxy :: Proxy l)) nodes g-    return (SchedulerGraph g', w')-  Nothing -> return (SchedulerGraph g, w)--runScheduler :: Scheduler IO -> IO ()-runScheduler s = do-  let g = buildScheduler s-  (g', w) <- runSchedulerGraph @Startup g newWorld-  let go gAcc wAcc = do-        (gAcc', wAcc') <- runSchedulerGraph @Update gAcc wAcc-        go gAcc' wAcc'-  go g' w

@@ -1,65 +1,25 @@-module Data.Aztecs.Storage (Storage (..), table, table') where--import Control.Monad (filterM)-import Data.Aztecs.Core-import Data.Functor ((<&>))-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.List (find)--data Storage a = Storage-  { empty :: IO (Storage a),-    spawn :: Entity -> a -> IO (Storage a),-    get :: Entity -> IO (Maybe (a, a -> Storage a -> IO (Storage a))),-    toList :: IO [EntityComponent a],-    toList' :: IO [(EntityComponent a, a -> IO ())],-    remove :: Entity -> IO (Storage a)-  }--table' :: [IORef (EntityComponent a)] -> Storage a-table' cs =-  Storage-    { empty = pure $ table' [],-      spawn = \e a -> do-        r <- newIORef (EntityComponent e a)-        return $ table' (r : cs),-      get = \e -> do-        cs' <--          mapM-            ( \r -> do-                a <- readIORef r-                return (a, r)-            )-            cs-        return-          ( find (\(EntityComponent e' _, _) -> e == e') cs'-              <&> \(EntityComponent _ a, r) ->-                ( a,-                  \a' t -> do-                    writeIORef r (EntityComponent e a')-                    return t-                )-          ),-      toList = mapM readIORef cs,-      toList' =-        mapM-          ( \r -> do-              (EntityComponent e a) <- readIORef r-              return-                ( (EntityComponent e a),-                  \a' -> writeIORef r (EntityComponent e a')-                )-          )-          cs,-      remove = \e -> do-        cs' <--          filterM-            ( \r -> do-                (EntityComponent e' _) <- readIORef r-                return $ e /= e'-            )-            cs-        return $ table' cs'-    }--table :: Storage a-table = table' []+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Data.Aztecs.Storage (Storage(..)) where
+
+import Data.Data (Typeable)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+
+class (Typeable (s a), Typeable a) => Storage s a where
+  singleton :: Int -> a -> s a
+  all :: s a -> [(Int, a)]
+  insert :: Int -> a -> s a -> s a
+  lookup :: Int -> s a -> Maybe a
+  fromAscList :: [(Int, a)] -> s a
+  remove :: Int -> s a -> (Maybe a, s a)
+
+instance (Typeable a) => Storage IntMap a where
+  singleton = IntMap.singleton
+  all = IntMap.toList
+  insert = IntMap.insert
+  lookup = IntMap.lookup
+  fromAscList = IntMap.fromAscList
+  remove i s = (IntMap.lookup i s, IntMap.delete i s) -- TODO remove double lookup

@@ -1,218 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.System-  ( Access (..),-    runAccess,-    runAccess',-    all,-    get,-    command,-    System (..),-    runSystem,-    runSystem',-    Cache (..),-  )-where--import Control.Monad.IO.Class-import Data.Aztecs.Command-import Data.Aztecs.Query (Query (..))-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.World (Entity, World (..))-import Data.Aztecs.World.Archetypes (Archetype, ArchetypeId)-import qualified Data.Aztecs.World.Archetypes as A-import Data.Foldable (foldrM)-import Data.Kind-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Typeable-import Prelude hiding (all, read)--newtype Cache = Cache (Map Archetype ArchetypeId)-  deriving (Semigroup, Monoid)--data Access (m :: Type -> Type) a where-  PureA :: a -> Access m a-  MapA :: (a -> b) -> Access m a -> Access m b-  AppA :: Access m (a -> b) -> Access m a -> Access m b-  BindA :: Access m a -> (a -> Access m b) -> Access m b-  AllA :: Archetype -> Query m a -> Access m [a]-  GetA :: Archetype -> Query m a -> Entity -> Access m (Maybe a)-  CommandA :: Command m () -> Access m ()-  LiftA :: m a -> Access m a--instance Functor (Access m) where-  fmap = MapA--instance (Monad m) => Applicative (Access m) where-  pure = PureA-  (<*>) = AppA--instance (Monad m) => Monad (Access m) where-  (>>=) = BindA--instance (MonadIO m) => MonadIO (Access m) where-  liftIO io = LiftA (liftIO io)--runAccess :: Access IO a -> World -> Cache -> IO (Either (Access IO a) a, World, Cache, [Command IO ()])-runAccess (PureA a) w c = return (Right a, w, c, [])-runAccess (MapA f a) w cache = do-  (a', w', cache', cmds) <- runAccess a w cache-  return-    ( case a' of-        Left a'' -> Left (MapA f a'')-        Right a'' -> Right (f a''),-      w',-      cache',-      cmds-    )-runAccess (AppA f a) w cache = do-  (f', w', cache', cmds) <- runAccess f w cache-  (a', w'', cache'', cmds') <- runAccess a w' cache'-  return-    ( case (f', a') of-        (Right f'', Right a'') -> Right (f'' a'')-        (Left f'', _) -> Left (AppA f'' a)-        (_, Left a'') -> Left (AppA f a''),-      w'',-      cache'',-      cmds ++ cmds'-    )-runAccess (BindA a f) w cache = do-  (a', w', cache', cmds) <- runAccess a w cache-  case a' of-    Left a'' -> return (Left (BindA a'' f), w', cache', cmds)-    Right a'' -> runAccess (f a'') w' cache'-runAccess (AllA a qb) w (Cache cache) = case Map.lookup (Q.buildQuery qb) cache of-  Just aId -> do-    es <- Q.all aId qb w-    return (Right es, w, Cache cache, [])-  Nothing -> return (Left (AllA a qb), w, Cache cache, [])-runAccess (GetA arch q e) w (Cache cache) = do-  case Map.lookup arch cache of-    Just aId -> do-      a <- Q.get aId q e w-      return (Right a, w, Cache cache, [])-    Nothing -> return (Left (GetA arch q e), w, Cache cache, [])-runAccess (CommandA cmd) w cache = return (Right (), w, cache, [cmd])-runAccess (LiftA io) w cache = do-  a <- liftIO io-  return (Right a, w, cache, [])--runAccess' :: Access IO a -> World -> Cache -> IO (a, World, Cache, [Command IO ()])-runAccess' (PureA a) w c = return (a, w, c, [])-runAccess' (MapA f a) w cache = do-  (a', w', cache', cmds) <- runAccess' a w cache-  return (f a', w', cache', cmds)-runAccess' (AppA f a) w cache = do-  (f', w', cache', cmds) <- runAccess' f w cache-  (a', w'', cache'', cmds') <- runAccess' a w' cache'-  return (f' a', w'', cache'', cmds ++ cmds')-runAccess' (BindA a f) w cache = do-  (a', w', cache', cmds) <- runAccess' a w cache-  (b, w'', cache'', cmds') <- runAccess' (f a') w' cache'-  return (b, w'', cache'', cmds ++ cmds')-runAccess' (AllA _ qb) (World cs as) (Cache cache) = do-  (aId, w) <- case Map.lookup (Q.buildQuery qb) cache of-    Just q' -> return (q', World cs as)-    Nothing -> do-      (x, as') <- A.insertArchetype (Q.buildQuery qb) cs as-      return (x, World cs as')-  es <- Q.all aId qb w-  return (es, w, Cache cache, [])-runAccess' (GetA arch q e) (World cs as) (Cache cache) = do-  (aId, w) <- case Map.lookup arch cache of-    Just q' -> return (q', World cs as)-    Nothing -> do-      (x, as') <- A.insertArchetype arch cs as-      return (x, World cs as')-  a <- Q.get aId q e w-  return (a, w, Cache cache, [])-runAccess' (CommandA cmd) w cache = return ((), w, cache, [cmd])-runAccess' (LiftA io) w cache = do-  a <- liftIO io-  return (a, w, cache, [])---- | Query all matches.-all :: (Monad m) => Query m a -> Access m [a]-all q = fst <$> all' mempty q--all' :: (Monad m) => Archetype -> Query m a -> Access m ([a], Archetype)-all' arch (PureQ a) = pure ([a], arch)-all' arch (MapQ f a) = all' arch (f <$> a)-all' arch (AppQ f a) = all' arch (f <*> a)-all' arch (BindQ a f) = do-  (a', arch') <- all' arch a-  foldrM-    ( \q (acc, archAcc) -> do-        (as, archAcc') <- all' archAcc (f q)-        return (as ++ acc, archAcc')-    )-    ([], arch')-    a'-all' arch (LiftQ m) = do-  a <- LiftA m-  return ([a], arch)-all' arch (ReadQ arch') = do-  let arch'' = (arch <> arch')-  as <- AllA arch'' (ReadQ arch')-  return (as, arch'')-all' arch (WriteQ f arch') = do-  let arch'' = (arch <> arch')-  as <- AllA arch'' (WriteQ f arch')-  return (as, arch'')-all' arch EntityQ = do-  es <- AllA arch EntityQ-  return (es, arch)--get :: (Monad m) => Entity -> Query m a -> Access m (Maybe a)-get e q = fst <$> get' mempty e q--get' :: (Monad m) => Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)-get' arch _ (PureQ a) = pure (Just a, arch)-get' arch e (MapQ f qb) = get' arch e (f <$> qb)-get' arch e (AppQ f a) = get' arch e (f <*> a)-get' arch e (BindQ a f) = do-  (a', arch') <- get' arch e a-  case fmap f a' of-    Just a'' -> get' arch' e a''-    Nothing -> return (Nothing, arch')-get' arch _ (LiftQ m) = do-  a <- LiftA m-  return (Just a, arch)-get' arch e (ReadQ arch') = do-  let arch'' = (arch <> arch')-  a <- GetA arch'' (ReadQ arch') e-  return (a, arch'')-get' arch e (WriteQ f arch') = do-  let arch'' = (arch <> arch')-  a <- GetA arch'' (WriteQ f arch') e-  return (a, arch'')-get' arch e EntityQ = return (Just e, arch)--command :: Command m () -> Access m ()-command = CommandA--class (Typeable a) => System m a where-  access :: Access m ()--runSystem :: forall a. (System IO a) => World -> IO World-runSystem w = do-  (_, _, _, w') <- runSystem' @a (Cache mempty) w-  return w'--runSystem' :: forall a. (System IO a) => Cache -> World -> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)-runSystem' cache w = do-  (result, w', cache', cmds) <- runAccess (access @IO @a) w cache-  case result of-    Left a -> return (Just a, cache', cmds, w')-    Right _ -> return (Nothing, cache', cmds, w')

@@ -1,29 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Data.Aztecs.Task-  ( Task (..),-    command,-    runTask,-  )-where--import Control.Monad.IO.Class-import Control.Monad.State (StateT (..))-import qualified Control.Monad.State as S-import Data.Aztecs.Command-import Data.Aztecs.World (World)-import Prelude hiding (all)---- | System task.-newtype Task m s a = Task (StateT (s, [Command m ()], World) m a)-  deriving (Functor, Applicative, Monad, MonadIO)--runTask :: (Functor m) => Task m s a -> s -> World -> m (a, s, [Command m ()], World)-runTask (Task t) s w = fmap (\(a, (s', cmds, w')) -> (a, s', cmds, w')) (S.runStateT t (s, [], w))---- | Queue a `Command` to run after this system is complete.-command :: (Monad m) => Command m () -> Task m a ()-command cmd = Task $ do-  (s, cmds, w) <- S.get-  S.put $ (s, cmds <> [cmd], w)

@@ -1,71 +1,191 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.World-  ( Entity,-    EntityComponent (..),-    Component (..),-    World (..),-    union,-    spawn,-    insert,-    get,-    getRow,-    newWorld,-    setRow,-    remove,-  )-where--import Data.Aztecs.Core-import Data.Aztecs.Storage (Storage)-import Data.Aztecs.World.Archetypes (Archetypes, newArchetypes)-import qualified Data.Aztecs.World.Archetypes as A-import Data.Aztecs.World.Components (Component, Components, newComponents)-import qualified Data.Aztecs.World.Components as C-import Data.Typeable-import Prelude hiding (read)--data World = World Components Archetypes deriving (Show)--newWorld :: World-newWorld = World newComponents newArchetypes--union :: World -> World -> World-union (World cs as) (World cs' _) = World (C.union cs cs') as--spawn :: forall c. (Component c) => c -> World -> IO (Entity, World)-spawn c (World cs as) = do-  (e, cs') <- C.spawn c cs -  return (e, World cs' as)--insert :: forall c. (Component c) => Entity -> c -> World -> IO World-insert e c (World cs as) = do-  cs' <- C.insert e c cs-  return $ World cs' (A.insert @c e cs' as)--getRow :: (Component c) => Proxy c -> World -> Maybe (Storage c)-getRow p (World cs _) = C.getRow p cs--get :: forall c. (Component c) => Entity -> World -> IO (Maybe (c, c -> World -> IO World))-get e (World cs _) = do-  res <- C.get e cs-  case res of-    Just (c, f) ->-      return $-        Just-          ( c,-            \c' (World cs' as) -> do-              cs'' <- f c' cs'-              return $ World cs'' as-          )-    Nothing -> return Nothing--setRow :: forall c. (Component c) => Storage c -> World -> World-setRow row (World cs as) = World (C.setRow row cs) as--remove :: forall c. (Component c) => Entity -> World -> World-remove e (World cs as) = World (C.remove @c e cs) as+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Data.Aztecs.World
+  ( ArchetypeID (..),
+    World (..),
+    empty,
+    spawn,
+    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.Dynamic (Dynamic)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+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,
+    components :: Components,
+    entities :: Map EntityID ArchetypeID,
+    nextEntityId :: EntityID
+  }
+  deriving (Show)
+
+-- | Empty `World`.
+empty :: World
+empty =
+  World
+    { archetypes = mempty,
+      archetypeIds = mempty,
+      archetypeComponents = mempty,
+      nextArchetypeId = ArchetypeID 0,
+      components = emptyComponents,
+      entities = mempty,
+      nextEntityId = EntityID 0
+    }
+
+-- | 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
+  Just cId -> spawnWithId cId c w
+  Nothing ->
+    let (cId, cs) = insertComponentId @a (components w)
+     in spawnWithId cId c w {components = cs}
+
+-- | Spawn an empty entity.
+spawnEmpty :: World -> (EntityID, World)
+spawnEmpty w = let e = nextEntityId w in (e, w {nextEntityId = EntityID (unEntityId e + 1)})
+
+-- | Spawn an entity with a component and its `ComponentID`.
+spawnWithId ::
+  forall a.
+  (Component a, Typeable (StorageT a)) =>
+  ComponentID ->
+  a ->
+  World ->
+  (EntityID, World)
+spawnWithId cId c w =
+  let (e, w') = spawnEmpty w
+   in case Map.lookup (Set.singleton cId) (archetypeIds 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)}
+          )
+
+-- | Spawn an entity with a component and its `ComponentID` directly into an archetype.
+spawnWithArchetypeId ::
+  forall a.
+  (Component a, Typeable (StorageT a)) =>
+  a ->
+  ComponentID ->
+  ArchetypeID ->
+  World ->
+  (EntityID, World)
+spawnWithArchetypeId c cId aId w =
+  let (e, w') = spawnEmpty w
+   in (e, spawnWithArchetypeId' e aId cId c w')
+
+spawnWithArchetypeId' ::
+  forall a.
+  (Component a, Typeable (StorageT a)) =>
+  EntityID ->
+  ArchetypeID ->
+  ComponentID ->
+  a ->
+  World ->
+  World
+spawnWithArchetypeId' e aId cId c w =
+  let f = A.insert e cId c
+   in w
+        { archetypes = Map.adjust f aId (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 :: forall a. (Component a, Typeable (StorageT a)) => EntityID -> a -> World -> World
+insert e c w =
+  let (cId, components') = insertComponentId @a (components w)
+   in insertWithId e cId c w {components = components'}
+
+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 =
+                            Map.adjust
+                              (\nextArch -> foldr f nextArch (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'
+    Nothing -> w
+  Nothing -> w
+
+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)
+   in case res of
+        Just (aId, arch) ->
+          let (dynAcc, arch') = A.remove e arch
+           in ( dynAcc,
+                w
+                  { archetypes = Map.insert aId arch' (archetypes w),
+                    entities = Map.delete e (entities w)
+                  }
+              )
+        Nothing -> (Map.empty, w)

@@ -1,181 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.World.Archetypes-  ( Archetype (..),-    ArchetypeComponent (..),-    ArchetypeComponents (..),-    getArchetypeComponent,-    ArchetypeState (..),-    ArchetypeId (..),-    Archetypes (..),-    newArchetypes,-    archetype,-    insertArchetype,-    getArchetype,-    insert,-  )-where--import Data.Aztecs.Core-import qualified Data.Aztecs.Storage as S-import Data.Aztecs.World.Components (Component, Components, getRow)-import qualified Data.Aztecs.World.Components as C-import Data.Dynamic (Dynamic, fromDynamic, toDyn)-import Data.Foldable (foldrM)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe, isJust)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Typeable-import Prelude hiding (read)--data ArchetypeComponent where-  ArchetypeComponent :: (Component c) => Proxy c -> ArchetypeComponent--instance Eq ArchetypeComponent where-  ArchetypeComponent a == ArchetypeComponent b = typeOf a == typeOf b--instance Ord ArchetypeComponent where-  ArchetypeComponent a `compare` ArchetypeComponent b = typeOf a `compare` typeOf b--instance Show ArchetypeComponent where-  show (ArchetypeComponent p) = show (typeOf p)--newtype Archetype = Archetype (Set ArchetypeComponent)-  deriving (Eq, Ord, Show, Monoid, Semigroup)--archetype :: forall c. (Component c) => Archetype-archetype = Archetype . Set.singleton $ ArchetypeComponent (Proxy @c)--newtype ArchetypeId = ArchetypeId Int deriving (Eq, Ord, Show)--newtype ArchetypeComponents = ArchetypeComponents (Map TypeRep Dynamic)-  deriving (Show)--getArchetypeComponent :: forall c. (Component c) => ArchetypeComponents -> Maybe (c, c -> IO ())-getArchetypeComponent (ArchetypeComponents m) = do-  d <- Map.lookup (typeOf (Proxy @c)) m-  fromDynamic d--insertArchetypeComponent :: forall c. (Component c) => c -> (c -> IO ()) -> ArchetypeComponents -> ArchetypeComponents-insertArchetypeComponent c f (ArchetypeComponents m) = ArchetypeComponents $ Map.insert (typeOf (Proxy @c)) (toDyn (c, f)) m--data ArchetypeState = ArchetypeState Archetype (Map Entity ArchetypeComponents) [ArchetypeId]-  deriving (Show)--data Archetypes-  = Archetypes-      (IntMap ArchetypeState)-      (Map TypeRep [ArchetypeId])-      (Map Archetype ArchetypeId)-      Int-  deriving (Show)--newArchetypes :: Archetypes-newArchetypes = Archetypes IntMap.empty Map.empty Map.empty 0--insertArchetype :: Archetype -> Components -> Archetypes -> IO (ArchetypeId, Archetypes)-insertArchetype (Archetype a) w (Archetypes es ids as i) = case Map.lookup (Archetype a) as of-  Just (ArchetypeId i') -> return (ArchetypeId i, Archetypes es ids as i')-  Nothing -> do-    (es', ids') <--      foldrM-        ( \(ArchetypeComponent p) (eAcc, acc) -> do-            cs <- fromMaybe (pure []) $ fmap (\s -> S.toList' s) (getRow p w)-            let eAcc' = map (\(EntityComponent e c, f) -> (e, insertArchetypeComponent c f (ArchetypeComponents mempty))) cs-            return (eAcc' ++ eAcc, Map.unionWith (<>) (Map.singleton (typeOf p) [ArchetypeId i]) acc)-        )-        ([], ids)-        (Set.toList a)-    return (ArchetypeId i, Archetypes (IntMap.insert i (ArchetypeState (Archetype a) (Map.fromList es') []) es) ids' as (i + 1))--getArchetype :: ArchetypeId -> Archetypes -> Maybe ArchetypeState-getArchetype (ArchetypeId i) (Archetypes es _ _ _) = IntMap.lookup i es--insert :: forall c. (Component c) => Entity -> Components -> Archetypes -> Archetypes-insert e cs (Archetypes es ids as j) = case Map.lookup (typeOf (Proxy @c)) ids of-  Just (ids') ->-    let insertInArchetype :: Int -> IntMap ArchetypeState -> IntMap ArchetypeState-        insertInArchetype archetypeId acc =-          IntMap.alter (updateArchetypeState archetypeId) archetypeId acc--        updateArchetypeState :: Int -> Maybe ArchetypeState -> Maybe ArchetypeState-        updateArchetypeState _ state = case state of-          Just (ArchetypeState arch esAcc deps) ->-            let isMatch =-                  all-                    (\(ArchetypeComponent p) -> isJust $ C.getRow p cs)-                    (Set.toList $ unwrapArchetype arch)-             in if isMatch-                  then-                    Just $ ArchetypeState arch (Map.singleton e (ArchetypeComponents mempty) <> esAcc) deps-                  else state-          Nothing -> state--        updateDependencies :: Int -> IntMap ArchetypeState -> IntMap ArchetypeState-        updateDependencies archetypeId acc = case IntMap.lookup archetypeId acc of-          Just (ArchetypeState _ _ deps) -> foldr updateDependencies (insertInArchetype archetypeId acc) (map getArchetypeId deps)-          Nothing -> acc-        es' = foldr updateDependencies es (map getArchetypeId ids')-     in merge $ Archetypes es' ids as j-  Nothing -> Archetypes es ids as j--merge :: Archetypes -> Archetypes-merge archetypes@(Archetypes es _ _ _) =-  foldl processArchetype archetypes (IntMap.toList es)-  where-    processArchetype :: Archetypes -> (Int, ArchetypeState) -> Archetypes-    processArchetype acc (parentId, ArchetypeState parentArch _ _) =-      foldl (updateDependency parentId parentArch) acc (IntMap.toList es)--    updateDependency :: Int -> Archetype -> Archetypes -> (Int, ArchetypeState) -> Archetypes-    updateDependency parentId parentArch acc (childId, ArchetypeState childArch _ _) =-      let parentComponents = unwrapArchetype parentArch-          childComponents = unwrapArchetype childArch-       in if childId /= parentId && Set.isSubsetOf childComponents parentComponents-            then mergeWithDeps (ArchetypeId parentId) (ArchetypeId childId) acc-            else acc--mergeWithDeps :: ArchetypeId -> ArchetypeId -> Archetypes -> Archetypes-mergeWithDeps parentId childId (Archetypes es ids as nextId) =-  case (IntMap.lookup (getArchetypeId parentId) es, IntMap.lookup (getArchetypeId childId) es) of-    (Just (ArchetypeState parentArch parentEntities parentDeps), Just (ArchetypeState childArch childEntities childDeps)) ->-      let parentComponents = unwrapArchetype parentArch-          childComponents = unwrapArchetype childArch--          adjustedChildComponents = Set.intersection parentComponents childComponents-          adjustedChildArch = Archetype adjustedChildComponents--          (childId', updatedEs, updatedAs, newNextId) =-            if adjustedChildComponents == childComponents-              then (childId, es, as, nextId)-              else case Map.lookup adjustedChildArch as of-                Just existingId -> (existingId, es, as, nextId)-                Nothing ->-                  let newChildId = ArchetypeId nextId-                      newState = ArchetypeState adjustedChildArch childEntities childDeps-                   in ( newChildId,-                        IntMap.insert nextId newState es,-                        Map.insert adjustedChildArch newChildId as,-                        nextId + 1-                      )--          updatedParentDeps = childId' : parentDeps-          updatedParentState = ArchetypeState parentArch parentEntities updatedParentDeps-          finalEs = IntMap.insert (getArchetypeId parentId) updatedParentState updatedEs-       in Archetypes finalEs ids updatedAs newNextId-    _ -> Archetypes es ids as nextId--getArchetypeId :: ArchetypeId -> Int-getArchetypeId (ArchetypeId x) = x--unwrapArchetype :: Archetype -> Set ArchetypeComponent-unwrapArchetype (Archetype set) = set

@@ -1,87 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Data.Aztecs.World.Components-  ( Component (..),-    Components,-    union,-    spawn,-    insert,-    adjust,-    get,-    getRow,-    newComponents,-    setRow,-    remove,-  )-where--import Data.Aztecs.Core-import Data.Aztecs.Storage (Storage, table)-import qualified Data.Aztecs.Storage as S-import Data.Dynamic (Dynamic, fromDynamic, toDyn)-import Data.Map (Map, alter, empty, lookup)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.Typeable-import Prelude hiding (read)--class (Typeable a) => Component a where-  storage :: Storage a-  storage = table--data Components = Components (Map TypeRep Dynamic) Entity deriving (Show)--newComponents :: Components-newComponents = Components empty (Entity 0)--union :: Components -> Components -> Components-union (Components a e) (Components b _) = Components (Map.union a b) e--spawn :: forall c. (Component c) => c -> Components -> IO (Entity, Components)-spawn c (Components w (Entity e)) = do-  w' <- insert (Entity e) c (Components w (Entity $ e + 1))-  return (Entity e, w')--insert :: forall c. (Component c) => Entity -> c -> Components -> IO Components-insert e c (Components w e') = do-  w' <--    Map.alterF-      ( \maybeRow -> do-          s <- S.spawn (fromMaybe storage (maybeRow >>= fromDynamic)) e c-          return . Just $ toDyn s-      )-      (typeOf (Proxy :: Proxy c))-      w-  return $ Components w' e'--adjust :: (Component c) => c -> (c -> c) -> Entity -> Components -> IO Components-adjust a f w = insert w (f a)--getRow :: (Component c) => Proxy c -> Components -> Maybe (Storage c)-getRow p (Components w _) = Data.Map.lookup (typeOf p) w >>= fromDynamic--get :: forall c. (Component c) => Entity -> Components -> IO (Maybe (c, c -> Components -> IO Components))-get e (Components w _) = case Data.Map.lookup (typeOf @(Proxy c) Proxy) w >>= fromDynamic of-  Just s -> do-    res <- S.get s e-    case res of-      Just (c, f) ->-        return $-          Just-            ( c,-              \c' (Components w' e') ->-                return $ Components (alter (\row -> Just . toDyn $ f c' (fromMaybe storage (row >>= fromDynamic))) (typeOf @(Proxy c) Proxy) w') e'-            )-      Nothing -> return Nothing-  Nothing -> return Nothing--setRow :: forall c. (Component c) => Storage c -> Components -> Components-setRow cs (Components w e') = Components (Map.insert (typeOf @(Proxy c) Proxy) (toDyn cs) w) e'--remove :: forall c. (Component c) => Entity -> Components -> Components-remove e (Components w e') = Components (alter (\row -> row >>= f) (typeOf @(Proxy c) Proxy) w) e'-  where-    f row = fmap (\row' -> toDyn $ S.remove @c row' e) (fromDynamic row)

@@ -1,4 +1,14 @@-module Main (main) where--main :: IO ()-main = putStrLn "Test suite not yet implemented."+module Main (main) where
+
+import Data.Aztecs
+
+newtype X = X Int deriving (Eq, Show)
+
+instance Component X
+
+newtype Y = Y Int deriving (Eq, Show)
+
+instance Component Y
+
+main :: IO ()
+main = return ()