{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}

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.Arrow (returnA)
import Control.DeepSeq
import Control.Monad (when)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)

newtype Parent = Parent {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, Parent -> ()
(Parent -> ()) -> NFData Parent
forall a. (a -> ()) -> NFData a
$crnf :: Parent -> ()
rnf :: Parent -> ()
NFData)

instance Component Parent

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, ParentState -> ()
(ParentState -> ()) -> NFData ParentState
forall a. (a -> ()) -> NFData a
$crnf :: ParentState -> ()
rnf :: ParentState -> ()
NFData)

instance Component ParentState

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, Children -> ()
(Children -> ()) -> NFData Children
forall a. (a -> ()) -> NFData a
$crnf :: Children -> ()
rnf :: Children -> ()
NFData)

instance Component Children

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, ChildState -> ()
(ChildState -> ()) -> NFData ChildState
forall a. (a -> ()) -> NFData a
$crnf :: ChildState -> ()
rnf :: ChildState -> ()
NFData)

instance Component ChildState

update ::
  ( ArrowQueryReader qr,
    ArrowDynamicQueryReader qr,
    ArrowReaderSystem qr arr,
    ArrowQueueSystem b m arr
  ) =>
  arr () ()
update :: forall (qr :: * -> * -> *) (arr :: * -> * -> *) b (m :: * -> *).
(ArrowQueryReader qr, ArrowDynamicQueryReader qr,
 ArrowReaderSystem qr arr, ArrowQueueSystem b m arr) =>
arr () ()
update = proc () -> do
  [(EntityID, EntityID, Maybe ParentState)]
parents <-
    qr () (EntityID, EntityID, Maybe ParentState)
-> arr () [(EntityID, EntityID, Maybe ParentState)]
forall i a. qr i a -> arr i [a]
forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
ArrowReaderSystem q arr =>
q i a -> arr i [a]
S.all
      ( proc () -> do
          EntityID
entity <- qr () EntityID
forall (arr :: * -> * -> *).
ArrowDynamicQueryReader arr =>
arr () EntityID
Q.entity -< ()
          Parent EntityID
parent <- qr () Parent
forall a. Component a => qr () a
forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () a
Q.fetch -< ()
          Maybe ParentState
maybeParentState <- forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () (Maybe a)
Q.fetchMaybe @_ @ParentState -< ()
          qr
  (EntityID, EntityID, Maybe ParentState)
  (EntityID, EntityID, Maybe ParentState)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (EntityID
entity, EntityID
parent, Maybe ParentState
maybeParentState)
      )
      -<
        ()
  [(EntityID, Set EntityID, Maybe ChildState)]
children <-
    qr () (EntityID, Set EntityID, Maybe ChildState)
-> arr () [(EntityID, Set EntityID, Maybe ChildState)]
forall i a. qr i a -> arr i [a]
forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
ArrowReaderSystem q arr =>
q i a -> arr i [a]
S.all
      ( proc () -> do
          EntityID
entity <- qr () EntityID
forall (arr :: * -> * -> *).
ArrowDynamicQueryReader arr =>
arr () EntityID
Q.entity -< ()
          Children Set EntityID
cs <- qr () Children
forall a. Component a => qr () a
forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () a
Q.fetch -< ()
          Maybe ChildState
maybeChildState <- forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () (Maybe a)
Q.fetchMaybe @_ @ChildState -< ()
          qr
  (EntityID, Set EntityID, Maybe ChildState)
  (EntityID, Set EntityID, Maybe ChildState)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (EntityID
entity, Set EntityID
cs, Maybe ChildState
maybeChildState)
      )
      -<
        ()
  (([(EntityID, EntityID, Maybe ParentState)],
  [(EntityID, Set EntityID, Maybe ChildState)])
 -> m ())
-> arr
     ([(EntityID, EntityID, Maybe ParentState)],
      [(EntityID, Set EntityID, Maybe ChildState)])
     ()
