aztecs 0.16.0 → 0.16.1

raw patch · 9 files changed

+83/−42 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• aztecs.cabal +1/−1
• examples/Lifecycle.hs +1/−1
• examples/Observers.hs +2/−2
• src/Aztecs/ECS.hs +10/−2
• src/Aztecs/ECS/Component.hs +2/−2
• src/Aztecs/ECS/Event.hs +4/−1
• src/Aztecs/ECS/Query.hs +20/−0
• src/Aztecs/ECS/World/Archetype.hs +26/−15
• src/Aztecs/Hierarchy.hs +17/−18

@@ -1,6 +1,6 @@ cabal-version: 2.4
 name:          aztecs
-version:       0.16.0
+version:       0.16.1
 license:       BSD-3-Clause
 license-file:  LICENSE
 maintainer:    matt@hunzinger.me

@@ -10,7 +10,7 @@ 
 instance Component IO X where
   componentOnInsert = exampleHook "insert"
-  componentOnChange = exampleHook "change"
+  componentOnChange e _ = exampleHook "change" e
   componentOnRemove = exampleHook "remove"
 
 exampleHook :: String -> EntityID -> X -> Access IO ()

@@ -22,8 +22,8 @@   -- Spawn observers that react to lifecycle events on the player's Health component
   _ <- spawn . bundle . observer @IO @(OnInsert Health) player $ \e (OnInsert h) ->
     observe "insert" e h
-  _ <- spawn . bundle . observer @IO @(OnChange Health) player $ \e (OnChange h) ->
-    observe "change" e h
+  _ <- spawn . bundle . observer @IO @(OnChange Health) player $ \e change ->
+    liftIO . putStrLn $ "change " ++ show e ++ ": old=" ++ show (onChangeOld change) ++ ", new=" ++ show (onChangeNew change)
   _ <- spawn . bundle . observer @IO @(OnRemove Health) player $ \e (OnRemove h) ->
     observe "remove" e h
 

@@ -67,7 +67,11 @@     queryMapWith,
     queryMapWith_,
     queryMapWithM,
-    DynamicQueryF,
+    queryMapAccum,
+    queryMapAccumM,
+    queryMapWithAccum,
+    queryMapWithAccumM,
+    DynamicQueryF (..),
     QueryFilter,
     with,
     without,
@@ -98,13 +102,17 @@     observerGlobal,
   )
 import Aztecs.ECS.Query
