module Mischief.ECS.Time where

import Control.Monad.IO.Class
import Data.Data
import Data.Function ((&))
import Data.Vector.Internal.Check (HasCallStack)
import Mischief.ECS.App.Plugins
import Mischief.ECS.App.Schedules
import Mischief.ECS.Components
import Mischief.ECS.Resources
import Mischief.ECS.Systems
import Mischief.ECS.Utils
import Mischief.ECS.World
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.Pipe
import System.Clock

class ToTime t where
  toTime :: t -> Time

data Time = Time
  { Time -> TimeSpec
delta :: TimeSpec,
    Time -> TimeSpec
elapsed :: TimeSpec
  }

data VirtualTime = VirtualTime
  { VirtualTime -> TimeSpec
virtualDelta :: TimeSpec,
    VirtualTime -> TimeSpec
virtualElapsed :: TimeSpec
  }
  deriving (Int -> VirtualTime -> ShowS
[VirtualTime] -> ShowS
VirtualTime -> String
(Int -> VirtualTime -> ShowS)
-> (VirtualTime -> String)
-> ([VirtualTime] -> ShowS)
-> Show VirtualTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VirtualTime -> ShowS
showsPrec :: Int -> VirtualTime -> ShowS
$cshow :: VirtualTime -> String
show :: VirtualTime -> String
$cshowList :: [VirtualTime] -> ShowS
showList :: [VirtualTime] -> ShowS
Show, Typeable VirtualTime
[HookRel VirtualTime]
[Hook VirtualTime]
Set DefaultComponentType
IsExclusive (IsExclusiveRel VirtualTime)
(Typeable VirtualTime, IsExclusive (IsExclusiveRel VirtualTime)) =>
Set DefaultComponentType
-> [Hook VirtualTime]
-> [Hook VirtualTime]
-> [Hook VirtualTime]
-> [HookRel VirtualTime]
-> [HookRel VirtualTime]
-> [HookRel VirtualTime]
-> Component VirtualTime
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 VirtualTime]
onAdd :: [Hook VirtualTime]
$conSet :: [Hook VirtualTime]
onSet :: [Hook VirtualTime]
$conRemove :: [Hook VirtualTime]
onRemove :: [Hook VirtualTime]
$conAddRel :: [HookRel VirtualTime]
onAddRel :: [HookRel VirtualTime]
$conSetRel :: [HookRel VirtualTime]
onSetRel :: [HookRel VirtualTime]
$conRemoveRel :: [HookRel VirtualTime]
onRemoveRel :: [HookRel VirtualTime]
Component)

data TimeTypePref

instance PrefType TimeTypePref TimeTag

instance ToTime VirtualTime where
  toTime :: VirtualTime -> Time
toTime VirtualTime
v = Time {delta :: TimeSpec
delta = VirtualTime
v.virtualDelta, elapsed :: TimeSpec
elapsed = VirtualTime
v.virtualElapsed}

data TimeTag where
  TimeTag :: (Component t, ToTime t) => Proxy t -> TimeTag

time :: (HasCallStack) => (MonadSystem w m) => m Time
time :: forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Time
time = do
  pref <- forall {k} (a :: k) (m :: * -> *) b w.
(PrefType a b, MonadSystem w m) =>
m (Maybe b)
forall a (m :: * -> *) b w.
(PrefType a b, MonadSystem w m) =>
m (Maybe b)
getPref @TimeTypePref
  case pref of
    Maybe TimeTag
Nothing -> VirtualTime -> Time
forall t. ToTime t => t -> Time
toTime (VirtualTime -> Time)
-> (Maybe VirtualTime -> VirtualTime) -> Maybe VirtualTime -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe VirtualTime -> VirtualTime
forall (f :: * -> *) a. (HasCallStack, Unwrappable f) => f a -> a
unwrap (Maybe VirtualTime -> Time) -> m (Maybe VirtualTime) -> m Time
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 @VirtualTime
    Just (TimeTag (Proxy t
_ :: Proxy t)) -> t -> Time
forall t. ToTime t => t -> Time
toTime (t -> Time) -> (Maybe t -> t) -> Maybe t -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe t -> t
forall (f :: * -> *) a. (HasCallStack, Unwrappable f) => f a -> a
unwrap (Maybe t -> Time) -> m (Maybe t) -> m Time
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 @t

timeMaybe :: (MonadSystem w m) => m (Maybe Time)
timeMaybe :: forall w (m :: * -> *). MonadSystem w m => m (Maybe Time)
timeMaybe = do
  pref <- forall {k} (a :: k) (m :: * -> *) b w.
