{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |

-- Module      : Aztecs.Asset.AssetServer

-- Copyright   : (c) Matt Hunzinger, 2025

-- License     : BSD-style (see the LICENSE file in the distribution)

--

-- Maintainer  : matt@hunzinger.me

-- Stability   : provisional

-- Portability : non-portable (GHC extensions)

--

-- Hierarchical relationships.

-- A `Children` component forms a one-to-many relationship with `Parent` components.

module Aztecs.Hierarchy
  ( Parent (..),
    Children (..),
    update,
    Hierarchy (..),
    toList,
    foldWithKey,
    mapWithKey,
    mapWithAccum,
    hierarchy,
    hierarchies,
    ParentState (..),
    ChildState (..),
  )
where

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
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as V
import GHC.Generics

-- | Parent component.

newtype Parent = Parent
  { -- | Parent entity ID.

    Parent -> EntityID
unParent :: EntityID
  }
  deriving (Parent -> Parent -> Bool
(Parent -> Parent -> Bool)
-> (Parent -> Parent -> Bool) -> Eq Parent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Parent -> Parent -> Bool
== :: Parent -> Parent -> Bool
$c/= :: Parent -> Parent -> Bool
/= :: Parent -> Parent -> Bool
Eq, Eq Parent
Eq Parent =>
(Parent -> Parent -> Ordering)
-> (Parent -> Parent -> Bool)
-> (Parent -> Parent -> Bool)
-> (Parent -> Parent -> Bool)
-> (Parent -> Parent -> Bool)
-> (Parent -> Parent -> Parent)
-> (Parent -> Parent -> Parent)
-> Ord Parent
Parent -> Parent -> Bool
Parent -> Parent -> Ordering
Parent -> Parent -> Parent
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Parent -> Parent -> Ordering
compare :: Parent -> Parent -> Ordering
$c< :: Parent -> Parent -> Bool
< :: Parent -> Parent -> Bool
$c<= :: Parent -> Parent -> Bool
<= :: Parent -> Parent -> Bool
$c> :: Parent -> Parent -> Bool
> :: Parent -> Parent -> Bool
$c>= :: Parent -> Parent -> Bool
>= :: Parent -> Parent -> Bool
$cmax :: Parent -> Parent -> Parent
max :: Parent -> Parent -> Parent
$cmin :: Parent -> Parent -> Parent
min :: Parent -> Parent -> Parent
Ord, Int -> Parent -> ShowS
[Parent] -> ShowS
Parent -> String
(Int -> Parent -> ShowS)
-> (Parent -> String) -> ([Parent] -> ShowS) -> Show Parent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Parent -> ShowS
showsPrec :: Int -> Parent -> ShowS
$cshow :: Parent -> String
show :: Parent -> String
$cshowList :: [Parent] -> ShowS
showList :: [Parent] -> ShowS
Show, (forall x. Parent -> Rep Parent x)
-> (forall x. Rep Parent x -> Parent) -> Generic Parent
forall x. Rep Parent x -> Parent
forall x. Parent -> Rep Parent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Parent -> Rep Parent x
from :: forall x. Parent -> Rep Parent x
$cto :: forall x. Rep Parent x -> Parent
to :: forall x. Rep Parent x -> Parent
Generic)

instance (Monad m) => Component m Parent

-- | Parent internal state component.

newtype ParentState = ParentState {ParentState -> EntityID
unParentState :: EntityID}
  deriving (Int -> ParentState -> ShowS
[ParentState] -> ShowS
ParentState -> String
(Int -> ParentState -> ShowS)
-> (ParentState -> String)
-> ([ParentState] -> ShowS)
-> Show ParentState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParentState -> ShowS
showsPrec :: Int -> ParentState -> ShowS
$cshow :: ParentState -> String
show :: ParentState -> String
$cshowList :: [ParentState] -> ShowS
showList :: [ParentState] -> ShowS
Show, (forall x. ParentState -> Rep ParentState x)
-> (forall x. Rep ParentState x -> ParentState)
-> Generic ParentState
forall x. Rep ParentState x -> ParentState
forall x. ParentState -> Rep ParentState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParentState -> Rep ParentState x
from :: forall x. ParentState -> Rep ParentState x
$cto :: forall x. Rep ParentState x -> ParentState
to :: forall x. Rep ParentState x -> ParentState
Generic)

instance (Monad m) => Component m ParentState

-- | Children component.

newtype Children = Children {Children -> Set EntityID
unChildren :: Set EntityID}
  deriving (Children -> Children -> Bool
(Children -> Children -> Bool)
-> (Children -> Children -> Bool) -> Eq Children
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Children -> Children -> Bool
== :: Children -> Children -> Bool
$c/= :: Children -> Children -> Bool
/= :: Children -> Children -> Bool
Eq, Eq Children
Eq Children =>
(Children -> Children -> Ordering)
-> (Children -> Children -> Bool)
-> (Children -> Children -> Bool)
-> (Children -> Children -> Bool)
-> (Children -> Children -> Bool)
-> (Children -> Children -> Children)
-> (Children -> Children -> Children)
-> Ord Children
Children -> Children -> Bool
Children -> Children -> Ordering
Children -> Children -> Children
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Children -> Children -> Ordering
compare :: Children -> Children -> Ordering
$c< :: Children -> Children -> Bool
< :: Children -> Children -> Bool
$c<= :: Children -> Children -> Bool
<= :: Children -> Children -> Bool
$c> :: Children -> Children -> Bool
> :: Children -> Children -> Bool
$c>= :: Children -> Children -> Bool
>= :: Children -> Children -> Bool
$cmax :: Children -> Children -> Children
max :: Children -> Children -> Children
$cmin :: Children -> Children -> Children
min :: Children -> Children -> Children
Ord, Int -> Children -> ShowS
[Children] -> ShowS
Children -> String
(Int -> Children -> ShowS)
-> (Children -> String) -> ([Children] -> ShowS) -> Show Children
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Children -> ShowS
showsPrec :: Int -> Children -> ShowS
$cshow :: Children -> String
show :: Children -> String
$cshowList :: [Children] -> ShowS
showList :: [Children] -> ShowS
Show, NonEmpty Children -> Children
Children -> Children -> Children
(Children -> Children -> Children)
-> (NonEmpty Children -> Children)
-> (forall b. Integral b => b -> Children -> Children)
-> Semigroup Children
forall b. Integral b => b -> Children -> Children
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Children -> Children -> Children
<> :: Children -> Children -> Children
$csconcat :: NonEmpty Children -> Children
sconcat :: NonEmpty Children -> Children
$cstimes :: forall b. Integral b => b -> Children -> Children
stimes :: forall b. Integral b => b -> Children -> Children
Semigroup, Semigroup Children
Children
Semigroup Children =>
Children
-> (Children -> Children -> Children)
-> ([Children] -> Children)
-> Monoid Children
[Children] -> Children
Children -> Children -> Children
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Children
mempty :: Children
$cmappend :: Children -> Children -> Children
mappend :: Children -> Children -> Children
$cmconcat :: [Children] -> Children
mconcat :: [Children] -> Children
Monoid, (forall x. Children -> Rep Children x)
-> (forall x. Rep Children x -> Children) -> Generic Children
forall x. Rep Children x -> Children
forall x. Children -> Rep Children x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Children -> Rep Children x
from :: forall x. Children -> Rep Children x
$cto :: forall x. Rep Children x -> Children
to :: forall x. Rep Children x -> Children
Generic)

instance (Monad m) => Component m Children

-- | Child internal state component.

newtype ChildState = ChildState {ChildState -> Set EntityID
unChildState :: Set EntityID}
  deriving (Int -> ChildState -> ShowS
[ChildState] -> ShowS
ChildState -> String
(Int -> ChildState -> ShowS)
-> (ChildState -> String)
-> ([ChildState] -> ShowS)
-> Show ChildState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChildState -> ShowS
showsPrec :: Int -> ChildState -> ShowS
$cshow :: ChildState -> String
show :: ChildState -> String
$cshowList :: [ChildState] -> ShowS
showList :: [ChildState] -> ShowS
Show, (forall x. ChildState -> Rep ChildState x)
-> (forall x. Rep ChildState x -> ChildState) -> Generic ChildState
forall x. Rep ChildState x -> ChildState
forall x. ChildState -> Rep ChildState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChildState -> Rep ChildState x
from :: forall x. ChildState -> Rep ChildState x
$cto :: forall x. Rep ChildState x -> ChildState
to :: forall x. Rep ChildState x -> ChildState
Generic)

instance (Monad m) => Component m ChildState

-- | Update the parent-child relationships.

update :: (Monad m) => Access m ()
update :: forall (m :: * -> *). Monad m => Access m ()
update = do
  Vector (EntityID, EntityID, Maybe ParentState)
parents <- System m (Vector (EntityID, EntityID, Maybe ParentState))
-> Access m (Vector (EntityID, EntityID, Maybe ParentState))
forall (m :: * -> *) a. Monad m => System m a -> Access m a
A.system (System m (Vector (EntityID, EntityID, Maybe ParentState))
 -> Access m (Vector (EntityID, EntityID, Maybe ParentState)))
-> (Query m (EntityID, EntityID, Maybe ParentState)
    -> System m (Vector (EntityID, EntityID, Maybe ParentState)))
-> Query m (EntityID, EntityID, Maybe ParentState)
-> Access m (Vector (EntityID, EntityID, Maybe ParentState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query m (EntityID, EntityID, Maybe ParentState)
-> System m (Vector (EntityID, EntityID, Maybe ParentState))
forall (m :: * -> *) a. Monad m => Query m a -> System m (Vector a)
S.readQuery (Query m (EntityID, EntityID, Maybe ParentState)
 -> Access m (Vector (EntityID, EntityID, Maybe ParentState)))
-> Query m (EntityID, EntityID, Maybe ParentState)
-> Access m (Vector (EntityID, EntityID, Maybe ParentState))
forall a b. (a -> b) -> a -> b
$ do
    EntityID
entity <- Query m EntityID
forall (m :: * -> *) (f :: * -> *). DynamicQueryF m f => f EntityID
Q.entity
    Parent
parent <- Query m Parent
forall (m :: * -> *) a. (Monad m, Component m a) => Query m a
Q.query
    Maybe ParentState
maybeParentState <- forall (m :: * -> *) a.
(Monad m, Component m a) =>
Query m (Maybe a)
Q.queryMaybe @_ @ParentState
    return (EntityID
entity, Parent -> EntityID
unParent Parent
parent, Maybe ParentState
maybeParentState)

  Vector (EntityID, Set EntityID, Maybe ChildState)
children <- System m (Vector (EntityID, Set EntityID, Maybe ChildState))
-> Access m (Vector (EntityID, Set EntityID, Maybe ChildState))
forall (m :: * -> *) a. Monad m => System m a -> Access m a
A.system (System m (Vector (EntityID, Set EntityID, Maybe ChildState))
 -> Access m (Vector (EntityID, Set EntityID, Maybe ChildState)))
-> (Query m (EntityID, Set EntityID, Maybe ChildState)
    -> System m (Vector (EntityID, Set EntityID, Maybe ChildState)))
-> Query m (EntityID, Set EntityID, Maybe ChildState)
-> Access m (Vector (EntityID, Set EntityID, Maybe ChildState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query m (EntityID, Set EntityID, Maybe ChildState)
-> System m (Vector (EntityID, Set EntityID, Maybe ChildState))
forall (m :: * -> *) a. Monad m => Query m a -> System m (Vector a)
S.readQuery (Query m (EntityID, Set EntityID, Maybe ChildState)
 -> Access m (Vector (EntityID, Set EntityID, Maybe ChildState)))
-> Query m (EntityID, Set EntityID, Maybe ChildState)
-> Access m (Vector (EntityID, Set EntityID, Maybe ChildState))
forall a b. (a -> b) -> a -> b
$ do
    EntityID
entity <- Query m EntityID
forall (m :: * -> *) (f :: * -> *). DynamicQueryF m f => f EntityID
Q.entity
    Children
cs <- Query m Children
forall (m :: * -> *) a. (Monad m, Component m a) => Query m a
Q.query
    Maybe ChildState
maybeChildState <- forall (m :: * -> *) a.
(Monad m, Component m a) =>
Query m (Maybe a)
Q.queryMaybe @_ @ChildState
    return (EntityID
entity, Children -> Set EntityID
unChildren Children
cs, Maybe ChildState
maybeChildState)

  let go :: Access m ()
go = do
        ((EntityID, EntityID, Maybe ParentState) -> Access m ())
-> Vector (EntityID, EntityID, Maybe ParentState) -> Access m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          ( \(EntityID
entity, EntityID
parent, Maybe ParentState
maybeParentState) -> case Maybe ParentState
maybeParentState of
              Just (ParentState EntityID
parentState) -> do
                Bool -> Access m () -> Access m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EntityID
parent EntityID -> EntityID -> Bool
forall a. Eq a => a -> a -> Bool
/= EntityID
parentState) (Access m () -> Access m ()) -> Access m () -> Access m ()
forall a b. (a -> b) -> a -> b
$ do
                  EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
parent (BundleT m -> Access m ())
-> (ParentState -> BundleT m) -> ParentState -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParentState -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (ParentState -> Access m ()) -> ParentState -> Access m ()
forall a b. (a -> b) -> a -> b
$ EntityID -> ParentState
ParentState EntityID
parent

                  -- Remove this entity from the previous parent's children.

                  Maybe Children
maybeLastChildren <- EntityID -> Access m (Maybe Children)
forall (m :: * -> *) a.
(Monad m, Component m a) =>
EntityID -> Access m (Maybe a)
A.lookup EntityID
parentState
                  let lastChildren :: Set EntityID
lastChildren = Set EntityID
-> (Children -> Set EntityID) -> Maybe Children -> Set EntityID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set EntityID
forall a. Monoid a => a
mempty Children -> Set EntityID
unChildren Maybe Children
maybeLastChildren
                  let lastChildren' :: Set EntityID
lastChildren' = (EntityID -> Bool) -> Set EntityID -> Set EntityID
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (EntityID -> EntityID -> Bool
forall a. Eq a => a -> a -> Bool
/= EntityID
entity) Set EntityID
lastChildren
                  EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
parentState (BundleT m -> Access m ())
-> (Set EntityID -> BundleT m) -> Set EntityID -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Children -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (Children -> BundleT m)
-> (Set EntityID -> Children) -> Set EntityID -> BundleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntityID -> Children
Children (Set EntityID -> Access m ()) -> Set EntityID -> Access m ()
forall a b. (a -> b) -> a -> b
$ Set EntityID
lastChildren'

                  -- Add this entity to the new parent's children.

                  Maybe Children
maybeChildren <- EntityID -> Access m (Maybe Children)
forall (m :: * -> *) a.
(Monad m, Component m a) =>
EntityID -> Access m (Maybe a)
A.lookup EntityID
parent
                  let parentChildren :: Set EntityID
parentChildren = Set EntityID
-> (Children -> Set EntityID) -> Maybe Children -> Set EntityID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set EntityID
forall a. Monoid a => a
mempty Children -> Set EntityID
unChildren Maybe Children
maybeChildren
                  EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
parent (BundleT m -> Access m ())
-> (Set EntityID -> BundleT m) -> Set EntityID -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Children -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (Children -> BundleT m)
-> (Set EntityID -> Children) -> Set EntityID -> BundleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntityID -> Children
Children (Set EntityID -> Access m ()) -> Set EntityID -> Access m ()
forall a b. (a -> b) -> a -> b
$ EntityID -> Set EntityID -> Set EntityID
forall a. Ord a => a -> Set a -> Set a
Set.insert EntityID
entity Set EntityID
parentChildren
              Maybe ParentState
Nothing -> do
                BundleT m -> Access m ()
forall (m :: * -> *). Monad m => BundleT m -> Access m ()
A.spawn_ (BundleT m -> Access m ())
-> (ParentState -> BundleT m) -> ParentState -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParentState -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (ParentState -> Access m ()) -> ParentState -> Access m ()
forall a b. (a -> b) -> a -> b
$ EntityID -> ParentState
ParentState EntityID
parent
                Maybe Children
maybeChildren <- EntityID -> Access m (Maybe Children)
forall (m :: * -> *) a.
(Monad m, Component m a) =>
EntityID -> Access m (Maybe a)
A.lookup EntityID
parent
                let parentChildren :: Set EntityID
parentChildren = Set EntityID
-> (Children -> Set EntityID) -> Maybe Children -> Set EntityID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set EntityID
forall a. Monoid a => a
mempty Children -> Set EntityID
unChildren Maybe Children
maybeChildren
                EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
parent (BundleT m -> Access m ())
-> (Set EntityID -> BundleT m) -> Set EntityID -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Children -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (Children -> BundleT m)
-> (Set EntityID -> Children) -> Set EntityID -> BundleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntityID -> Children
Children (Set EntityID -> Access m ()) -> Set EntityID -> Access m ()
forall a b. (a -> b) -> a -> b
$ EntityID -> Set EntityID -> Set EntityID
forall a. Ord a => a -> Set a -> Set a
Set.insert EntityID
entity Set EntityID
parentChildren
          )
          Vector (EntityID, EntityID, Maybe ParentState)
parents
        ((EntityID, Set EntityID, Maybe ChildState) -> Access m ())
-> Vector (EntityID, Set EntityID, Maybe ChildState) -> Access m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          ( \(EntityID
entity, Set EntityID
children', Maybe ChildState
maybeChildState) -> case Maybe ChildState
maybeChildState of
              Just (ChildState Set EntityID
childState) -> do
                Bool -> Access m () -> Access m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set EntityID
children' Set EntityID -> Set EntityID -> Bool
forall a. Eq a => a -> a -> Bool
/= Set EntityID
childState) (Access m () -> Access m ()) -> Access m () -> Access m ()
forall a b. (a -> b) -> a -> b
$ do
                  EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
entity (BundleT m -> Access m ())
-> (ChildState -> BundleT m) -> ChildState -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildState -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (ChildState -> Access m ()) -> ChildState -> Access m ()
forall a b. (a -> b) -> a -> b
$ Set EntityID -> ChildState
ChildState Set EntityID
children'
                  let added :: Set EntityID
added = Set EntityID -> Set EntityID -> Set EntityID
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set EntityID
children' Set EntityID
childState
                      removed :: Set EntityID
removed = Set EntityID -> Set EntityID -> Set EntityID
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set EntityID
childState Set EntityID
children'
                  (EntityID -> Access m ()) -> Set EntityID -> Access m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\EntityID
e -> EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
e (BundleT m -> Access m ())
-> (EntityID -> BundleT m) -> EntityID -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parent -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (Parent -> BundleT m)
-> (EntityID -> Parent) -> EntityID -> BundleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityID -> Parent
Parent (EntityID -> Access m ()) -> EntityID -> Access m ()
forall a b. (a -> b) -> a -> b
$ EntityID
entity) Set EntityID
added
                  (EntityID -> Access m (Maybe Parent))
-> Set EntityID -> Access m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
(Monad m, Component m a) =>
EntityID -> Access m (Maybe a)
A.remove @_ @Parent) Set EntityID
removed
              Maybe ChildState
Nothing -> do
                EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
entity (BundleT m -> Access m ())
-> (ChildState -> BundleT m) -> ChildState -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildState -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (ChildState -> Access m ()) -> ChildState -> Access m ()
forall a b. (a -> b) -> a -> b
$ Set EntityID -> ChildState
ChildState Set EntityID
children'
                (EntityID -> Access m ()) -> Set EntityID -> Access m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\EntityID
e -> EntityID -> BundleT m -> Access m ()
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> Access m ()
A.insert EntityID
e (BundleT m -> Access m ())
-> (EntityID -> BundleT m) -> EntityID -> Access m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parent -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundle (Parent -> BundleT m)
-> (EntityID -> Parent) -> EntityID -> BundleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityID -> Parent
Parent (EntityID -> Access m ()) -> EntityID -> Access m ()
forall a b. (a -> b) -> a -> b
$ EntityID
entity) Set EntityID
children'
          )
          Vector (EntityID, Set EntityID, Maybe ChildState)
