content: {-|
  Stability: experimental
  
  This module is experimental, and its API might change between point releases.
  Use at your own risk.
  
  The default relation between an entity and a component value is one to zero
  or one. The entity may or may not have a value for the component, but if the
  component value exists, it belongs to an entity. This module enables setting
  multiple "child" component values rooted under the same "parent" entity,
  providing a one to many relation: the parent entity has zero or more child
  values of the component type. Concretely, these component values are of type
  'Child' @c@, belong to their own separate entities, and are explicitly linked
  to the parent entity.
  
  Ad-hoc child relationships may be established without using this module by
  including a parent 'Entity' in your component's type, but this is limiting in
  regards to traversing the relationship. Systems concerned with the relationship
  may only start from the child entities' component(s) and then fetch the parent
  entity's component(s). By expressing the relationship using this module, you get
  support for iteration over the parent-child relationship in whichever way is
  more convenient for your systems, i.e. you can map over child entities using the
  'Child' component then fetch the child entity's parent component(s) as needed,
  or you can map over the parent entities' 'ChildList' component then fetch the
  child entities' component(s) as needed.
  
  Some example use cases for this module:
  
  - Parent entity has a position defined in world space and child entities have
  data relative to the parent's position e.g. hitboxes, sprite animations, etc.
  - Parent entity is a leader and child entities are squad members e.g. a
  necromancer can summon skeletons
  
  For an introduction to using this module, see the [associated
  example](https://github.com/jonascarpay/apecs/tree/master/examples/Children.hs).
  -}
  
  {-# LANGUAGE FlexibleContexts           #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE InstanceSigs               #-}
  {-# LANGUAGE LambdaCase                 #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  {-# LANGUAGE NamedFieldPuns             #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  {-# LANGUAGE TypeApplications           #-}
  {-# LANGUAGE TypeFamilies               #-}
  {-# LANGUAGE UndecidableInstances       #-}
  
  module Apecs.Experimental.Children
    ( -- * Component
      Child(..)
      -- * Pseudocomponents
    , ChildValue(..)
    , ChildList(..)
    ) where
  
  import Apecs.Core
  import Control.Monad.IO.Class (MonadIO(liftIO))
  import Data.Foldable (for_)
  import Data.IORef (IORef)
  import Data.IntMap.Strict (IntMap)
  import Data.IntSet (IntSet)
  import Data.List.NonEmpty (NonEmpty)
  import Type.Reflection (TypeRep, Typeable, typeRep)
  
  import qualified Data.IORef as IORef
  import qualified Data.IntMap.Strict as M
  import qualified Data.IntSet as S
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Vector.Unboxed as U
  
  -- | The 'Child' component wraps the parent entity and the child entity's
  -- underlying component value.
  --
  -- If you want a @Foo@ component in your game to be treated as a child
  -- component, specify the component type as @Child Foo@ when declaring your
  -- world:
  --
  -- > newtype Hitbox = Hitbox AABB deriving Show
  -- > instance Component Hitbox where type Storage Hitbox = Map Hitbox
  -- >
  -- > -- A type alias solely for TH quoting's sake.
  -- > type ChildHitbox = Child Hitbox
  -- >
  -- > makeWorld "World" [''ChildHitbox]
  --
  -- If your system is iterating over the 'Child' component but does not need the
  -- parent entity, use the 'ChildValue' pseudocomponent instead for better
  -- performance.
  --
  -- Note that if you delete a parent entity (i.e. 'Apecs.System.destroy'
  -- all of the parent entity's components), consider a
  -- 'Apecs.System.destroy' on the parent entity's children too. See
  -- 'ChildList' for assistance on this. This is more from a memory
  -- management point of view than one of safety: nothing via standard
  -- usage of this library will break if a child "outlives" its
  -- parent. However, both trying to directly 'Apecs.System.get' some
  -- component value of a child's non-existent parent or trying to
  -- directly 'Apecs.System.get' a parent's non-existent 'ChildList' will
  -- result in runtime errors. Raw use of 'Apecs.System.get' is inherently
  -- dangerous and its risk is not specific to the behavior provided by
  -- this module.
  data Child c = Child !Entity !c deriving (Eq, Show)
  instance Component c => Component (Child c) where
    type Storage (Child c) = Children (Storage c)
  
  -- | 'Children' augments another store with support for one-to-many parent-child
  -- relationships.
  --
  -- This wrapper is not exported. If the user wants a @Foo@ component to be
  -- treated as a child component, they declare their component when building
  -- their world as type @Child Foo@. This will cause the @Children@ store wrapper
  -- to be used via the @Storage@/@Elem@ type relation.
  data Children s = Children
    { childrenParentToChildren :: !(IORef (IntMap IntSet))
    , childrenChildToParent :: !(IORef (IntMap Int))
    , childrenDelegate :: !s
    }
  type instance Elem (Children s) = Child (Elem s)
  
  instance (MonadIO m, ExplInit m s) => ExplInit m (Children s) where
    {-# INLINE explInit #-}
    explInit :: m (Children s)
    explInit = do
      childrenDelegate <- explInit
      liftIO $ do
        childrenParentToChildren <- IORef.newIORef M.empty
        childrenChildToParent <- IORef.newIORef M.empty
        pure Children
          { childrenParentToChildren
          , childrenChildToParent
          , childrenDelegate
          }
  
  instance (MonadIO m, ExplMembers m s) => ExplMembers m (Children s) where
    {-# INLINE explMembers #-}
    explMembers :: Children s -> m (U.Vector Int)
    explMembers (Children _ _ s) = explMembers s
  
  instance (MonadIO m, ExplGet m s, Typeable (Elem s)) => ExplGet m (Children s) where
    {-# INLINE explGet #-}
    explGet :: Children s -> Int -> m (Child (Elem s))
    explGet (Children _ childToParent s) child = do
      liftIO (M.lookup child <$> IORef.readIORef childToParent) >>= \case
        Nothing -> error $ parentNotFound (typeRep @(Elem s)) child
        Just parent -> do
          component <- explGet s child
          pure $ Child (Entity parent) component
  
    {-# INLINE explExists #-}
    explExists :: Children s -> Int -> m Bool
    explExists (Children _ _ s) = explExists s
  
  instance (MonadIO m, ExplSet m s) => ExplSet m (Children s) where
    {-# INLINE explSet #-}
    explSet :: Children s -> Int -> Child (Elem s) -> m ()
    explSet (Children parentToChildren childToParent s) child (Child (Entity parent) x) = do
      explSet s child x
      liftIO $ do
        (mPrevParent, childToParentMap') <-
          M.insertLookupWithKey insertChildToParent child parent
            <$> IORef.readIORef childToParent
        -- @insertLookupWithKey@ uses a @StrictPair@ internally for its result
        -- before converting to standard pair, so there's no need to evaluate
        -- @childToParentMap'@ here before writing it to the @IORef@.
        IORef.writeIORef childToParent childToParentMap'
        IORef.modifyIORef' parentToChildren
          $ M.insertWith S.union parent (S.singleton child)
          . case mPrevParent of
              -- If the child was previously mapped to a different parent, be sure
              -- to clean up the old mapping from parent to child.
              Just prevParent | prevParent /= parent ->
                M.update (deleteParentToChild child) prevParent
              _ -> id
      where
      insertChildToParent :: M.Key -> Int -> Int -> Int
      insertChildToParent _k newParent _prevParent = newParent
  
  instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Children s) where
    {-# INLINE explDestroy #-}
    explDestroy :: Children s -> Int -> m ()
    explDestroy (Children parentToChildren childToParent s) child = do
      explDestroy s child
      liftIO $ do
        childToParentMap <- IORef.readIORef childToParent
        case M.updateLookupWithKey deleteChildToParent child childToParentMap of
          (Nothing, _) -> do
            -- If the parent entity can't be found, assume the child was
            -- previously destroyed.
            pure ()
          (Just parent, childToParentMap') -> do
            -- @updateLookupWithKey@ uses a @StrictPair@ internally for its result
            -- before converting to standard pair, so there's no need to evaluate
            -- @childToParentMap'@ here before writing it to the @IORef@.
            IORef.writeIORef childToParent childToParentMap'
            IORef.modifyIORef' parentToChildren
              $ M.update (deleteParentToChild child) parent
      where
      deleteChildToParent :: M.Key -> Int -> Maybe Int
      deleteChildToParent _k _v = Nothing
  
  -- | Accessor pseudocomponent that produces just the underlying component value
  -- as opposed to 'Child' which also produces the parent entity.
  --
  -- For best performance, you should prefer 'ChildValue' over 'Child' if your
  -- system is iterating over children and does not need the parent entities.
  newtype ChildValue c = ChildValue c deriving (Eq, Show)
  instance Component c => Component (ChildValue c) where
    type Storage (ChildValue c) = ChildValueStore (Storage c)
  
  newtype ChildValueStore s = ChildValueStore (Children s)
  type instance Elem (ChildValueStore s) = ChildValue (Elem s)
  
  instance (MonadIO m, Component c, Has w m (Child c)) => Has w m (ChildValue c) where
    {-# INLINE getStore #-}
    getStore :: SystemT w m (Storage (ChildValue c))
    getStore = ChildValueStore <$> getStore
  
  instance ExplMembers m s => ExplMembers m (ChildValueStore s) where
    {-# INLINE explMembers #-}
    explMembers :: ChildValueStore s -> m (U.Vector Int)
    explMembers (ChildValueStore (Children _ _ s)) = explMembers s
  
  instance ExplGet m s => ExplGet m (ChildValueStore s) where
    {-# INLINE explExists #-}
    explExists :: ChildValueStore s -> Int -> m Bool
    explExists (ChildValueStore (Children _ _ s)) = explExists s
  
    {-# INLINE explGet #-}
    explGet :: ChildValueStore s -> Int -> m (ChildValue (Elem s))
    explGet (ChildValueStore (Children _ _ s)) child =
      ChildValue <$> explGet s child
  
  -- | Pseudocomponent that produces all child entities for a parent.
  --
  -- A useful property of this pseudocomponent is that it may be destroyed, which
  -- does a cascading 'Apecs.System.destroy' on all of the parent's children:
  --
  -- > -- Remove all of player 1 entity's hitboxes:
  -- > destroy player1 $ Proxy @(ChildList Hitbox)
  --
  -- The cascading 'Apecs.System.destroy' behavior is provided for convenience,
  -- but note that if you assigned additional components to the child entities,
  -- those components will not be destroyed. In this case, you should destroy
  -- all components on the children explicitly, e.g.:
  --
  -- > ChildList children :: ChildList Hitbox <- get player1
  -- > for_ children $ \child -> do
  -- >   destroy child $ Proxy @ComponentsToDestroy
  newtype ChildList c = ChildList (NonEmpty Entity) deriving (Eq, Show)
  instance Component c => Component (ChildList c) where
    type Storage (ChildList c) = ChildListStore (Storage c)
  
  newtype ChildListStore s = ChildListStore (Children s)
  type instance Elem (ChildListStore s) = ChildList (Elem s)
  
  instance (MonadIO m, Component c, Has w m (Child c)) => Has w m (ChildList c) where
    {-# INLINE getStore #-}
    getStore :: SystemT w m (Storage (ChildList c))
    getStore = ChildListStore <$> getStore
  
  instance MonadIO m => ExplMembers m (ChildListStore s) where
    {-# INLINE explMembers #-}
    explMembers :: ChildListStore s -> m (U.Vector Int)
    explMembers (ChildListStore (Children parentToChildren _ _)) = do
      liftIO $ U.fromList . M.keys <$> IORef.readIORef parentToChildren
  
  instance (MonadIO m, Typeable (Elem s)) => ExplGet m (ChildListStore s) where
    {-# INLINE explExists #-}
    explExists :: ChildListStore s -> Int -> m Bool
    explExists (ChildListStore (Children parentToChildren _ _)) parent = do
      liftIO $ M.member parent <$> IORef.readIORef parentToChildren
  
    {-# INLINE explGet #-}
    explGet :: ChildListStore s -> Int -> m (ChildList (Elem s))
    explGet (ChildListStore (Children parentToChildren _ _)) parent = do
      liftIO (toNE . M.lookup parent <$> IORef.readIORef parentToChildren) >>= \case
        Nothing -> error $ parentNotFound (typeRep @(Elem s)) parent
        Just children -> pure $ ChildList children
      where
      toNE :: Maybe IntSet -> Maybe (NonEmpty Entity)
      toNE mChildEnts
        | Just childEnts <- mChildEnts = NE.nonEmpty (Entity <$> S.elems childEnts)
        | otherwise = Nothing
  
  instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (ChildListStore s) where
    {-# INLINE explDestroy #-}
    explDestroy :: ChildListStore s -> Int -> m ()
    explDestroy (ChildListStore children@(Children parentToChildren _ _)) parent = do
      liftIO (M.lookup parent <$> IORef.readIORef parentToChildren) >>= \case
        Nothing -> pure ()
        Just childSet -> do
          for_ (S.elems childSet) $ \child -> do
            explDestroy children child
  
  deleteParentToChild :: Int -> IntSet -> Maybe IntSet
  deleteParentToChild child v
    | v' <- S.delete child v, not $ S.null v' = Just v'
    | otherwise = Nothing
  
  parentNotFound :: TypeRep a -> Int -> String
  parentNotFound tyRep ety =
    unwords
      [ "Reading non-existent parent entity for child component of type"
      , show tyRep
      , "for child entity"
      , show ety
      ]
  