{-# 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
  { Systems
-> IORef
     (Map
        (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)]))
systemMap :: IORef (Map (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)]))
  }
  deriving anyclass (Typeable Systems
[HookRel Systems]
[Hook Systems]
Set DefaultComponentType
IsExclusive (IsExclusiveRel Systems)
(Typeable Systems, IsExclusive (IsExclusiveRel Systems)) =>
Set DefaultComponentType
-> [Hook Systems]
-> [Hook Systems]
-> [Hook Systems]
-> [HookRel Systems]
-> [HookRel Systems]
-> [HookRel Systems]
-> Component Systems
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook Systems]
onAdd :: [Hook Systems]
$conSet :: [Hook Systems]
onSet :: [Hook Systems]
$conRemove :: [Hook Systems]
onRemove :: [Hook Systems]
$conAddRel :: [HookRel Systems]
onAddRel :: [HookRel Systems]
$conSetRel :: [HookRel Systems]
onSetRel :: [HookRel Systems]
$conRemoveRel :: [HookRel Systems]
onRemoveRel :: [HookRel Systems]
Component)

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

instance Component SystemFunction where
  required :: Set DefaultComponentType
required = forall b. RequiredBundle b => Set DefaultComponentType
forall {k} (b :: k). RequiredBundle b => Set DefaultComponentType
require @(SystemTick, LastSystemTick)

newSystems :: IO Systems
newSystems :: IO Systems
newSystems = do
  !systemMap <- Map (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)])
-> IO
     (IORef
        (Map
           (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)])))
forall a. a -> IO (IORef a)
newIORef Map (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)])
forall k a. Map k a
Map.empty
  pure Systems {systemMap}

getSystemId' :: (HasCallStack) => ScheduleId -> System () -> StableName (System ()) -> IORef [(StableName (System ()), SystemId)] -> System SystemId
getSystemId' :: HasCallStack =>
ScheduleId
-> System ()
-> StableName (System ())
-> IORef [(StableName (System ()), SystemId)]
-> System SystemId
getSystemId' !ScheduleId
schedule !System ()
system !StableName (System ())
stableName !IORef [(StableName (System ()), SystemId)]
list = do
  !list' <- IO [(StableName (System ()), SystemId)]
-> System [(StableName (System ()), SystemId)]
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(StableName (System ()), SystemId)]
 -> System [(StableName (System ()), SystemId)])
-> IO [(StableName (System ()), SystemId)]
-> System [(StableName (System ()), SystemId)]
forall a b. (a -> b) -> a -> b
$ IORef [(StableName (System ()), SystemId)]
-> IO [(StableName (System ()), SystemId)]
forall a. IORef a -> IO a
readIORef IORef [(StableName (System ()), SystemId)]
list
  case find (\(StableName (System ()), SystemId)
x -> (StableName (System ()), SystemId) -> StableName (System ())
forall a b. (a, b) -> a
fst (StableName (System ()), SystemId)
x StableName (System ()) -> StableName (System ()) -> Bool
forall a b. StableName a -> StableName b -> Bool
`eqStableName` StableName (System ())
stableName) list' of
    Just (StableName (System ())
_, !SystemId
x) -> SystemId -> System SystemId
forall a. a -> System a
forall (m :: * -> *) a. Monad m => a -> m a
return SystemId
x
    Maybe (StableName (System ()), SystemId)
Nothing -> do
      !index <- (SystemFunction, Rel ScheduledIn) -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn (System () -> SystemFunction
SystemFunction System ()
system, ScheduledIn -> Entity -> Rel ScheduledIn
forall c. c -> Entity -> Rel c
Rel ScheduledIn
ScheduledIn ScheduleId
schedule.id)
      liftIO $ modifyIORef' list (++ [(stableName, SystemId index)])
      pure $ SystemId index

getSystemId :: (HasCallStack) => ScheduleId -> System () -> System SystemId
getSystemId :: HasCallStack => ScheduleId -> System () -> System SystemId
getSystemId !ScheduleId
sch !System ()
system = do
  Systems {systemMap} <- Maybe Systems -> Systems
forall (f :: * -> *) a. (HasCallStack, Unwrappable f) => f a -> a
unwrap (Maybe Systems -> Systems)
-> System (Maybe Systems) -> System Systems
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @Systems)

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

  case Map.lookup (sch, hashStableName stableName) systemMap' of
    Just !IORef [(StableName (System ()), SystemId)]
x -> HasCallStack =>
ScheduleId
-> System ()
-> StableName (System ())
-> IORef [(StableName (System ()), SystemId)]
-> System SystemId
ScheduleId
-> System ()
-> StableName (System ())
-> IORef [(StableName (System ()), SystemId)]
-> System SystemId
getSystemId' ScheduleId
sch System ()
system StableName (System ())
stableName IORef [(StableName (System ()), SystemId)]
x
    Maybe (IORef [(StableName (System ()), SystemId)])
Nothing -> do
      !l <- IO (IORef [(StableName (System ()), SystemId)])