forall i. (i -> m ()) -> arr i ()
forall b (m :: * -> *) (arr :: * -> * -> *) i.
ArrowQueueSystem b m arr =>
(i -> m ()) -> arr i ()
S.queue
    ( \([(EntityID, EntityID, Maybe ParentState)]
parents, [(EntityID, Set EntityID, Maybe ChildState)]
childRes) -> do
        ((EntityID, EntityID, Maybe ParentState) -> m ())
-> [(EntityID, EntityID, Maybe ParentState)] -> 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 -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EntityID
parent EntityID -> EntityID -> Bool
forall a. Eq a => a -> a -> Bool
/= EntityID
parentState) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  EntityID -> ParentState -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
parent (ParentState -> m ()) -> ParentState -> 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 -> m (Maybe Children)
forall a. Component a => EntityID -> m (Maybe a)
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> 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 -> Children -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
parentState (Children -> m ())
-> (Set EntityID -> Children) -> Set EntityID -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntityID -> Children
Children (Set EntityID -> m ()) -> Set EntityID -> m ()
forall a b. (a -> b) -> a -> b
$ Set EntityID
lastChildren'

                  -- Add this entity to the new parent's children.
                  Maybe Children
maybeChildren <- EntityID -> m (Maybe Children)
forall a. Component a => EntityID -> m (Maybe a)
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> 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 -> Children -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
parent (Children -> m ())
-> (Set EntityID -> Children) -> Set EntityID -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntityID -> Children
Children (Set EntityID -> m ()) -> Set EntityID -> 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
                b -> m ()
forall b (m :: * -> *). MonadAccess b m => b -> m ()
A.spawn_ (b -> m ()) -> (ParentState -> b) -> ParentState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParentState -> b
forall c. Component c => c -> b
forall a c. (MonoidBundle a, Component c) => c -> a
bundle (ParentState -> m ()) -> ParentState -> m ()
forall a b. (a -> b) -> a -> b
$ EntityID -> ParentState
ParentState EntityID
parent
                Maybe Children
maybeChildren <- EntityID -> m (Maybe Children)
forall a. Component a => EntityID -> m (Maybe a)
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> 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 -> Children -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
parent (Children -> m ())
-> (Set EntityID -> Children) -> Set EntityID -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntityID -> Children
Children (Set EntityID -> m ()) -> Set EntityID -> 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
          )
          [(EntityID, EntityID, Maybe ParentState)]
parents
        ((EntityID, Set EntityID, Maybe ChildState) -> m ())
-> [(EntityID, Set EntityID, Maybe ChildState)] -> 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 -> m () -> 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) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  EntityID -> ChildState -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
entity (ChildState -> m ()) -> ChildState -> 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 -> m ()) -> Set EntityID -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\EntityID
e -> EntityID -> Parent -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
e (Parent -> m ()) -> (EntityID -> Parent) -> EntityID -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityID -> Parent
Parent (EntityID -> m ()) -> EntityID -> m ()
forall a b. (a -> b) -> a -> b
$ EntityID
entity) Set EntityID
added
                  (EntityID -> m (Maybe Parent)) -> Set EntityID -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> m (Maybe a)
A.remove @_ @_ @Parent) Set EntityID
removed
              Maybe ChildState
Nothing -> do
                EntityID -> ChildState -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
entity (ChildState -> m ()) -> ChildState -> m ()
forall a b. (a -> b) -> a -> b
$ Set EntityID -> ChildState
ChildState Set EntityID
children
                (EntityID -> m ()) -> Set EntityID -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\EntityID
e -> EntityID -> Parent -> m ()
forall a. Component a => EntityID -> a -> m ()
forall b (m :: * -> *) a.
(MonadAccess b m, Component a) =>
EntityID -> a -> m ()
A.insert EntityID
e (Parent -> m ()) -> (EntityID -> Parent) -> EntityID -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityID -> Parent
Parent (EntityID -> m ()) -> EntityID -> m ()
forall a b. (a -> b) -> a -> b
$ EntityID
entity) Set EntityID
children
          )
          [(EntityID, Set EntityID, Maybe ChildState)]
childRes
    )
    -<
      ([(EntityID, EntityID, Maybe ParentState)]
parents, [(EntityID, Set EntityID, Maybe ChildState)]
children)

data Hierarchy a = Node
  { forall a. Hierarchy a -> EntityID
nodeEntityId :: EntityID,
    forall a. Hierarchy a -> a
nodeEntity :: a,
    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)

