{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.ECS.App where

-- import Data.Map
-- import Data.Map qualified as Map

import Control.Monad (filterM, forever, unless, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader (MonadReader (..))
import Data.Data
import Data.Default
import Data.Foldable
import Data.IORef
import Mischief.ECS.App.Plugins
import Mischief.ECS.App.Schedules
import Mischief.ECS.App.SystemDef
import Mischief.ECS.App.Systems (ScheduledIn, SystemFunction, Systems)
import Mischief.ECS.App.Systems qualified as Systems
import Mischief.ECS.Components
import Mischief.ECS.Components.Bundle
import Mischief.ECS.Components.Spawn (getOrAddComponentId)
import Mischief.ECS.Entities
import Mischief.ECS.Hidden
import Mischief.ECS.Log
import Mischief.ECS.Relationships.Order
import Mischief.ECS.Resources
import Mischief.ECS.World
import Mischief.ECS.World.Defer
import Mischief.ECS.World.Insert
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.Markers
import Mischief.ECS.World.Query.QueryFilter
import Mischief.ECS.World.Spawn

-- | The App is a wrapper around the World through which plugins can be added.
data App = App
  { App -> World
world :: World,
    App -> Systems
systems :: Systems
  }

-- | Create a new App.
newApp :: IO App
newApp :: IO App
newApp = do
  !world <- SystemTools -> IO World
newWorld SystemTools
getTools
  runSystem (spawnEntity (Entity (# 0##, 0## #)) ()) world

  !systems <- Systems.newSystems

  let !app = App {World
world :: World
world :: World
world, Systems
systems :: Systems
systems :: Systems
systems}

  runSystem appInit app.world
  pure app

-- | Add a plugin to the App.
addPlugin :: forall p. (Plugin p) => App -> IO ()
addPlugin :: forall p. Plugin p => App -> IO ()
addPlugin !App
app = System () -> World -> IO ()
forall a. System a -> World -> IO a
runSystem (forall p. Plugin p => System ()
addPluginRec @p) App
app.world

-- | Run the App.
runApp :: App -> IO ()
runApp :: App -> IO ()
runApp !App
app = (System () -> World -> IO ()) -> World -> System () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip System () -> World -> IO ()
forall a. System a -> World -> IO a
runSystem App
app.world (System () -> IO ()) -> System () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  !x <- forall sch. Schedule sch => System Entity
forall {k} (sch :: k). Schedule sch => System Entity
scheduleEntity @Init
  liftIO $ runSchedules [x]

  !startups <- orderEntities =<< query (mkQuery' E (With (C @StartupSchedule)))
  !updates <- orderEntities =<< query (mkQuery' E (With (C @UpdateSchedule)))

  liftIO $ runSchedules startups
  liftIO $ runSchedulesLoop updates
  where
    runSchedulesLoop :: [Entity] -> IO ()
runSchedulesLoop ![Entity]
schedules = do
      IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [Entity] -> IO ()
runSchedules [Entity]
schedules
        IORef Frame -> (Frame -> Frame) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' App
app.world.frame (\(Frame Int
x) -> Int -> Frame
Frame (Int -> Frame) -> Int -> Frame
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

    runSchedules :: [Entity] -> IO ()
runSchedules ![Entity]
schedules =
      [Entity] -> (Entity -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Entity]
schedules ((Entity -> IO ()) -> IO ()) -> (Entity -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(!Entity
schedule) -> do
        System () -> World -> IO ()
forall a. System a -> World -> IO a
runSystem (Entity -> System ()
runSchedule' Entity
schedule) App
app.world

-- | Run all systems of a Schedule.
runSchedule :: forall sch. (Schedule sch) => System ()
runSchedule :: forall {k} (sch :: k). Schedule sch => System ()
runSchedule = forall (sch :: k). Schedule sch => System Entity
forall {k} (sch :: k). Schedule sch => System Entity
scheduleEntity @sch System Entity -> (Entity -> System ()) -> System ()
forall a b. System a -> (a -> System b) -> System b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entity -> System ()
runSchedule'

runSchedule' :: Entity -> System ()
runSchedule' :: Entity -> System ()
runSchedule' Entity
schedule = do
  !world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  !systems <- orderEntities =<< query (mkQuery' E (With (R @ScheduledIn schedule)))

  for_ systems $ \(!Entity
systemId) -> do
    Just (!systemFunction, !lastSystemTick) <- Query System (SystemFunction, SystemTick)
-> System (Maybe (SystemFunction, SystemTick))
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single (Query System (SystemFunction, SystemTick)
 -> System (Maybe (SystemFunction, SystemTick)))
-> Query System (SystemFunction, SystemTick)
-> System (Maybe (SystemFunction, SystemTick))
forall a b. (a -> b) -> a -> b
$ Entity
-> (C SystemFunction, C SystemTick)
-> Query System (SystemFunction, SystemTick)
forall qd out (m :: * -> *).
Queryable qd out =>
Entity -> qd -> Query m out
mkGet Entity
systemId (forall a. C a
forall {k} (a :: k). C a
C @SystemFunction, forall a. C a
forall {k} (a :: k). C a
C @SystemTick)
    !currentSystemTick <- liftIO $ readIORef world.tick

    insert (SystemTick currentSystemTick) systemId
    insert (LastSystemTick lastSystemTick.inner) systemId

    Control.Monad.Reader.local (hide . setSystemId (SystemId systemId) . unhide) $ do
      systemFunction.inner
      flush
      flushAsync
      tryRun
      tick

  when (null systems) $ do
    flush
    flushAsync
    tryRun
    tick

simulateSystem :: System () -> System ()
simulateSystem :: System () -> System ()
simulateSystem System ()
s = do
  e <- (SystemTick, LastSystemTick) -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn (Tick -> SystemTick
SystemTick (Word64 -> Tick
Tick Word64
0), Tick -> LastSystemTick
LastSystemTick (Word64 -> Tick
Tick Word64
0))
  Control.Monad.Reader.local (hide . setSystemId (SystemId e) . unhide) s

setSystemTicks :: Tick -> Tick -> System ()
setSystemTicks :: Tick -> Tick -> System ()
setSystemTicks Tick
a Tick
b = do
  world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  let SystemId id = world.systemId
  insert (LastSystemTick a, SystemTick b) id

tryRun :: System ()
tryRun :: System ()
tryRun = do
  World {trySystems = !trySystems} <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  newSystems <- liftIO $ newIORef []
  !trySystems' <- liftIO $ readIORef trySystems
  liftIO $ writeIORef trySystems []

  !trySystems'' <-
    filterM
      ( \(!System (Maybe ErasedValue)
s1, !ErasedValue -> System ()
s2) -> do
          !b <- System (Maybe ErasedValue)
s1
          case b of
            Maybe ErasedValue
Nothing -> Bool -> System Bool
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            Just ErasedValue
x -> do
              ErasedValue -> System ()
s2 ErasedValue
x

              World {trySystems = !trySystemsNew} <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
              t <- liftIO $ readIORef trySystemsNew
              liftIO $ modifyIORef' newSystems (++ t)

              pure False
      )
      trySystems'
  t <- liftIO $ readIORef newSystems
  liftIO $ writeIORef trySystems (t ++ trySystems'')
  unless (null t) tryRun

appInit :: System ()
appInit :: System ()
appInit = do
  Schedules -> System ()
forall r. (Component r, Bundle r) => r -> System ()
insertRes (Schedules -> System ()) -> Schedules -> System ()
forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def @Schedules

  !systems <- IO Systems -> System Systems
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Systems
Systems.newSystems
  insertRes systems

  !pre <- scheduleEntity @PreStartup
  !startup <- scheduleEntity @Startup
  !post <- scheduleEntity @PostStartup

  for_ [pre, startup, post] $ insert StartupSchedule

  insert (Rel Before startup) pre
  insert (Rel Before post) startup

  !first <- scheduleEntity @First
  !pre <- scheduleEntity @PreUpdate
  !update <- scheduleEntity @Update
  !post <- scheduleEntity @PostUpdate
  !last <- scheduleEntity @Last

  for_ [first, pre, update, post, last] $ insert UpdateSchedule

  insert (Rel Before pre) first
  insert (Rel Before update) pre
  insert (Rel Before post) update
  insert (Rel Before last) post

-- | Register a Component. This is done automatically when inserting it for the first time.
register :: forall c. (Component c) => System ()
register :: forall c. Component c => System ()
register = Proxy c -> System ()
forall c. Component c => Proxy c -> System ()
registerComponent (Proxy c -> System ()) -> Proxy c -> System ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c

registerComponent :: forall c. (Component c) => Proxy c -> System ()
registerComponent :: forall c. Component c => Proxy c -> System ()
registerComponent !Proxy c
c = do
  _ <- ComponentType -> System ComponentId
getOrAddComponentId (Proxy c -> ComponentType
forall c. Component c => Proxy c -> ComponentType
ComponentType Proxy c
c)
  pure ()

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

toolsGet :: forall c m w. (MonadSystem w m, Component c) => Proxy c -> Entity -> m (Maybe c)
toolsGet :: forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
Proxy c -> Entity -> m (Maybe c)
toolsGet Proxy c
_ !Entity
e = Query m c -> m (Maybe c)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single (Query m c -> m (Maybe c)) -> Query m c -> m (Maybe c)
forall a b. (a -> b) -> a -> b
$ Entity -> C c -> Query m c
forall qd out (m :: * -> *).
Queryable qd out =>
Entity -> qd -> Query m out
mkGet Entity
e (forall a. C a
forall {k} (a :: k). C a
C @c)

toolsSet :: forall c. (Bundle c) => c -> Entity -> System ()
toolsSet :: forall b. Bundle b => b -> Entity -> System ()
toolsSet = c -> Entity -> System ()
forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
forall b. Bundle b => b -> Entity -> System ()
insert

toolsGetRAny :: forall c m w. (Component c, MonadSystem w m, IsExclusiveRel c ~ False) => Proxy c -> Entity -> m (Maybe [Rel c])
toolsGetRAny :: forall c (m :: * -> *) w.
(Component c, MonadSystem w m, IsExclusiveRel c ~ 'False) =>
Proxy c -> Entity -> m (Maybe [Rel c])
toolsGetRAny Proxy c
_ !Entity
e = Query m [Rel c] -> m (Maybe [Rel c])
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single (Query m [Rel c] -> m (Maybe [Rel c]))
-> Query m [Rel c] -> m (Maybe [Rel c])
forall a b. (a -> b) -> a -> b
$ Entity -> R c Any -> Query m [Rel c]
forall qd out (m :: * -> *).
Queryable qd out =>
Entity -> qd -> Query m out
mkGet Entity
e (forall {k} (a :: k) b. b -> R a b
forall a b. b -> R a b
R @c Any
Any)

toolsSpawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()
toolsSpawnByInsert :: forall b. Bundle b => Entity -> b -> System ()
toolsSpawnByInsert = Entity -> b -> System ()
forall b. Bundle b => Entity -> b -> System ()
spawnEntityByInsert

incTick :: Tick -> Maybe Tick
incTick :: Tick -> Maybe Tick
incTick (Tick !Word64
a) | Word64
a Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
forall a. Bounded a => a
maxBound = Maybe Tick
forall a. Maybe a
Nothing
incTick (Tick !Word64
a) = Tick -> Maybe Tick
forall a. a -> Maybe a
Just (Tick -> Maybe Tick) -> Tick -> Maybe Tick
forall a b. (a -> b) -> a -> b
$ Word64 -> Tick
Tick (Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)

-- | Increment the World's Tick.
tick :: System ()
tick :: System ()
tick = do
  !world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  !tick <- liftIO $ incTick <$> readIORef world.tick
  case tick of
    Maybe Tick
Nothing -> do
      Text -> System ()
forall w (m :: * -> *).
(HasCallStack, MonadSystem w m) =>
Text -> m ()
warn Text
"Reached maximum Tick. Resetting count. Previous changed will not be detected."
      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 Tick -> Tick -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef World
world.tick (Tick -> IO ()) -> Tick -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Tick
Tick Word64
0
    Just !Tick
t -> 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 Tick -> Tick -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef World
world.tick Tick
t

getTick :: (MonadSystem w m) => m Tick
getTick :: forall w (m :: * -> *). MonadSystem w m => m Tick
getTick = do
  world <- m World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  liftIO $ readIORef world.tick

setTick :: Tick -> System ()
setTick :: Tick -> System ()
setTick Tick
tick = do
  world <- System World
forall w (m :: * -> *). MonadSystem w m => m World
unsafeGetWorld
  liftIO $ writeIORef world.tick tick