-> System (IORef [(StableName (System ()), SystemId)])
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [(StableName (System ()), SystemId)])
 -> System (IORef [(StableName (System ()), SystemId)]))
-> IO (IORef [(StableName (System ()), SystemId)])
-> System (IORef [(StableName (System ()), SystemId)])
forall a b. (a -> b) -> a -> b
$ [(StableName (System ()), SystemId)]
-> IO (IORef [(StableName (System ()), SystemId)])
forall a. a -> IO (IORef a)
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 (System ())
-> IORef [(StableName (System ()), SystemId)] -> System ()
removeSystemFromMap' !StableName (System ())
stableName !IORef [(StableName (System ()), SystemId)]
list = do
  IO () -> System ()
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> System ()) -> IO () -> System ()
forall a b. (a -> b) -> a -> b
$ IORef [(StableName (System ()), SystemId)]
-> ([(StableName (System ()), SystemId)]
    -> [(StableName (System ()), SystemId)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [(StableName (System ()), SystemId)]
list (([(StableName (System ()), SystemId)]
  -> [(StableName (System ()), SystemId)])
 -> IO ())
-> ([(StableName (System ()), SystemId)]
    -> [(StableName (System ()), SystemId)])
-> IO ()
forall a b. (a -> b) -> a -> b
$ ((StableName (System ()), SystemId) -> Bool)
-> [(StableName (System ()), SystemId)]
-> [(StableName (System ()), SystemId)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StableName (System ()), SystemId)
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (StableName (System ()), SystemId) -> StableName (System ())
forall a b. (a, b) -> a
fst (StableName (System ()), SystemId)
x StableName (System ()) -> StableName (System ()) -> Bool
forall a b. StableName a -> StableName b -> Bool
`eqStableName` StableName (System ())
stableName)

removeSystemFromMap :: ScheduleId -> System () -> System ()
removeSystemFromMap :: ScheduleId -> System () -> System ()
removeSystemFromMap !ScheduleId
sch !System ()
system = do
  Systems {systemMap} <- Maybe Systems -> Systems
forall (f :: * -> *) a. (HasCallStack, Unwrappable f) => f a -> a
unwrap (Maybe Systems -> Systems)
-> System (Maybe Systems) -> System Systems
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
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 :: forall {k} (sch :: k).
(HasCallStack, Schedule sch) =>
System () -> System Entity
systemEntity !System ()
s = do
  !schId <- forall (sch :: k). Schedule sch => System Entity
forall {k} (sch :: k). Schedule sch => System Entity
scheduleEntity @sch
  !x <- getSystemId (ScheduleId schId) s
  pure x.id

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

data ScheduledIn = ScheduledIn deriving (Typeable ScheduledIn
[HookRel ScheduledIn]
[Hook ScheduledIn]
Set DefaultComponentType
IsExclusive (IsExclusiveRel ScheduledIn)
(Typeable ScheduledIn, IsExclusive (IsExclusiveRel ScheduledIn)) =>
Set DefaultComponentType
-> [Hook ScheduledIn]
-> [Hook ScheduledIn]
-> [Hook ScheduledIn]
-> [HookRel ScheduledIn]
-> [HookRel ScheduledIn]
-> [HookRel ScheduledIn]
-> Component ScheduledIn
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook ScheduledIn]
onAdd :: [Hook ScheduledIn]
$conSet :: [Hook ScheduledIn]
onSet :: [Hook ScheduledIn]
$conRemove :: [Hook ScheduledIn]
onRemove :: [Hook ScheduledIn]
$conAddRel :: [HookRel ScheduledIn]
onAddRel :: [HookRel ScheduledIn]
$conSetRel :: [HookRel ScheduledIn]
onSetRel :: [HookRel ScheduledIn]
$conRemoveRel :: [HookRel ScheduledIn]
onRemoveRel :: [HookRel ScheduledIn]
Component)

getSystemTicks :: World -> IO (Tick, Tick)
getSystemTicks :: World -> IO (Tick, Tick)
getSystemTicks !World
world = do
  let (SystemId !Entity
sys) = World
world.systemId
  System (Tick, Tick) -> World -> IO (Tick, Tick)
forall a. System a -> World -> IO a
runSystem
    ( do
        Just (!a, !b) <- Query System (LastSystemTick, SystemTick)
-> System (Maybe (LastSystemTick, SystemTick))
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single (Query System (LastSystemTick, SystemTick)
 -> System (Maybe (LastSystemTick, SystemTick)))
-> Query System (LastSystemTick, SystemTick)
-> System (Maybe (LastSystemTick, SystemTick))
forall a b. (a -> b) -> a -> b
$ Entity
-> (C LastSystemTick, C SystemTick)
-> Query System (LastSystemTick, SystemTick)
forall qd out (m :: * -> *).
Queryable qd out =>
Entity -> qd -> Query m out
mkGet Entity
sys (forall a. C a
forall {k} (a :: k). C a
C @LastSystemTick, forall a. C a
forall {k} (a :: k). C a
C @SystemTick)
        return (a.inner, b.inner)
    )
    World
world