packages feed

aztecs 0.1.0.0 → 0.1.0.1

raw patch · 13 files changed

+1085/−16 lines, 13 filesdep +asyncdep +containersdep +mtl

Dependencies added: async, containers, mtl

Files

− CHANGELOG.md 
@@ -1,5 +0,0 @@-# Revision history for aztecs--## 0.1.0.0 -- YYYY-mm-dd--* First version. Released on an unsuspecting world.
aztecs.cabal view
@@ -1,14 +1,15 @@-cabal-version:   3.0-name:            aztecs-version:         0.1.0.0-license:         BSD-3-Clause-license-file:    LICENSE-maintainer:      matt@hunzinger.me-author:          Matt Hunzinger-build-type:      Simple-extra-doc-files: CHANGELOG.md-synopsis:        A type-safe and friendly ECS for Haskell -description:     A type-safe and friendly ECS for Haskell +cabal-version: 3.0+name:          aztecs+version:       0.1.0.1+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.Core
+ src/Data/Aztecs.hs view
@@ -0,0 +1,33 @@+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,+  )
+ src/Data/Aztecs/Command.hs view
@@ -0,0 +1,43 @@+{-# 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'
+ src/Data/Aztecs/Core.hs view
@@ -0,0 +1,5 @@+module Data.Aztecs.Core (Entity (..), EntityComponent (..)) where++newtype Entity = Entity Int deriving (Eq, Ord, Show)++data EntityComponent a = EntityComponent Entity a deriving (Show)
+ src/Data/Aztecs/Query.hs view
@@ -0,0 +1,134 @@+{-# 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
+ src/Data/Aztecs/Schedule.hs view
@@ -0,0 +1,207 @@+{-# 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
+ src/Data/Aztecs/Storage.hs view
@@ -0,0 +1,65 @@+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' []
+ src/Data/Aztecs/System.hs view
@@ -0,0 +1,218 @@+{-# 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')
+ src/Data/Aztecs/Task.hs view
@@ -0,0 +1,29 @@+{-# 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)
+ src/Data/Aztecs/World.hs view
@@ -0,0 +1,71 @@+{-# 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
+ src/Data/Aztecs/World/Archetypes.hs view
@@ -0,0 +1,181 @@+{-# 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
+ src/Data/Aztecs/World/Components.hs view
@@ -0,0 +1,87 @@+{-# 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)