World.hs

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

module Mischief.ECS.World
  ( -- * World
    World (..),
    newWorld,
    setSystemId,
    setDeferred,
    Frame (..),
    SystemTools (..),
    worldGet,
    worldGetRAny,
    worldSet,
    worldSpawnByInsert,

    -- * Prefs
    PrefType,
    setPref,
    getPref,
    SupressEventsPref,

    -- * Systems
    System (..),
    SystemId (..),
    runWhen,
    runSystem,
    MonadSystem,
    unsafeGetWorld,
    sysUnliftIO,
    SystemAny (..),

    -- * Parallel
    ParSystem (..),
    ParWorld (..),
    parLift,
  )
where

import Colog qualified
import Control.Concurrent.STM (TVar, newTVarIO)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Primitive (PrimMonad (..), RealWorld)
import Control.Monad.Reader.Class (MonadReader (..), asks)
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Trans.Reader (ReaderT (runReaderT))
import Data.Data
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Map (Map)
import Data.Map qualified as Map
import Mischief.ECS.Archetypes (Archetypes, emptyArchetypes)
import Mischief.ECS.Collectable
import Mischief.ECS.Components
  ( Component (IsExclusiveRel),
    Components,
    Rel,
    Tick (Tick),
    emptyComponents,
  )
import Mischief.ECS.Components.Bundle
import Mischief.ECS.Entities
  ( Entities,
    Entity (Entity),
    emptyEntities,
  )
import Mischief.ECS.Hidden
import Mischief.ECS.Tables (Tables, emptyTables)
import Mischief.ECS.Utils (ErasedValue (..), eraseValue, unsafeUneraseValue)

-- | @The World@ is the main data structure storing the entities, components, archetypes, and everything else that lives in our app.
data World = World
  { -- | Archetype storage.
    archetypes :: Archetypes,
    -- | Components storage.
    components :: Components,
    -- | Entities storage.
    entities :: Entities,
    -- | Archetype tables. Storage for the actual data of components.
    tables :: Tables,
    -- | List of deferred system to be ran at the next sync point. They can also be flushed manually using 'flush'.
    deferred :: IORef [System ()],
    -- | Secondary list of deferred systems stored in a TVar, meant to be used when running systems asynchronously.
    -- They are ran at the first available sync point, and can also be flushed manually with 'flushAsync'.
    deferredAsync :: TVar [System ()],
    -- | Systems to be tried at the next sync point. If the first system returns a Just, it is removed from the list and the second
    -- system is ran with the returned value.
    trySystems :: IORef [(System (Maybe ErasedValue), ErasedValue -> System ())],
    -- | The current tick, incremented each time a system is ran, used for change detection.
    tick :: IORef Tick,
    -- | Id of the current system.
    systemId :: SystemId,
    -- | The current frame.
    frame :: IORef Frame,
    -- | Certain toggleable settings.
    prefs :: Prefs,
    logger :: Colog.LogAction IO Colog.Message,
    loggerErr :: Colog.LogAction IO Colog.Message,
    tools :: SystemTools
  }

newtype Prefs = Prefs (Map TypeRep Pref)

data Pref where
  Pref :: (Typeable a) => a -> Pref

class (Typeable a, Typeable b) => PrefType a b | a -> b

data SupressEventsPref

instance PrefType SupressEventsPref Bool

worldSetPref :: forall a b. (PrefType a b) => b -> World -> World
worldSetPref !value !world =
  let Prefs !prefs = world.prefs
   in world {prefs = Prefs $ Map.insert (typeRep $ Proxy @a) (Pref value) prefs}

worldGetPref :: forall a b. (PrefType a b) => World -> Maybe b
worldGetPref World {prefs = Prefs !prefs} = worldGetPref' @a =<< Map.lookup (typeRep $ Proxy @a) prefs

worldGetPref' :: forall a b. (PrefType a b) => Pref -> Maybe b
worldGetPref' (Pref (!s :: a')) =
  case eqT @a' @b of
    Just Refl -> Just s
    Nothing -> Nothing

setPref :: forall a b c. (PrefType a b) => b -> System c -> System c
setPref !value !s = do
  !world <- unsafeGetWorld
  let world' = worldSetPref @a value world
  liftIO $ runSystem s world'

getPref :: forall a m b w. (PrefType a b, MonadSystem w m) => m (Maybe b)
getPref = worldGetPref @a <$> unsafeGetWorld

newtype Frame = Frame Int deriving (Show, Eq, Ord)

-- | Unique id assigned to each system that's added to a schedule. Just a wrapper around Entity.
newtype SystemId = SystemId {id :: Entity} deriving (Show, Eq, Ord)

-- | Create a new World in IO.
newWorld :: SystemTools -> IO World
newWorld !tools = do
  !archetypes <- emptyArchetypes
  !components <- emptyComponents
  !entities <- emptyEntities
  !tables <- emptyTables
  !deferred <- newIORef []
  !deferredAsync <- newTVarIO []
  !tick <- newIORef (Tick 0)
  !frame <- newIORef (Frame 0)
  !trySystems <- newIORef []
  let !prefs = Prefs Map.empty

  let !logger = Colog.cmap Colog.fmtMessage Colog.logTextStdout
  let !loggerErr = Colog.cmap Colog.fmtMessage Colog.logTextStderr

  pure
    World
      { archetypes,
        components,
        entities,
        tables,
        deferred,
        deferredAsync,
        tick,
        systemId = SystemId (Entity (# 0##, 0## #)),
        frame,
        prefs,
        logger,
        loggerErr,
        trySystems,
        tools
      }

-- | Change the current SystemId of the World.
setSystemId :: SystemId -> World -> World
setSystemId !systemId !world = world {systemId}

-- | Set the list of deferred systems of the World.
setDeferred :: IORef [System ()] -> World -> World
setDeferred !deferred !world = world {deferred}

-- | A System is a monad that mutates the World.
--
-- It can be added to a certain schedule and ordered with other systems.
-- It also offers IO access via 'liftIO'.
--
-- Read the [tutorial]("Mischief.ECS.Tutorial.Systems") on systems for more details.
newtype System a = System (ReaderT (Hidden World) IO a)
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Hidden World), MonadFail, MonadThrow)