-  ( DynamicQueryF,
+  ( DynamicQueryF (..),
     Query,
     QueryFilter,
     query,
     queryMap,
+    queryMapAccum,
+    queryMapAccumM,
     queryMapM,
     queryMapWith,
+    queryMapWithAccum,
+    queryMapWithAccumM,
     queryMapWithM,
     queryMapWith_,
     queryMaybe,

@@ -36,8 +36,8 @@   {-# INLINEABLE componentOnInsert #-}
 
   -- | Lifecycle hook called when a component is changed.
-  componentOnChange :: EntityID -> a -> Access m ()
-  componentOnChange _ _ = pure ()
+  componentOnChange :: EntityID -> a -> a -> Access m ()
+  componentOnChange _ _ _ = pure ()
   {-# INLINEABLE componentOnChange #-}
 
   -- | Lifecycle hook called when a component is removed.

@@ -32,7 +32,10 @@ instance (Typeable a) => Event (OnInsert a)
 
 -- | Event triggered when a component is changed.
-newtype OnChange a = OnChange {unOnChange :: a}
+data OnChange a = OnChange
+  { onChangeOld :: a,
+    onChangeNew :: a
+  }
   deriving (Show, Eq, Generic)
 
 instance (Typeable a) => Event (OnChange a)

@@ -34,6 +34,8 @@     queryMapWith,
     queryMapWith_,
     queryMapWithM,
+    queryMapAccum,
+    queryMapAccumM,
     queryMapWithAccum,
     queryMapWithAccumM,
 
@@ -179,6 +181,24 @@   Query m b
 queryMapWithM f = queryWriter @m @b $ queryMapDynWithM f
 {-# INLINE queryMapWithM #-}
+
+-- | Query a component with input, returning a tuple of the result and the updated component.
+queryMapAccum ::
+  forall m a b.
+  (Monad m, Component m b) =>
+  (b -> (a, b)) ->
+  Query m (a, b)
+queryMapAccum f = queryMapWithAccum (const f) (pure ())
+{-# INLINE queryMapAccum #-}
+
+-- | Query a component with input and update it with a monadic action, returning a tuple.
+queryMapAccumM ::
+  forall m a b.
+  (Monad m, Component m b) =>
+  (b -> m (a, b)) ->
+  Query m (a, b)
+queryMapAccumM f = queryMapWithAccumM (const f) (pure ())
+{-# INLINE queryMapAccumM #-}
 
 -- | Query a component with input, returning a tuple of the result and the updated component.
 queryMapWithAccum ::

@@ -101,11 +101,17 @@ insertComponent ::
   forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> (Archetype m, Access m ())
 insertComponent e cId c arch =
-  let !storage =
-        S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch
-      hook = do
-        componentOnInsert e c
-        triggerEntityEvent e (OnInsert c)
+  let oldComponents = lookupComponents @m @a cId arch
+      oldValue = oldComponents Map.!? e
+      !storage =
+        S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ oldComponents
+      hook = case oldValue of
+        Just old -> do
+          componentOnChange e old c
+          triggerEntityEvent e (OnChange old c)
+        Nothing -> do
+          componentOnInsert e c
+          triggerEntityEvent e (OnInsert c)
    in (arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}, hook)
 
 -- | Insert a component into an archetype without running lifecycle hooks.
@@ -125,7 +131,8 @@ zipWith ::
   forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Vector c, Archetype m, Access m ())
 zipWith as f cId arch =
-  let go maybeDyn = case maybeDyn of
+  let oldCs = lookupComponentsAsc @m @c cId arch
+      go maybeDyn = case maybeDyn of
         Just dyn -> case fromDynamic $ storageDyn dyn of
           Just s -> do
             let !(cs', s') = S.zipWith @c @(StorageT c) f as s
@@ -135,7 +142,7 @@         Nothing -> return Nothing
       (storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch
       eIds = V.fromList . Set.toList $ entities arch
-      hooks = V.foldl (\acc (e, c) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds cs)
+      hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs)
    in (cs, arch {storages = storages'}, hooks)
 {-# INLINE zipWith #-}
 
@@ -144,7 +151,8 @@ zipWithM ::
   forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> m c) -> ComponentID -> Archetype m -> m (Vector c, Archetype m, Access m ())
 zipWithM as f cId arch = do
-  let go maybeDyn = case maybeDyn of
+  let oldCs = lookupComponentsAsc @m @c cId arch
+      go maybeDyn = case maybeDyn of
         Just dyn -> case fromDynamic $ storageDyn dyn of
           Just s ->
             WriterT $
@@ -156,7 +164,7 @@   res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch
   let cs = snd res
       eIds = V.fromList . Set.toList $ entities arch
-      hooks = V.foldl (\acc (e, c) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds cs)
+      hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs)
   return (cs, arch {storages = fst res}, hooks)
 
 -- | Zip a vector of components with a function and a component storage.
@@ -164,7 +172,8 @@ zipWith_ ::
   forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Archetype m, Access m ())
 zipWith_ as f cId arch =
-  let maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of
+  let oldCs = lookupComponentsAsc @m @c cId arch
+      maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of
         Just dyn -> case fromDynamic $ storageDyn dyn of
           Just s ->
             let !(cs, s') = S.zipWith @c @(StorageT c) f as s in Just (cs, dyn {storageDyn = toDyn s'})
@@ -173,7 +182,7 @@    in case maybeStorage of
         Just (cs, s) ->
           let eIds = V.fromList . Set.toList $ entities arch
-              hooks = V.foldl (\acc (e, c) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds cs)
+              hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs)
            in (empty {storages = IntMap.singleton (unComponentId cId) s}, hooks)
         Nothing -> (empty {storages = IntMap.empty}, return ())
 {-# INLINE zipWith_ #-}
@@ -182,7 +191,8 @@ zipWithAccum ::
   forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> (o, c)) -> ComponentID -> Archetype m -> (Vector (o, c), Archetype m, Access m ())
 zipWithAccum as f cId arch =
-  let go maybeDyn = case maybeDyn of
+  let oldCs = lookupComponentsAsc @m @c cId arch
+      go maybeDyn = case maybeDyn of
         Just dyn -> case fromDynamic $ storageDyn dyn of
           Just s -> do
             let !(pairs', s') = S.zipWithAccum @c @(StorageT c) f as s
@@ -192,7 +202,7 @@         Nothing -> return Nothing
       (storages', pairs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch
       eIds = V.fromList . Set.toList $ entities arch
-      hooks = V.foldl (\acc (e, (_, c)) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds pairs)
+      hooks = V.foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs pairs)
    in (pairs, arch {storages = storages'}, hooks)
 {-# INLINE zipWithAccum #-}
 
@@ -200,7 +210,8 @@ zipWithAccumM ::
   forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> m (o, c)) -> ComponentID -> Archetype m -> m (Vector (o, c), Archetype m, Access m ())
 zipWithAccumM as f cId arch = do
-  let go maybeDyn = case maybeDyn of
+  let oldCs = lookupComponentsAsc @m @c cId arch
+      go maybeDyn = case maybeDyn of
         Just dyn -> case fromDynamic $ storageDyn dyn of
           Just s ->
             WriterT $
@@ -212,7 +223,7 @@   res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch
   let pairs = snd res
       eIds = V.fromList . Set.toList $ entities arch
-      hooks = V.foldl (\acc (e, (_, c)) -> acc >> componentOnChange e c >> triggerEntityEvent e (OnChange c)) (return ()) (V.zip eIds pairs)
+      hooks = V.foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs pairs)
   return (pairs, arch {storages = fst res}, hooks)
 {-# INLINE zipWithAccumM #-}
 

@@ -82,20 +82,20 @@ update :: (Monad m) => Access m ()
 update = do
   parents <- A.system . S.readQuery $ do
-    entity <- Q.entity
+    e <- Q.entity
     parent <- Q.query
     maybeParentState <- Q.queryMaybe @_ @ParentState
-    return (entity, unParent parent, maybeParentState)
+    return (e, unParent parent, maybeParentState)
 
   children <- A.system . S.readQuery $ do
-    entity <- Q.entity
+    e <- Q.entity
     cs <- Q.query
     maybeChildState <- Q.queryMaybe @_ @ChildState
-    return (entity, unChildren cs, maybeChildState)
+    return (e, unChildren cs, maybeChildState)
 
   let go = do
         mapM_
-          ( \(entity, parent, maybeParentState) -> case maybeParentState of
+          ( \(e, parent, maybeParentState) -> case maybeParentState of
               Just (ParentState parentState) -> do
                 when (parent /= parentState) $ do
                   A.insert parent . bundle $ ParentState parent
@@ -103,32 +103,32 @@                   -- Remove this entity from the previous parent's children.
                   maybeLastChildren <- A.lookup parentState
                   let lastChildren = maybe mempty unChildren maybeLastChildren
-                  let lastChildren' = Set.filter (/= entity) lastChildren
+                  let lastChildren' = Set.filter (/= e) lastChildren
                   A.insert parentState . bundle . Children $ lastChildren'
 
                   -- Add this entity to the new parent's children.
                   maybeChildren <- A.lookup parent
                   let parentChildren = maybe mempty unChildren maybeChildren
-                  A.insert parent . bundle . Children $ Set.insert entity parentChildren
+                  A.insert parent . bundle . Children $ Set.insert e parentChildren
               Nothing -> do
                 A.spawn_ . bundle $ ParentState parent
                 maybeChildren <- A.lookup parent
                 let parentChildren = maybe mempty unChildren maybeChildren
-                A.insert parent . bundle . Children $ Set.insert entity parentChildren
+                A.insert parent . bundle . Children $ Set.insert e parentChildren
           )
           parents
         mapM_
-          ( \(entity, children', maybeChildState) -> case maybeChildState of
+          ( \(e, children', maybeChildState) -> case maybeChildState of
               Just (ChildState childState) -> do
                 when (children' /= childState) $ do
-                  A.insert entity . bundle $ ChildState children'
+                  A.insert e . bundle $ ChildState children'
                   let added = Set.difference children' childState
                       removed = Set.difference childState children'
-                  mapM_ (\e -> A.insert e . bundle . Parent $ entity) added
+                  mapM_ (\e' -> A.insert e' . bundle . Parent $ e') added
                   mapM_ (A.remove @_ @Parent) removed
               Nothing -> do
-                A.insert entity . bundle $ ChildState children'
-                mapM_ (\e -> A.insert e . bundle . Parent $ entity) children'
+                A.insert e . bundle $ ChildState children'
+                mapM_ (\e' -> A.insert e' . bundle . Parent $ e') children'
           )
           children
   go
@@ -177,11 +177,10 @@   Access m (Maybe (Hierarchy a))
 hierarchy e q = do
   children <- A.system . S.readQuery $ do
-    entity <- Q.entity
+    e' <- Q.entity
     cs <- Q.query
     a <- q
-    return (entity, (unChildren cs, a))
-
+    return (e', (unChildren cs, a))
   let childMap = Map.fromList $ V.toList children
   return $ hierarchy' e childMap
 
@@ -194,10 +193,10 @@ hierarchies q = do
   children <-
     A.system . S.readQuery $ do
-      entity <- Q.entity
+      e <- Q.entity
       cs <- Q.query
       a <- q
-      return (entity, (unChildren cs, a))
+      return (e, (unChildren cs, a))
 
   let childMap = Map.fromList $ V.toList children
   roots <- A.system $ S.readQueryFiltered Q.entity (with @m @Children <> without @m @Parent)