module Mischief.ECS.World.Defer where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Foldable
import Data.Functor
import Data.IORef
import GHC.Float (float2Int)
import Mischief.ECS.World

-- | Defer a System. This will put it in the current deferred queue which is typically flushed in-between scheduled systems.
--
-- This is useful for executing mutations in parallel systems.
--
-- You can manually flush the queue with 'flush'.
defer :: (MonadSystem w m) => System a -> m ()
defer :: forall w (m :: * -> *) a. MonadSystem w m => System a -> m ()
defer System a
s =
  System () -> ParSystem () -> m ()
forall a. System a -> ParSystem a -> m a
forall (m :: * -> *) a.
SystemAny m =>
System a -> ParSystem a -> m a
systemAny
    ( do
        world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
        liftIO $ modifyIORef' world.deferred (++ [s $> ()])
    )
    ( do
        ParWorld {parDeferred = !parDeferred} <- ParSystem ParWorld
forall r (m :: * -> *). MonadReader r m => m r
ask
        liftIO $ modifyIORef' parDeferred (++ [s $> ()])
    )

-- | Flush the current list of deferred commands.
flush :: System ()
flush :: System ()
flush = do
  !world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  !systems <- liftIO $ readIORef world.deferred

  for_ systems $ \(!System ()
s) -> do
    System () -> System ()
forall a. System a -> System a
forkDefer (System () -> System ()) -> System () -> System ()
forall a b. (a -> b) -> a -> b
$ do
      System ()
s
      System ()
flush

  liftIO $ writeIORef world.deferred []

-- | Flush the current list of deferred async commands.
flushAsync :: System ()
flushAsync :: System ()
flushAsync = do
  !world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld

  !systems <- liftIO $ atomically $ do
    !systems <- readTVar world.deferredAsync
    writeTVar world.deferredAsync []
    pure systems

  for_ systems $ \(!System ()
s) -> do
    System () -> System ()
forall a. System a -> System a
forkDefer (System () -> System ()) -> System () -> System ()
forall a b. (a -> b) -> a -> b
$ do
      System ()
s
      System ()
flush

forkDefer :: System a -> System a
forkDefer :: forall a. System a -> System a
forkDefer !System a
s = do
  !world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  !deferred <- liftIO $ newIORef []

  let !world' = IORef [System ()] -> World -> World
setDeferred IORef [System ()]
deferred World
world
  !a <- liftIO $ runSystem s world'

  !deferred <- liftIO $ readIORef deferred
  liftIO $ modifyIORef' world.deferred (++ deferred)
  pure a

-- | Run an IO action asynchronously before running a System with its output. Useful when performing significant IO such as reading / loading files.
runAfter :: (MonadSystem w m) => IO a -> (a -> System ()) -> m ()
runAfter :: forall w (m :: * -> *) a.
MonadSystem w m =>
IO a -> (a -> System ()) -> m ()
runAfter !IO a
function !a -> System ()
system = do
  !world <- m World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  _ <- liftIO $ forkIO $ do
    !a <- function
    atomically $ modifyTVar' world.deferredAsync (++ [system a])

  pure ()

-- | Delay a system by a given amount of seconds.
--
-- Example:
--
-- @
-- delay 1.5 $ insert (Health 100) player
-- @
delay :: (MonadSystem w m) => Float -> System a -> m ()
delay :: forall w (m :: * -> *) a.
MonadSystem w m =>
Float -> System a -> m ()
delay !Float
d !System a
system = IO () -> (() -> System ()) -> m ()
forall w (m :: * -> *) a.
MonadSystem w m =>
IO a -> (a -> System ()) -> m ()
runAfter (Int -> IO ()
threadDelay (Float -> Int
float2Int (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ Float
1000000 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
d)) (System a -> System ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (System a -> System ()) -> (() -> System a) -> () -> System ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. System a -> () -> System a
forall a b. a -> b -> a
const System a
system)