children
  Access m ()
go

-- | Hierarchy of entities.

data Hierarchy a = Node
  { -- | Entity ID.

    forall a. Hierarchy a -> EntityID
nodeEntityId :: EntityID,
    -- | Entity components.

    forall a. Hierarchy a -> a
nodeEntity :: a,
    -- | Child nodes.

    forall a. Hierarchy a -> [Hierarchy a]
nodeChildren :: [Hierarchy a]
  }
  deriving ((forall a b. (a -> b) -> Hierarchy a -> Hierarchy b)
-> (forall a b. a -> Hierarchy b -> Hierarchy a)
-> Functor Hierarchy
forall a b. a -> Hierarchy b -> Hierarchy a
forall a b. (a -> b) -> Hierarchy a -> Hierarchy b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Hierarchy a -> Hierarchy b
fmap :: forall a b. (a -> b) -> Hierarchy a -> Hierarchy b
$c<$ :: forall a b. a -> Hierarchy b -> Hierarchy a
<$ :: forall a b. a -> Hierarchy b -> Hierarchy a
Functor)

instance Foldable Hierarchy where
  foldMap :: forall m a. Monoid m => (a -> m) -> Hierarchy a -> m
foldMap a -> m
f Hierarchy a
n = a -> m
f (Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n) m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Hierarchy a -> m) -> [Hierarchy a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Hierarchy a -> m
forall m a. Monoid m => (a -> m) -> Hierarchy a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) (Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n)