-- | Run a 'System' with the given 'World' inside 'IO'
runSystem :: System a -> World -> IO a
runSystem (System !r) !w = runReaderT r (hide w)

-- runSystem' :: (MonadSystem w m) => m a -> World -> IO a
-- runSystem' (System !r) w =

instance PrimMonad System where
  type PrimState System = PrimState IO
  primitive = System . lift . primitive

-- | Special wrapper around World given to 'ParSystem's.
data ParWorld = ParWorld
  { -- | @Hidden@ ensures users cannot access and mutate the World.
    world :: Hidden World,
    -- | Deferred systems will be collected in this dedicated list and then
    -- merged back into the main deferred list once the parallel systems are joined.
    parDeferred :: IORef [System ()]
  }

-- | A variant of 'System' that contains a 'ParWorld' instead of 'World'.
--
-- @Parallel systems@ will only be able to run systems that are either specifically intended for them or
-- are made to work with any @'MonadSystem'@ (such as queries).
--
-- To run a normal @System ()@, you need to 'Mischief.ECS.World.Defer.defer'!
newtype ParSystem a = ParSystem (ReaderT ParWorld IO a)
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ParWorld, MonadFail, PrimMonad, MonadThrow)

class GetWorld a where
  getWorld :: a -> Hidden World

instance (GetWorld (Hidden World)) where
  getWorld = id

instance (GetWorld ParWorld) where
  getWorld !x = x.world

class SystemAny m where
  systemAny :: System a -> ParSystem a -> m a

instance SystemAny ParSystem where
  systemAny _ a = a

instance SystemAny System where
  systemAny a _ = a

-- | Typeclass that can be used to generalize systems to both @'System'@ and @'ParSystem'@.
--
-- Used mainly by queries and other operations which don't mutate the World.
class (GetWorld w, MonadReader w a, Applicative a, MonadFail a, Functor a, Monad a, MonadIO a, PrimMonad a, PrimState a ~ RealWorld, MonadThrow a, SystemAny a) => MonadSystem w a

instance MonadSystem (Hidden World) System

instance MonadSystem ParWorld ParSystem

-- Grab the World. DO NOT USE THIS.
unsafeGetWorld :: (MonadSystem w m) => m World
unsafeGetWorld = do
  asks (unhide . getWorld)

instance EraseIntoStorage (System ()) [System ()] where
  erase :: System () -> [System ()]
  erase !x = [x]

data SystemTools = SystemTools
  { get :: forall c m w. (MonadSystem w m, Component c) => Proxy c -> Entity -> m (Maybe c),
    getRAny :: forall c m w. (Component c, MonadSystem w m, IsExclusiveRel c ~ False) => Proxy c -> Entity -> m (Maybe [Rel c]),
    set :: forall c. (Bundle c) => c -> Entity -> System (),
    spawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()
  }

worldGet :: forall c m w. (MonadSystem w m, Component c) => Proxy c -> Entity -> m (Maybe c)
worldGet !p !e = do
  World {tools = SystemTools {get = !get}} <- unsafeGetWorld
  get p e

worldSet :: forall c. (Bundle c) => c -> Entity -> System ()
worldSet !c !e = do
  World {tools = SystemTools {set = !set}} <- unsafeGetWorld
  set c e

worldGetRAny :: forall c m w. (Component c, MonadSystem w m, IsExclusiveRel c ~ False) => Proxy c -> Entity -> m (Maybe [Rel c])
worldGetRAny !p !e = do
  World {tools = SystemTools {getRAny = !getRAny}} <- unsafeGetWorld
  getRAny p e

worldSpawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()
worldSpawnByInsert !e !b = do
  World {tools = SystemTools {spawnByInsert = !spawnByInsert}} <- unsafeGetWorld
  spawnByInsert e b

sysUnliftIO :: System (System a -> IO a)
sysUnliftIO = do
  !world <- hide <$> unsafeGetWorld
  pure $ \(System !a) -> runReaderT a world

-- | Primitive that allows you to set a system to run at every sync point until it returns a @Just a@, at which point
-- it will run the second system with the obtained @a@ and stop running.
--
-- It will run once on the spot, meaning it has no overhead if the first system immediately succeed.
--
-- You should only use this in one-time logic, such as Events or the Startup schedule. You should not use it
-- in logic that runs continuously, such as in Update, as it will keep queueing up a new system to check without removing the old one.
runWhen :: (Typeable a) => System (Maybe a) -> (a -> System b) -> System ()
runWhen !s1 !s2 = do
  b <- s1
  case b of
    Just a -> void $ s2 a
    Nothing -> do
      World {trySystems = !trySystems} <- unsafeGetWorld
      liftIO $ modifyIORef' trySystems (++ [(fmap eraseValue <$> s1, void . s2 . unsafeUneraseValue)])

-- | Lift a ParSystem into a System. Doesn't flush the deferred queue!
parLift :: ParSystem a -> System a
parLift (ParSystem !p) = do
  world <- unsafeGetWorld
  systems <- liftIO $ newIORef []
  a <- liftIO $ runReaderT p ParWorld {world = Hidden world, parDeferred = systems}
  systems <- liftIO $ readIORef systems
  liftIO $ modifyIORef' world.deferred (++ systems)
  pure a