From 828619c56f2740de3361a54cc1c8a07f58fd281a Mon Sep 17 00:00:00 2001 From: Matt Hunzinger Date: Mon, 26 Jan 2026 01:00:53 -0500 Subject: [PATCH] feat!: update Hierarchy module to use component hooks --- src/Aztecs.hs | 3 +- src/Aztecs/Hierarchy.hs | 114 +++++++++++++++------------------------- 2 files changed, 43 insertions(+), 74 deletions(-) diff --git a/src/Aztecs.hs b/src/Aztecs.hs index a65e9f62..7fb40c61 100644 --- a/src/Aztecs.hs +++ b/src/Aztecs.hs @@ -2,6 +2,7 @@ -- -- An ECS is a modern approach to organizing your application state as a database, -- providing patterns for data-oriented design and parallel processing. -module Aztecs (module Aztecs.ECS) where +module Aztecs (module Aztecs.ECS, module Aztecs.Hierarchy) where import Aztecs.ECS +import Aztecs.Hierarchy diff --git a/src/Aztecs/Hierarchy.hs b/src/Aztecs/Hierarchy.hs index fcb4753c..99175489 100644 --- a/src/Aztecs/Hierarchy.hs +++ b/src/Aztecs/Hierarchy.hs @@ -24,7 +24,6 @@ module Aztecs.Hierarchy ( Parent (..), Children (..), - update, Hierarchy (..), toList, foldWithKey, @@ -32,8 +31,6 @@ module Aztecs.Hierarchy mapWithAccum, hierarchy, hierarchies, - ParentState (..), - ChildState (..), ) where @@ -41,7 +38,6 @@ import Aztecs.ECS import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S -import Control.Monad import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -58,80 +54,52 @@ newtype Parent = Parent } deriving (Eq, Ord, Show, Generic) -instance (Monad m) => Component m Parent - --- | Parent internal state component. -newtype ParentState = ParentState {unParentState :: EntityID} - deriving (Show, Generic) - -instance (Monad m) => Component m ParentState +instance (Monad m) => Component m Parent where + componentOnInsert e (Parent parent) = do + -- Add this entity to the parent's children. + maybeChildren <- A.lookup parent + let parentChildren = maybe mempty unChildren maybeChildren + A.insertUntracked parent . bundle . Children $ Set.insert e parentChildren + + componentOnChange e (Parent oldParent) (Parent newParent) = do + -- Remove this entity from the old parent's children. + maybeOldChildren <- A.lookup oldParent + let oldChildren = maybe mempty unChildren maybeOldChildren + let oldChildren' = Set.filter (/= e) oldChildren + A.insertUntracked oldParent . bundle . Children $ oldChildren' + + -- Add this entity to the new parent's children. + maybeNewChildren <- A.lookup newParent + let newChildren = maybe mempty unChildren maybeNewChildren + A.insertUntracked newParent . bundle . Children $ Set.insert e newChildren + + componentOnRemove e (Parent parent) = do + -- Remove this entity from the parent's children. + maybeChildren <- A.lookup parent + let parentChildren = maybe mempty unChildren maybeChildren + let parentChildren' = Set.filter (/= e) parentChildren + A.insertUntracked parent . bundle . Children $ parentChildren' -- | Children component. newtype Children = Children {unChildren :: Set EntityID} deriving (Eq, Ord, Show, Semigroup, Monoid, Generic) -instance (Monad m) => Component m Children - --- | Child internal state component. -newtype ChildState = ChildState {unChildState :: Set EntityID} - deriving (Show, Generic) - -instance (Monad m) => Component m ChildState - --- | Update the parent-child relationships. -update :: (Monad m) => Access m () -update = do - parents <- A.system . S.readQuery $ do - e <- Q.entity - parent <- Q.query - maybeParentState <- Q.queryMaybe @_ @ParentState - return (e, unParent parent, maybeParentState) - - children <- A.system . S.readQuery $ do - e <- Q.entity - cs <- Q.query - maybeChildState <- Q.queryMaybe @_ @ChildState - return (e, unChildren cs, maybeChildState) - - let go = do - mapM_ - ( \(e, parent, maybeParentState) -> case maybeParentState of - Just (ParentState parentState) -> do - when (parent /= parentState) $ do - A.insert parent . bundle $ ParentState parent - - -- Remove this entity from the previous parent's children. - maybeLastChildren <- A.lookup parentState - let lastChildren = maybe mempty unChildren maybeLastChildren - 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 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 e parentChildren - ) - parents - mapM_ - ( \(e, children', maybeChildState) -> case maybeChildState of - Just (ChildState childState) -> do - when (children' /= childState) $ do - A.insert e . bundle $ ChildState children' - let added = Set.difference children' childState - removed = Set.difference childState children' - mapM_ (\e' -> A.insert e' . bundle . Parent $ e') added - mapM_ (A.remove @_ @Parent) removed - Nothing -> do - A.insert e . bundle $ ChildState children' - mapM_ (\e' -> A.insert e' . bundle . Parent $ e') children' - ) - children - go +instance (Monad m) => Component m Children where + componentOnInsert e (Children cs) = do + -- Set parent on all children. + mapM_ (\child -> A.insertUntracked child . bundle $ Parent e) cs + + componentOnChange e (Children oldCs) (Children newCs) = do + let added = Set.difference newCs oldCs + removed = Set.difference oldCs newCs + -- Set parent on added children. + mapM_ (\child -> A.insertUntracked child . bundle $ Parent e) added + -- Remove parent from removed children. + mapM_ (\child -> A.remove @_ @Parent child) removed + + componentOnRemove _ (Children cs) = do + -- Remove parent from all children. + mapM_ (\child -> A.remove @_ @Parent child) cs -- | Hierarchy of entities. data Hierarchy a = Node