Systems.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.ECS.App.Systems where

import Control.Monad.IO.Class
import Data.Foldable
import Data.IORef
import Data.Map (Map)
import Data.Map qualified as Map
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.Required
import Mischief.ECS.Entities
import Mischief.ECS.Resources
import Mischief.ECS.Utils
import Mischief.ECS.World
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.Markers
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
  pure 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)])
      pure $ 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 :: forall sch. (HasCallStack, Schedule sch) => System () -> System Entity
systemEntity !s = do
  !schId <- scheduleEntity @sch
  !x <- getSystemId (ScheduleId schId) s
  pure x.id

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

data ScheduledIn = ScheduledIn deriving (Component)

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