Systems.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.ECS.App.Systems where

import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Default
import Data.Foldable
import Data.IORef
import Data.Map (Map)
import Data.Map qualified as Map
import GHC.Generics
import GHC.StableName (StableName, eqStableName, hashStableName, makeStableName)
import GHC.Stack.Types
import Mischief.ECS.App.Schedules
import Mischief.ECS.App.SystemDef
import Mischief.ECS.Components
import Mischief.ECS.Components.Bundle
import Mischief.ECS.Components.Required
import Mischief.ECS.Entities
import Mischief.ECS.Log
import Mischief.ECS.Relationships.Order
import Mischief.ECS.Resources
import Mischief.ECS.Tables
import Mischief.ECS.Utils
import Mischief.ECS.World
import Mischief.ECS.World.Insert
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.Markers
import Mischief.ECS.World.Query.Queryable
import Mischief.ECS.World.Spawn

newtype Systems = Systems
  { systemMap :: IORef (Map (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)]))
  }
  deriving anyclass (Component)

newtype SystemFunction = SystemFunction {inner :: System ()}

instance Component SystemFunction where
  required = require @(SystemTick, LastSystemTick)

newSystems :: IO Systems
newSystems = do
  systemMap <- newIORef Map.empty
  return Systems {systemMap}

getSystemId' :: (HasCallStack) => ScheduleId -> System () -> StableName (System ()) -> IORef [(StableName (System ()), SystemId)] -> System SystemId
getSystemId' schedule system stableName list = do
  list' <- liftIO $ readIORef list
  case find (\x -> fst x `eqStableName` stableName) list' of
    Just (_, x) -> return x
    Nothing -> do
      index <- spawn (SystemFunction system, Rel ScheduledIn schedule.id)
      liftIO $ modifyIORef' list (++ [(stableName, SystemId index)])
      return $ SystemId index

getSystemId :: (HasCallStack) => ScheduleId -> System () -> System SystemId
getSystemId sch system = do
  Systems {systemMap} <- unwrap <$> (res @Systems)

  stableName <- liftIO $ makeStableName system
  systemMap' <- liftIO $ readIORef systemMap

  case Map.lookup (sch, hashStableName stableName) systemMap' of
    Just x -> getSystemId' sch system stableName x
    Nothing -> do
      l <- liftIO $ newIORef []
      liftIO $ modifyIORef' systemMap (Map.insert (sch, hashStableName stableName) l)
      getSystemId' sch system stableName l

removeSystemFromMap' :: StableName (System ()) -> IORef [(StableName (System ()), SystemId)] -> System ()
removeSystemFromMap' stableName list = do
  liftIO $ modifyIORef' list $ filter (\x -> not $ fst x `eqStableName` stableName)

removeSystemFromMap :: ScheduleId -> System () -> System ()
removeSystemFromMap sch system = do
  Systems {systemMap} <- unwrap <$> (res @Systems)

  stableName <- liftIO $ makeStableName system
  systemMap' <- liftIO $ readIORef systemMap

  forM_
    (Map.lookup (sch, hashStableName stableName) systemMap')
    (removeSystemFromMap' stableName)

systemEntity :: (HasCallStack, Schedule sch) => sch -> System () -> System Entity
systemEntity sch s = do
  schId <- scheduleEntity sch
  x <- getSystemId (ScheduleId schId) s
  return x.id

self :: forall m w. (MonadSystem w m) => m Entity
self = do
  world <- unsafeGetWorld
  let (SystemId sys) = world.systemId
  return sys

data ScheduledIn = ScheduledIn deriving (Component)

getSystemTicks :: World -> IO (Tick, Tick)
getSystemTicks world = do
  let (SystemId sys) = world.systemId
  runSystem
    ( do
        Just (a, b) <- get (C @LastSystemTick, C @SystemTick) sys
        return (a.inner, b.inner)
    )
    world