instance Traversable Hierarchy where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Hierarchy a -> f (Hierarchy b)
traverse a -> f b
f Hierarchy a
n =
    EntityID -> b -> [Hierarchy b] -> Hierarchy b
forall a. EntityID -> a -> [Hierarchy a] -> Hierarchy a
Node (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n) (b -> [Hierarchy b] -> Hierarchy b)
-> f b -> f ([Hierarchy b] -> Hierarchy b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f (Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n) f ([Hierarchy b] -> Hierarchy b)
-> f [Hierarchy b] -> f (Hierarchy b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hierarchy a -> f (Hierarchy b))
-> [Hierarchy a] -> f [Hierarchy b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a -> f b) -> Hierarchy a -> f (Hierarchy b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Hierarchy a -> f (Hierarchy b)
traverse a -> f b
f) (Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n)

-- | Convert a hierarchy to a vector of entity IDs and components.

toList :: Hierarchy a -> Vector (EntityID, a)
toList :: forall a. Hierarchy a -> Vector (EntityID, a)
toList Hierarchy a
n = (EntityID, a) -> Vector (EntityID, a)
forall a. a -> Vector a
V.singleton (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n, Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n) Vector (EntityID, a)
-> Vector (EntityID, a) -> Vector (EntityID, a)
forall a. Semigroup a => a -> a -> a
<> (Hierarchy a -> Vector (EntityID, a))
-> Vector (Hierarchy a) -> Vector (EntityID, a)
forall a b. (a -> Vector b) -> Vector a -> Vector b
V.concatMap Hierarchy a -> Vector (EntityID, a)
forall a. Hierarchy a -> Vector (EntityID, a)
toList ([Hierarchy a] -> Vector (Hierarchy a)
forall a. [a] -> Vector a
V.fromList ([Hierarchy a] -> Vector (Hierarchy a))
-> [Hierarchy a] -> Vector (Hierarchy a)
forall a b. (a -> b) -> a -> b
$ Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n)

-- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator.

foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b
foldWithKey :: forall a b. (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b
foldWithKey EntityID -> a -> b -> b
f Hierarchy a
n b
b = EntityID -> a -> b -> b
f (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n) (Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n) ((Hierarchy a -> b -> b) -> b -> [Hierarchy a] -> b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((EntityID -> a -> b -> b) -> Hierarchy a -> b -> b
forall a b. (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b
foldWithKey EntityID -> a -> b -> b
f) b
b (Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n))

-- | Map a hierarchy with a function that takes the entity ID and entity.

mapWithKey :: (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b
mapWithKey :: forall a b. (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b
mapWithKey EntityID -> a -> b
f Hierarchy a
n =
  EntityID -> b -> [Hierarchy b] -> Hierarchy b
forall a. EntityID -> a -> [Hierarchy a] -> Hierarchy a
Node (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n) (EntityID -> a -> b
f (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n) (Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n)) ((Hierarchy a -> Hierarchy b) -> [Hierarchy a] -> [Hierarchy b]
forall a b. (a -> b) -> [a] -> [b]
map ((EntityID -> a -> b) -> Hierarchy a -> Hierarchy b
forall a b. (EntityID -> a -> b) -> Hierarchy a -> Hierarchy b
mapWithKey EntityID -> a -> b
f) (Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n))

-- | Map a hierarchy with a function that takes the entity ID, entity, and accumulator.

mapWithAccum :: (EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c
mapWithAccum :: forall a b c.
(EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c
mapWithAccum EntityID -> a -> b -> (c, b)
f b
b Hierarchy a
n = case EntityID -> a -> b -> (c, b)
f (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n) (Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n) b
b of
  (c
c, b
b') -> EntityID -> c -> [Hierarchy c] -> Hierarchy c
forall a. EntityID -> a -> [Hierarchy a] -> Hierarchy a
Node (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n) c
c ((Hierarchy a -> Hierarchy c) -> [Hierarchy a] -> [Hierarchy c]
forall a b. (a -> b) -> [a] -> [b]
map ((EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c
forall a b c.
(EntityID -> a -> b -> (c, b)) -> b -> Hierarchy a -> Hierarchy c
mapWithAccum EntityID -> a -> b -> (c, b)
f b
b') (Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n))

-- | System to read a hierarchy of parents to children with the given query.

hierarchy ::
  (Monad m) =>
  EntityID ->
  Query m a ->
  Access m (Maybe (Hierarchy a))
hierarchy :: forall (m :: * -> *) a.
Monad m =>
EntityID -> Query m a -> Access m (Maybe (Hierarchy a))
hierarchy EntityID
e Query m a
q = do
  Vector (EntityID, (Set EntityID, a))
children <- System m (Vector (EntityID, (Set EntityID, a)))
-> Access m (Vector (EntityID, (Set EntityID, a)))
forall (m :: * -> *) a. Monad m => System m a -> Access m a
A.system (System m (Vector (EntityID, (Set EntityID, a)))
 -> Access m (Vector (EntityID, (Set EntityID, a))))
-> (Query m (EntityID, (Set EntityID, a))
    -> System m (Vector (EntityID, (Set EntityID, a))))
-> Query m (EntityID, (Set EntityID, a))
-> Access m (Vector (EntityID, (Set EntityID, a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query m (EntityID, (Set EntityID, a))
-> System m (Vector (EntityID, (Set EntityID, a)))
forall (m :: * -> *) a. Monad m => Query m a -> System m (Vector a)
S.readQuery (Query m (EntityID, (Set EntityID, a))
 -> Access m (Vector (EntityID, (Set EntityID, a))))
-> Query m (EntityID, (Set EntityID, a))
-> Access m (Vector (EntityID, (Set EntityID, a)))
forall a b. (a -> b) -> a -> b
$ do
    EntityID
entity <- Query m EntityID
forall (m :: * -> *) (f :: * -> *). DynamicQueryF m f => f EntityID
Q.entity
    Children
cs <- Query m Children
forall (m :: * -> *) a. (Monad m, Component m a) => Query m a
Q.query
    a
a <- Query m a
q
    return (EntityID
entity, (Children -> Set EntityID
unChildren Children
cs, a
a))

  let childMap :: Map EntityID (Set EntityID, a)
childMap = [(EntityID, (Set EntityID, a))] -> Map EntityID (Set EntityID, a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(EntityID, (Set EntityID, a))] -> Map EntityID (Set EntityID, a))
-> [(EntityID, (Set EntityID, a))]
-> Map EntityID (Set EntityID, a)
forall a b. (a -> b) -> a -> b
$ Vector (EntityID, (Set EntityID, a))
-> [(EntityID, (Set EntityID, a))]
forall a. Vector a -> [a]
V.toList Vector (EntityID, (Set EntityID, a))
children
  Maybe (Hierarchy a) -> Access m (Maybe (Hierarchy a))
forall a. a -> Access m a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Maybe (Hierarchy a) -> Access m (Maybe (Hierarchy a)))
-> Maybe (Hierarchy a) -> Access m (Maybe (Hierarchy a))
forall a b. (a -> b) -> a -> b
$ EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
forall a.
EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
hierarchy' EntityID
e Map EntityID (Set EntityID, a)
childMap

-- | Build all hierarchies of parents to children, joined with the given query.

hierarchies ::
  forall m a.
  (Monad m) =>
  Query m a ->
  Access m (Vector (Hierarchy a))
hierarchies :: forall (m :: * -> *) a.
Monad m =>
Query m a -> Access m (Vector (Hierarchy a))
hierarchies Query m a
q = do
  Vector (EntityID, (Set EntityID, a))
children <-
    System m (Vector (EntityID, (Set EntityID, a)))
-> Access m (Vector (EntityID, (Set EntityID, a)))
forall (m :: * -> *) a. Monad m => System m a -> Access m a
A.system (System m (Vector (EntityID, (Set EntityID, a)))
 -> Access m (Vector (EntityID, (Set EntityID, a))))
-> (Query m (EntityID, (Set EntityID, a))
    -> System m (Vector (EntityID, (Set EntityID, a))))
-> Query m (EntityID, (Set EntityID, a))
-> Access m (Vector (EntityID, (Set EntityID, a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query m (EntityID, (Set EntityID, a))
-> System m (Vector (EntityID, (Set EntityID, a)))
forall (m :: * -> *) a. Monad m => Query m a -> System m (Vector a)
S.readQuery (Query m (EntityID, (Set EntityID, a))
 -> Access m (Vector (EntityID, (Set EntityID, a))))
-> Query m (EntityID, (Set EntityID, a))
-> Access m (Vector (EntityID, (Set EntityID, a)))
forall a b. (a -> b) -> a -> b
$ do
      EntityID
entity <- Query m EntityID
forall (m :: * -> *) (f :: * -> *). DynamicQueryF m f => f EntityID
Q.entity
      Children
cs <- Query m Children
forall (m :: * -> *) a. (Monad m, Component m a) => Query m a
Q.query
      a
a <- Query m a
q
      return (EntityID
entity, (Children -> Set EntityID
unChildren Children
cs, a
a))

  let childMap :: Map EntityID (Set EntityID, a)
childMap = [(EntityID, (Set EntityID, a))] -> Map EntityID (Set EntityID, a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(EntityID, (Set EntityID, a))] -> Map EntityID (Set EntityID, a))
-> [(EntityID, (Set EntityID, a))]
-> Map EntityID (Set EntityID, a)
forall a b. (a -> b) -> a -> b
$ Vector (EntityID, (Set EntityID, a))
-> [(EntityID, (Set EntityID, a))]
forall a. Vector a -> [a]
V.toList Vector (EntityID, (Set EntityID, a))
children
  Vector EntityID
roots <- System m (Vector EntityID) -> Access m (Vector EntityID)
forall (m :: * -> *) a. Monad m => System m a -> Access m a
A.system (System m (Vector EntityID) -> Access m (Vector EntityID))
-> System m (Vector EntityID) -> Access m (Vector EntityID)
forall a b. (a -> b) -> a -> b
$ Query m EntityID -> QueryFilter -> System m (Vector EntityID)
forall (m :: * -> *) a.
Monad m =>
Query m a -> QueryFilter -> System m (Vector a)
S.readQueryFiltered Query m EntityID
forall (m :: * -> *) (f :: * -> *). DynamicQueryF m f => f EntityID
Q.entity (forall (m :: * -> *) a. Component m a => QueryFilter
with @m @Children QueryFilter -> QueryFilter -> QueryFilter
forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) a. Component m a => QueryFilter
without @m @Parent)
  return $ (EntityID -> Maybe (Hierarchy a))
-> Vector EntityID -> Vector (Hierarchy a)
forall a b. (a -> Maybe b) -> Vector a -> Vector b
V.mapMaybe (EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
forall a.
EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
`hierarchy'` Map EntityID (Set EntityID, a)
childMap) Vector EntityID
roots

-- | Build a hierarchy of parents to children.

hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
hierarchy' :: forall a.
EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
hierarchy' EntityID
e Map EntityID (Set EntityID, a)
childMap = case EntityID
-> Map EntityID (Set EntityID, a) -> Maybe (Set EntityID, a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EntityID
e Map EntityID (Set EntityID, a)
childMap of
  Just (Set EntityID
cs, a
a) ->
    let bs :: [Hierarchy a]
bs = (EntityID -> Maybe (Hierarchy a)) -> [EntityID] -> [Hierarchy a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
forall a.
EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a)
`hierarchy'` Map EntityID (Set EntityID, a)
childMap) (Set EntityID -> [EntityID]
forall a. Set a -> [a]
Set.toList Set EntityID
cs)
     in Hierarchy a -> Maybe (Hierarchy a)
forall a. a -> Maybe a
Just
          Node
            { nodeEntityId :: EntityID
nodeEntityId = EntityID
e,
              nodeEntity :: a
nodeEntity = a
a,
              nodeChildren :: [Hierarchy a]
nodeChildren = [Hierarchy a]
bs
            }
  Maybe (Set EntityID, a)
Nothing -> Maybe (Hierarchy a)
forall a. Maybe a
Nothing