Insert.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Mischief.ECS.World.Insert where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Foldable (for_)
import Data.IORef
import Data.List hiding (insert)
import Data.Maybe
import Data.Set qualified as Set
import Data.Text qualified as T
import GHC.Base (Int (..))
import GHC.Stack
import Mischief.ECS.Archetypes.Graph
  ( getArchetypeOnInsert,
  )
import Mischief.ECS.Components
import Mischief.ECS.Components.Bundle
import Mischief.ECS.Components.HooksDef (HookContext (..), HookContextRel (..))
import Mischief.ECS.Components.Spawn (ComponentAddHooks (ComponentAddHooks), ComponentAddHooksRel (ComponentAddHooksRel), ComponentSetHooks (ComponentSetHooks), ComponentSetHooksRel (ComponentSetHooksRel), meta)
import Mischief.ECS.Entities
import Mischief.ECS.Events
import Mischief.ECS.Log
import Mischief.ECS.Tables
import Mischief.ECS.Vec qualified as Vec
import Mischief.ECS.World
import Mischief.ECS.World.Change
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.Markers
import Mischief.ECS.World.Utils

data Exception' = Exception' deriving (Show)

instance Exception Exception'

-- | Insert a bundle of components on an Entity.
--
-- If the entity already contains these components, their values will be
-- updated in-place instead of causing an archetype change.
insert :: (HasCallStack) => forall b. (Bundle b) => b -> Entity -> System ()
insert !bundle !entity =
  do
    !world <- unsafeGetWorld
    !pointer <- liftIO $ getPointer entity world.entities

    case pointer of
      Nothing -> warn $ "Insertion failed: Entity " <> T.show entity <> " is not alive."
      Just !currentPointer -> do
        let BundleData {elements = !elements, resources = !resources, external = !external} = bundleData bundle

        for_ external $ \(!e, !x) -> do
          insert x e

        for_ resources $ \BundleElement {component = ErasedComponent (!val :: c)} -> do
          !m <- meta @c
          insert val m

        !currentTick <- liftIO $ readIORef world.tick

        !bundleData <- liftIO $ processBundleElements world elements
        let !newComponents = sort $ map (\(!x) -> x.id) bundleData.elements

        (EntityPointer (# !archetypeId, !rowIndex #)) <- liftIO $ readIORef currentPointer

        !currentTable <- Vec.read world.tables.inner (I# archetypeId)

        ChangeResult {requiredComponentsAdded = !requiredComponentsAdded, newComponents = !newComponents} <-
          if newComponents `isSubsequenceOf` currentTable.components
            -- Simple case, no archetype change.
            then do
              liftIO $ replaceComponentsIntoTable bundleData (Just currentTick) (EntityPointer (# archetypeId, rowIndex #)) currentTable
              pure $ ChangeResult [] []
            -- Complex case, archetype change.
            else do
              !newArchetype <- getArchetypeOnInsert (ArchetypeId $ I# archetypeId) newComponents
              changeArchetype entity newArchetype (Just bundleData)

        !supressEvents <- fromMaybe False <$> getPref @SupressEventsPref
        unless supressEvents $ do
          triggerAddEvent (ProcessedBundleData newComponents) entity
          triggerAddEvent (ProcessedBundleData requiredComponentsAdded) entity
          triggerSetEvent bundleData entity
          triggerSetEvent (ProcessedBundleData requiredComponentsAdded) entity

-- | Insert a bundle of components on an Entity.
--
-- Only the components that the entity doesn't already have will be inserted, and the rest ignored.
insertNew :: forall b. (Bundle b) => b -> Entity -> System ()
insertNew !bundle !entity =
  do
    let BundleData {elements = !elements, resources = !resources, external = !external} = bundleData bundle
    for_ external $ \(!e, !s) -> do
      insertNew s e

    !world <- unsafeGetWorld
    !pointer <- liftIO $ getPointer entity world.entities

    case pointer of
      Nothing -> warn $ "Insertion failed: Entity " <> T.show entity <> " is not alive."
      Just !currentPointer -> do
        for_ resources $ \BundleElement {component = ErasedComponent (!val :: c)} -> do
          !m <- meta @c
          !r <- single $ mkGet m (C @c)
          case r of
            Just _ -> pure ()
            Nothing -> insert val m

        !bundleData <- liftIO $ processBundleElements world elements

        (EntityPointer (# !archetypeId, _ #)) <- liftIO $ readIORef currentPointer

        !currentTable <- Vec.read world.tables.inner (I# archetypeId)

        let newComponents = ProcessedBundleData $ filter (\(!c) -> c.id `notElem` currentTable.components) bundleData.elements

        unless (null newComponents.elements) $ do
          !newArchetype <- getArchetypeOnInsert (ArchetypeId $ I# archetypeId) $ map (\(!x) -> x.id) newComponents.elements
          ChangeResult {requiredComponentsAdded} <- changeArchetype entity newArchetype (Just bundleData)

          !supressEvents <- fromMaybe False <$> getPref @SupressEventsPref
          unless supressEvents $ do
            triggerAddEvent (ProcessedBundleData requiredComponentsAdded) entity
            triggerAddEvent newComponents entity
            triggerSetEvent (ProcessedBundleData requiredComponentsAdded) entity
            triggerSetEvent newComponents entity

insertIfNeq :: forall b. (BundleEq b) => b -> Entity -> System ()
insertIfNeq !b !entity = do
  let BundleData {elements = !elements, resources = !resources, external = !external} = bundleDataEq b

  !comps <- flip filterM (Set.toList elements) $ \BundleElement {rep, component = ErasedComponentEq (!val :: c)} -> do
    !val' <- case rep of
      PairRep (_, target) -> fmap (\(!x) -> x.comp) <$> single (mkGet entity (R @c target))
      _ -> single (mkGet entity (C @c))

    case val' of
      Nothing -> pure True
      Just !val' -> pure (val /= val')

  resources <- flip filterM (Set.toList resources) $ \BundleElement {rep, component = ErasedComponentEq (!val :: c)} -> do
    !e <- meta @c
    val' <- case rep of
      ComponentRep _ -> single $ mkGet e (C @c)
      _ -> undefined

    case val' of
      Nothing -> pure True
      Just !val' -> pure (val /= val')

  for_ external $ \(!e, !external) -> do
    insertIfNeq external e

  insert (bundleEqToSimple $ BundleData (Set.fromList comps) (Set.fromList resources) Set.empty) entity

triggerAddEvent :: ProcessedBundleData -> Entity -> System ()
triggerAddEvent !bundle !entity =
  for_ bundle.elements $ \(!x) -> do
    let !(ComponentId (# _, !target #)) = x.id
    case target of
      Nothing ->
        triggerAddEventC x.component entity
      Just !target ->
        triggerAddEventR x.component target entity

triggerAddEventC :: ErasedComponent -> Entity -> System ()
triggerAddEventC (ErasedComponent (_ :: c)) !entity = do
  let !context = HookContext {entity}

  !m <- meta @c
  !hooks <- single $ mkGet m (C @ComponentAddHooks)
  for_ hooks $ \(ComponentAddHooks !h) -> do
    for_ h $ \(!h) -> h context

  trigger $ OnAdd @c entity

triggerAddEventR :: ErasedComponent -> Entity -> Entity -> System ()
triggerAddEventR (ErasedComponent (_ :: c)) !target !entity = do
  let !context = HookContextRel {entity, target}

  !m <- meta @c
  Just !hooks <- single $ mkGet m (M @ComponentAddHooksRel)
  for_ hooks $ \(ComponentAddHooksRel !h) -> do
    for_ h $ \(!h) -> h context

  trigger $ OnAddRel @c entity target

triggerSetEvent :: ProcessedBundleData -> Entity -> System ()
triggerSetEvent !bundle !entity =
  for_ bundle.elements $ \(!x) -> do
    let !(ComponentId (# _, !target #)) = x.id
    case target of
      Nothing ->
        triggerSetEventC x.component entity
      Just !target ->
        triggerSetEventR x.component target entity

triggerSetEventC :: ErasedComponent -> Entity -> System ()
triggerSetEventC (ErasedComponent (_ :: c)) !entity = do
  let !context = HookContext {entity}

  !m <- meta @c
  Just !hooks <- single $ mkGet m (M @ComponentSetHooks)
  for_ hooks $ \(ComponentSetHooks !h) -> do
    for_ h $ \(!h) -> h context

  trigger $ OnSet @c entity

triggerSetEventR :: ErasedComponent -> Entity -> Entity -> System ()
triggerSetEventR (ErasedComponent (_ :: c)) !target !entity = do
  let !context = HookContextRel {entity, target}

  !m <- meta @c
  Just !hooks <- single $ mkGet m (M @ComponentSetHooksRel)
  for_ hooks $ \(ComponentSetHooksRel !h) -> do
    for_ h $ \(!h) -> h context

  trigger $ OnSetRel @c entity target