Spawn.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.ECS.Components.Spawn where

import Control.Monad
import Control.Monad.IO.Class
import Data.Data
import Data.Default
import Data.Foldable
-- import Mischief.ECS.Components.Hooks
-- import Mischief.ECS.World.Defer
-- import Mischief.ECS.World.Insert

-- import Mischief.ECS.Events

import Data.HashTable.IO qualified as H
import GHC.Base (Word (..))
import Mischief.ECS.Components
import Mischief.ECS.Components.Common
import Mischief.ECS.Components.HooksDef
import Mischief.ECS.Components.Required (requireAll)
import Mischief.ECS.Entities
import Mischief.ECS.World

-- import Mischief.ECS.World.Spawn

-- | Get the id of a component - entity pair. In case the component isn't registered, it will give it a new id.
getOrAddPairId :: Pair -> System ComponentId
getOrAddPairId (Pair (!t, !entity)) = do
  (ComponentId (# !id, _ #)) <- getOrAddComponentId t
  pure $ ComponentId (# id, Just entity #)

-- | Get the id of a component. In case the component isn't registered, it will give it a new id.
getOrAddComponentId :: ComponentType -> System ComponentId
getOrAddComponentId (ComponentType (_ :: Proxy c)) = do
  !world <- unsafeGetWorld
  let !comp = world.components
  !w <- liftIO $ H.lookup comp.components (typeRep $ Proxy @c)

  case w of
    Just (W# !t) -> pure $ ComponentId (# t, Nothing #)
    Nothing -> do
      !result <- liftIO $ getNewEntityComp world.entities
      let !(Entity (# !id, _ #)) = result

      liftIO $ H.insert comp.components (typeRep $ Proxy @c) (W# id)
      -- liftIO $ modifyIORef' comp.components $ Map.insert (typeRep $ Proxy @c) (W# id)

      -- l <- liftIO $ newIORef Set.empty
      -- liftIO $ modifyIORef' comp.archetypes $ Map.insert result l

      setPref @SupressEventsPref True $
        worldSpawnByInsert
          result
          ( ( ComponentType $ Proxy @c,
              def @ComponentPairs
            ),
            Name $
              "Meta entity for " ++ show (typeRep $ Proxy @c)
          )

      when (isExclusive @(IsExclusiveRel c)) $ do
        worldSet IsExclusiveRelationship result

      for_ (requireAll @c) $ \(DefaultComponentType (_ :: (Proxy other))) -> do
        (ComponentId (# !otherId', _ #)) <- getOrAddComponentId (ComponentType $ Proxy @other)

        let !otherId = Entity (# otherId', 0## #)
        worldSet (Rel RequiredBy result) otherId
        worldSet (Rel Requires otherId) result
        worldSet (DefaultValue $ ErasedComponent $ def @other) otherId

      registerHooks @c result

      pure $ ComponentId (# id, Nothing #)

-- l <- liftIO $ newIORef Set.empty
-- liftIO $ modifyIORef' archetypes $ Map.insert id l

-- | Return the meta entity corresponding to a given component.
meta :: forall c. (Component c) => System Entity
meta = do
  (ComponentId (# !id, _ #)) <- getOrAddComponentId (ComponentType $ Proxy @c)
  pure $ Entity (# id, 0## #)

tryMeta :: forall c m w. (Component c, MonadSystem w m) => m (Maybe Entity)
tryMeta = do
  !world <- unsafeGetWorld
  !component <- liftIO $ getComponentId (typeRep $ Proxy @c) world.components
  pure $ fmap (\(ComponentId (# !id, _ #)) -> Entity (# id, 0## #)) component

registerHooks :: forall c. (Component c) => Entity -> System ()
registerHooks !entity = do
  let !a = map getHook (onAdd @c)
  let !s = map getHook (onSet @c)
  let !r = map getHook (onRemove @c)
  let !ar = map getHookRel (onAddRel @c)
  let !sr = map getHookRel (onSetRel @c)
  let !rr = map getHookRel (onRemoveRel @c)

  worldSet (ComponentAddHooks a) entity
  worldSet (ComponentSetHooks s) entity
  worldSet (ComponentRemoveHooks r) entity
  worldSet (ComponentAddHooksRel ar) entity
  worldSet (ComponentSetHooksRel sr) entity
  worldSet (ComponentRemoveHooksRel rr) entity

getHook :: Hook c -> (HookContext -> System ())
getHook (Hook (!h :: HookContext -> m ())) = do
  case eqT @m @System of
    Nothing -> undefined
    Just Refl -> h

getHookRel :: HookRel c -> (HookContextRel -> System ())
getHookRel (HookRel (!h :: HookContextRel -> m ())) = do
  case eqT @m @System of
    Nothing -> undefined
    Just Refl -> h

-- registerHook :: ErasedHook c -> System ()
-- registerHook (ErasedHook (h :: e c -> m ())) = do
--   world <- unsafeGetWorld
--   e <- liftIO $ getNewEntity world.entities
--   case eqT @m @System of
--     Just Refl -> void $ worldSpawnByInsert e $ Observer h
--     Nothing -> undefined

newtype ComponentAddHooks = ComponentAddHooks [HookContext -> System ()] deriving anyclass (Component)

newtype ComponentSetHooks = ComponentSetHooks [HookContext -> System ()] deriving anyclass (Component)

newtype ComponentRemoveHooks = ComponentRemoveHooks [HookContext -> System ()] deriving anyclass (Component)

newtype ComponentAddHooksRel = ComponentAddHooksRel [HookContextRel -> System ()] deriving anyclass (Component)

newtype ComponentSetHooksRel = ComponentSetHooksRel [HookContextRel -> System ()] deriving anyclass (Component)

newtype ComponentRemoveHooksRel = ComponentRemoveHooksRel [HookContextRel -> System ()] deriving anyclass (Component)