(PrefType a b, MonadSystem w m) =>
m (Maybe b)
forall a (m :: * -> *) b w.
(PrefType a b, MonadSystem w m) =>
m (Maybe b)
getPref @TimeTypePref
  case pref of
    Maybe TimeTag
Nothing -> (VirtualTime -> Time) -> Maybe VirtualTime -> Maybe Time
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VirtualTime -> Time
forall t. ToTime t => t -> Time
toTime (Maybe VirtualTime -> Maybe Time)
-> m (Maybe VirtualTime) -> m (Maybe Time)
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 @VirtualTime
    Just (TimeTag (Proxy t
_ :: Proxy t)) -> (t -> Time) -> Maybe t -> Maybe Time
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> Time
forall t. ToTime t => t -> Time
toTime (Maybe t -> Maybe Time) -> m (Maybe t) -> m (Maybe Time)
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 @t

qtime :: (MonadSystem w m) => Query m Time
qtime :: forall w (m :: * -> *). MonadSystem w m => Query m Time
qtime = () -> Query m ()
forall a. a -> Query m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () Query m () -> (Query m () -> Query m Time) -> Query m Time
forall a b. a -> (a -> b) -> b
& (Entity -> () -> m Time) -> Query m () -> Query m Time
forall a (m :: * -> *) b.
(Entity -> a -> m b) -> Query m a -> Query m b
qtraverse (\Entity
_ ()
_ -> m Time
forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Time
time)

delta :: (HasCallStack) => (MonadSystem w m) => m Float
delta :: forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Float
delta = do
  time <- m Time
forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Time
time
  pure $ specToSecs time.delta

qdelta :: (MonadSystem w m) => Query m Float
qdelta :: forall w (m :: * -> *). MonadSystem w m => Query m Float
qdelta = () -> Query m ()
forall a. a -> Query m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () Query m () -> (Query m () -> Query m Float) -> Query m Float
forall a b. a -> (a -> b) -> b
& (Entity -> () -> m Float) -> Query m () -> Query m Float
forall a (m :: * -> *) b.
(Entity -> a -> m b) -> Query m a -> Query m b
qtraverse (\Entity
_ ()
_ -> m Float
forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Float
delta)

elapsed :: (HasCallStack) => (MonadSystem w m) => m Float
elapsed :: forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Float
elapsed = do
  time <- m Time
forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Time
time
  pure $ specToSecs time.elapsed

qelapsed :: (MonadSystem w m) => Query m Float
qelapsed :: forall w (m :: * -> *). MonadSystem w m => Query m Float
qelapsed = () -> Query m ()
forall a. a -> Query m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () Query m () -> (Query m () -> Query m Float) -> Query m Float
forall a b. a -> (a -> b) -> b
& (Entity -> () -> m Float) -> Query m () -> Query m Float
forall a (m :: * -> *) b.
(Entity -> a -> m b) -> Query m a -> Query m b
qtraverse (\Entity
_ ()
_ -> m Float
forall w (m :: * -> *). (HasCallStack, MonadSystem w m) => m Float
elapsed)

specToSecs :: TimeSpec -> Float
specToSecs :: TimeSpec -> Float
specToSecs TimeSpec
a = Int64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral TimeSpec
a.sec Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral TimeSpec
a.nsec Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
1000000000

secsToSpec :: Float -> TimeSpec
secsToSpec :: Float -> TimeSpec
secsToSpec Float
s =
  let secs :: Int64
secs = Float -> Int64
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
s
   in Int64 -> Int64 -> TimeSpec
TimeSpec Int64
secs (Int64 -> TimeSpec) -> Int64 -> TimeSpec
forall a b. (a -> b) -> a -> b
$ Float -> Int64
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
- Int64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
secs) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
1000000000)

-- | Plugin that keeps track of time. Enables calling 'delta', 'elapsed', and so on.
--
-- Note that these methods are context-dependent. For instance, if used in a Fixed schedule, 'delta' will always return the time as inferred from the fixed frequency.
data TimePlugin

instance Plugin TimePlugin where
  init :: System ()
init = do
    currentTime <- IO TimeSpec -> System TimeSpec
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeSpec -> System TimeSpec) -> IO TimeSpec -> System TimeSpec
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
getTime Clock
Monotonic
    insertRes $ VirtualTime {virtualDelta = TimeSpec {sec = 0, nsec = 0}, virtualElapsed = currentTime}
    schedule @First (systems updateTime)

updateTime :: System ()
updateTime :: System ()
updateTime = do
  Just time <- forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @VirtualTime
  currentTime <- liftIO $ getTime Monotonic
  insertRes VirtualTime {virtualDelta = currentTime - time.virtualElapsed, virtualElapsed = currentTime}