toList :: Hierarchy a -> [(EntityID, a)]
toList :: forall a. Hierarchy a -> [(EntityID, a)]
toList Hierarchy a
n = (Hierarchy a -> EntityID
forall a. Hierarchy a -> EntityID
nodeEntityId Hierarchy a
n, Hierarchy a -> a
forall a. Hierarchy a -> a
nodeEntity Hierarchy a
n) (EntityID, a) -> [(EntityID, a)] -> [(EntityID, a)]
forall a. a -> [a] -> [a]
: (Hierarchy a -> [(EntityID, a)])
-> [Hierarchy a] -> [(EntityID, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Hierarchy a -> [(EntityID, a)]
forall a. Hierarchy a -> [(EntityID, a)]
toList (Hierarchy a -> [Hierarchy a]
forall a. Hierarchy a -> [Hierarchy a]
nodeChildren Hierarchy a
n)

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))

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))

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))

hierarchy ::
  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>
  EntityID ->
  q i a ->
  arr i (Maybe (Hierarchy a))
hierarchy :: forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
(ArrowQueryReader q, ArrowDynamicQueryReader q,
 ArrowReaderSystem q arr) =>
EntityID -> q i a -> arr i (Maybe (Hierarchy a))
hierarchy EntityID
e q i a
q = proc i
i -> do
  [(EntityID, (Set EntityID, a))]
children <-
    q i (EntityID, (Set EntityID, a))
-> arr i [(EntityID, (Set EntityID, a))]
forall i a. q i a -> arr i [a]
forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
ArrowReaderSystem q arr =>
q i a -> arr i [a]
S.all
      ( proc i
i -> do
          EntityID
entity <- q () EntityID
forall (arr :: * -> * -> *).
ArrowDynamicQueryReader arr =>
arr () EntityID
Q.entity -< ()
          Children Set EntityID
cs <- q () Children
forall a. Component a => q () a
forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () a
Q.fetch -< ()
          a
a <- q i a
q -< i
i
          q (EntityID, (Set EntityID, a)) (EntityID, (Set EntityID, a))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (EntityID
entity, (Set EntityID
cs, a
a))
      )
      -<
        i
i
  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))]
children
  arr (Maybe (Hierarchy a)) (Maybe (Hierarchy a))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< 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 with the given query.
hierarchies ::
  (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>
  q i a ->
  arr i [Hierarchy a]
hierarchies :: forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
(ArrowQueryReader q, ArrowDynamicQueryReader q,
 ArrowReaderSystem q arr) =>
q i a -> arr i [Hierarchy a]
hierarchies q i a
q = proc i
i -> do
  [(EntityID, (Set EntityID, a))]
children <-
    q i (EntityID, (Set EntityID, a))
-> arr i [(EntityID, (Set EntityID, a))]
forall i a. q i a -> arr i [a]
forall (q :: * -> * -> *) (arr :: * -> * -> *) i a.
ArrowReaderSystem q arr =>
q i a -> arr i [a]
S.all
      ( proc i
i -> do
          EntityID
entity <- q () EntityID
forall (arr :: * -> * -> *).
ArrowDynamicQueryReader arr =>
arr () EntityID
Q.entity -< ()
          Children Set EntityID
cs <- q () Children
forall a. Component a => q () a
forall (arr :: * -> * -> *) a.
(ArrowQueryReader arr, Component a) =>
arr () a
Q.fetch -< ()
          a
a <- q i a
q -< i
i
          q (EntityID, (Set EntityID, a)) (EntityID, (Set EntityID, a))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (EntityID
entity, (Set EntityID
cs, a
a))
      )
      -<
        i
i
  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))]
children
  [EntityID]
roots <- q () EntityID -> QueryFilter -> arr () [EntityID]
forall a. q () a -> QueryFilter -> arr () [a]
forall (q :: * -> * -> *) (arr :: * -> * -> *) a.
ArrowReaderSystem q arr =>
q () a -> QueryFilter -> arr () [a]
S.filter q () EntityID
forall (arr :: * -> * -> *).
ArrowDynamicQueryReader arr =>
arr () EntityID
Q.entity (QueryFilter -> arr () [EntityID])
-> QueryFilter -> arr () [EntityID]
forall a b. (a -> b) -> a -> b
$ forall a. Component a => QueryFilter
with @Children QueryFilter -> QueryFilter -> QueryFilter
forall a. Semigroup a => a -> a -> a
<> forall a. Component a => QueryFilter
without @Parent -< ()
  arr [Hierarchy a] [Hierarchy a]
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (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) [EntityID]
roots

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