{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Rollback and replay based game networking
module Alpaca.NetCode.Internal.ClockSync where

import Alpaca.NetCode.Internal.Common
import Control.Concurrent.STM
import Data.Maybe (fromMaybe)

import Data.Int (Int64)

-- TODO make all these constants part of ClientConfig

-- Min/Max Time dilation. This is the maximum speedup of our own clock that
-- we'll allow to catch up to the estimated server clock. Note that the min is
-- greater than 0 meaning that we never stop or reverse time.

minTimeDilation :: Float
minTimeDilation :: Float
minTimeDilation = Float
0.9

maxTimeDilation :: Float
maxTimeDilation :: Float
maxTimeDilation = Float
1.1

-- Number of ping samples to maintain
pingSamples :: Int
pingSamples :: Int
pingSamples = Int
8

-- Number of timing samples to maintain
timingSamples :: Int
timingSamples :: Int
timingSamples = Int
40

-- Some state for managing clock synchronization
data ClockSync = ClockSync
  -- On the last server time estimate: (client's local time, estimated server's local time)
  { ClockSync -> Maybe (Float, Float)
csLastSample :: Maybe (Time, Time),
    -- Last few samples of point times
    ClockSync -> [Float]
csPingSamples :: [Duration],
    -- Last few samples of: (server time, estimated corresponding client time)
    -- relative to base.
    ClockSync -> [(Float, Float)]
csTimingSamples :: [(Time, Time)]
  }

csEstPing :: ClockSync -> Duration
csEstPing :: ClockSync -> Float
csEstPing (ClockSync {csPingSamples :: ClockSync -> [Float]
csPingSamples = [Float]
xs}) = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Float]
xs Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Int -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ [Float] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
xs)

-- | returns (off, drift) sutch that serverTime = (drift * clientTime) + offset
csEstOffsetAndDrift :: ClockSync -> Maybe (Time, Time)
csEstOffsetAndDrift :: ClockSync -> Maybe (Float, Float)
csEstOffsetAndDrift (ClockSync {csTimingSamples :: ClockSync -> [(Float, Float)]
csTimingSamples = [(Float, Float)]
xs})
  | Int
nInt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
pingSamples Bool -> Bool -> Bool
|| Float
slopDenom Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 = Maybe (Float, Float)
forall a. Maybe a
Nothing
  -- TODO perhaps it's more efficient to just use https://en.wikipedia.org/wiki/Simple_linear_regression#Fitting_the_regression_line

  | Bool
otherwise = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float
offset, Float
slope)
  where
    nInt :: Int
nInt = [(Float, Float)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Float, Float)]
xs
    n :: Float
n = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nInt
    avg :: [Float] -> Float
avg [Float]
xs' = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Float]
xs' Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
n
    avgServer :: Float
avgServer = [Float] -> Float
avg ((Float, Float) -> Float
forall a b. (a, b) -> a
fst ((Float, Float) -> Float) -> [(Float, Float)] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Float, Float)]
xs)
    avgClient :: Float
avgClient = [Float] -> Float
avg ((Float, Float) -> Float
forall a b. (a, b) -> b
snd ((Float, Float) -> Float) -> [(Float, Float)] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Float, Float)]
xs)
    slopNumer :: Float
slopNumer = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
avgServer) Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
avgClient) | (Float
s, Float
c) <- [(Float, Float)]
xs]
    slopDenom :: Float
slopDenom = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
avgClient) Float -> Int64 -> Float
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int64
2 :: Int64) | (Float
_, Float
c) <- [(Float, Float)]
xs]
    slope :: Float
slope = Float
slopNumer Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
slopDenom
    offset :: Float
offset = Float
avgServer Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
slope Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
avgClient)

-- | Initialize clock synchronization.
initializeClockSync ::
  -- | Tick time (time per tick in seconds)
  Float ->
  -- | Get the current time from the system in seconds.
  IO Float ->
  -- | Returns:
  --
  -- *  Given some @extraTime@, Estimate the tick on the server when a message
  --    sent at @now + extraTime@ is received by the server plus some extraTime
  --    time.
  --
  -- * Record a clock sync event. Given a heartbeat meassge, this is: client
  --   send time, server receive time, client receive (of the heart beat
  --   response) time)
  --
  -- * analytics returns:
  --
  --   * Ping
  --
  --   * Estimated error from the server clock. This error occurs when we've
  --     committed to some time samples then realize that our measurements are
  --     off. Instead of immediately correcting, we simply dilate time (speeding
  --     up a bit or slowing down a bit) until the "effective" clock is
  --     corrected (see min/maxTimeDilation). On till corrected, our time
  --     estimates differ from what we really think the time is on the server,
  --     and that difference is the "estimated error". Specifically `error =
  --     servertime - effective time`
  IO (Float -> IO Tick, Float -> Float -> Float -> IO (), IO (Maybe (Float, Float)))
initializeClockSync :: Float
-> IO Float
-> IO
     (Float -> IO Tick, Float -> Float -> Float -> IO (),
      IO (Maybe (Float, Float)))
initializeClockSync Float
tickTime IO Float
getTime = do
  TVar ClockSync
clockSyncTVar :: TVar ClockSync <- ClockSync -> IO (TVar ClockSync)
forall a. a -> IO (TVar a)
newTVarIO (Maybe (Float, Float) -> [Float] -> [(Float, Float)] -> ClockSync
ClockSync Maybe (Float, Float)
forall a. Maybe a
Nothing [] [])
  let -- Estimate the tick on the server when a message sent at `now + extraTime` is
      -- received by the server plus some extraTime time.
      estimateServerTickPlusLatencyPlusBufferPlus :: Float -> IO Tick
      estimateServerTickPlusLatencyPlusBufferPlus :: Float -> IO Tick
estimateServerTickPlusLatencyPlusBufferPlus Float
extraTime = do
        Float
clientTime <- IO Float
getTime
        STM Tick -> IO Tick
forall a. STM a -> IO a
atomically (STM Tick -> IO Tick) -> STM Tick -> IO Tick
forall a b. (a -> b) -> a -> b
$ do
          ClockSync
cs <- TVar ClockSync -> STM ClockSync
forall a. TVar a -> STM a
readTVar TVar ClockSync
clockSyncTVar
          Maybe (Float, Float, Float, ClockSync)
anaMay <- ClockSync
-> Float -> Float -> STM (Maybe (Float, Float, Float, ClockSync))
analytics' ClockSync
cs Float
clientTime Float
extraTime
          case Maybe (Float, Float, Float, ClockSync)
anaMay of
            Maybe (Float, Float, Float, ClockSync)
Nothing -> STM Tick
forall a. STM a
retry
            Just (Float
_estServerTime, Float
dilatedEstServerTime, Float
_ping, ClockSync
newCS) -> do
              TVar ClockSync -> ClockSync -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ClockSync
clockSyncTVar ClockSync
newCS
              Tick -> STM Tick
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Tick
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float
dilatedEstServerTime Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
tickTime))

      analytics :: IO (Maybe (Float, Float))
      analytics :: IO (Maybe (Float, Float))
analytics = do
        Float
clientTime <- IO Float
getTime
        STM (Maybe (Float, Float)) -> IO (Maybe (Float, Float))
forall a. STM a -> IO a
atomically (STM (Maybe (Float, Float)) -> IO (Maybe (Float, Float)))
-> STM (Maybe (Float, Float)) -> IO (Maybe (Float, Float))
forall a b. (a -> b) -> a -> b
$ do
          ClockSync
cs <- TVar ClockSync -> STM ClockSync
forall a. TVar a -> STM a
readTVar TVar ClockSync
clockSyncTVar
          Maybe (Float, Float, Float, ClockSync)
anaMay <- ClockSync
-> Float -> Float -> STM (Maybe (Float, Float, Float, ClockSync))
analytics' ClockSync
cs Float
clientTime Float
0
          case Maybe (Float, Float, Float, ClockSync)
anaMay of
            Maybe (Float, Float, Float, ClockSync)
Nothing -> Maybe (Float, Float) -> STM (Maybe (Float, Float))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Float, Float)
forall a. Maybe a
Nothing
            Just (Float
estServerTime, Float
dilatedEstServerTime, Float
ping, ClockSync
_newCS) -> do
              Maybe (Float, Float) -> STM (Maybe (Float, Float))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Float, Float) -> STM (Maybe (Float, Float)))
-> Maybe (Float, Float) -> STM (Maybe (Float, Float))
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float
ping, Float
estServerTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dilatedEstServerTime)

      -- (estimated server time, estimated server time clamping time dilation, ping, ClockSync with the new sample point)
      analytics' :: ClockSync -> Time -> Float -> STM (Maybe (Float, Float, Float, ClockSync))
      analytics' :: ClockSync
-> Float -> Float -> STM (Maybe (Float, Float, Float, ClockSync))
analytics' ClockSync
cs Float
clientTime Float
extraTime = do
        let offDriftMay :: Maybe (Float, Float)
offDriftMay = ClockSync -> Maybe (Float, Float)
csEstOffsetAndDrift ClockSync
cs
        case Maybe (Float, Float)
offDriftMay of
          Maybe (Float, Float)
Nothing -> Maybe (Float, Float, Float, ClockSync)
-> STM (Maybe (Float, Float, Float, ClockSync))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Float, Float, Float, ClockSync)
forall a. Maybe a
Nothing
          Just (Float
offset, Float
drift) -> do
            let estServerTime :: Float
estServerTime = (Float
drift Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
clientTime) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
                clampedEstServerTime :: Float
clampedEstServerTime = Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
estServerTime (Maybe Float -> Float) -> Maybe Float -> Float
forall a b. (a -> b) -> a -> b
$
                  do
                    (Float
lastClientTime, Float
lastEstServerTime) <- ClockSync -> Maybe (Float, Float)
csLastSample ClockSync
cs
                    let targetTimeDilation :: Float
targetTimeDilation =
                          (Float
estServerTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
lastEstServerTime)
                            Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
clientTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
lastClientTime)
                        clampedTimeDilation :: Float
clampedTimeDilation =
                          Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
maxTimeDilation) (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$
                            Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
minTimeDilation) (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$
                              Float
targetTimeDilation
                    Float -> Maybe Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Maybe Float) -> Float -> Maybe Float
forall a b. (a -> b) -> a -> b
$ Float
lastEstServerTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
clampedTimeDilation Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
clientTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
lastClientTime))

            -- For now we're just on local host, so just add a small delay
            -- to the current time to estimate the server time.
            let elapsedTime :: Float
elapsedTime = Float
clampedEstServerTime
                latency :: Float
latency = ClockSync -> Float
csEstPing ClockSync
newCS Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 -- TODO I think adding latency is probably causing some annoying preceived input latency variablility. Rethink this!
                dilatedEstServerTime :: Float
dilatedEstServerTime = (Float
elapsedTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
latency Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bufferTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
extraTime)
                newCS :: ClockSync
newCS = ClockSync
cs {csLastSample :: Maybe (Float, Float)
csLastSample = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float
clientTime, Float
clampedEstServerTime)}
                ping :: Float
ping = ClockSync -> Float
csEstPing ClockSync
newCS
            Maybe (Float, Float, Float, ClockSync)
-> STM (Maybe (Float, Float, Float, ClockSync))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Float, Float, Float, ClockSync)
 -> STM (Maybe (Float, Float, Float, ClockSync)))
-> Maybe (Float, Float, Float, ClockSync)
-> STM (Maybe (Float, Float, Float, ClockSync))
forall a b. (a -> b) -> a -> b
$ (Float, Float, Float, ClockSync)
-> Maybe (Float, Float, Float, ClockSync)
forall a. a -> Maybe a
Just (Float
estServerTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
latency Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bufferTime, Float
dilatedEstServerTime, Float
ping, ClockSync
newCS)

      recordClockSyncSample :: Float -> Float -> Float -> IO ()
      recordClockSyncSample :: Float -> Float -> Float -> IO ()
recordClockSyncSample Float
clientSendTime Float
serverTime Float
clientReceiveTime = do
        let pingSample :: Float
pingSample = Float
clientReceiveTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
clientSendTime
            latency :: Float
latency = Float
pingSample Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            timingSample :: (Float, Float)
timingSample =
              ( Float
serverTime,
                Float
latency Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
clientSendTime
              )

        ClockSync
_cs' <- STM ClockSync -> IO ClockSync
forall a. STM a -> IO a
atomically (STM ClockSync -> IO ClockSync) -> STM ClockSync -> IO ClockSync
forall a b. (a -> b) -> a -> b
$ do
          ClockSync
cs <- TVar ClockSync -> STM ClockSync
forall a. TVar a -> STM a
readTVar TVar ClockSync
clockSyncTVar
          let cs' :: ClockSync
cs' =
                ClockSync :: Maybe (Float, Float) -> [Float] -> [(Float, Float)] -> ClockSync
ClockSync
                  { csLastSample :: Maybe (Float, Float)
csLastSample = ClockSync -> Maybe (Float, Float)
csLastSample ClockSync
cs,
                    csPingSamples :: [Float]
csPingSamples = Int -> [Float] -> [Float]
forall a. Int -> [a] -> [a]
take Int
pingSamples (Float
pingSample Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: ClockSync -> [Float]
csPingSamples ClockSync
cs),
                    csTimingSamples :: [(Float, Float)]
csTimingSamples = Int -> [(Float, Float)] -> [(Float, Float)]
forall a. Int -> [a] -> [a]
take Int
timingSamples ((Float, Float)
timingSample (Float, Float) -> [(Float, Float)] -> [(Float, Float)]
forall a. a -> [a] -> [a]
: ClockSync -> [(Float, Float)]
csTimingSamples ClockSync
cs)
                  }
          TVar ClockSync -> ClockSync -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ClockSync
clockSyncTVar ClockSync
cs'
          ClockSync -> STM ClockSync
forall (m :: * -> *) a. Monad m => a -> m a
return ClockSync
cs'

        -- putStrLn $ "Ping: " ++ show (csEstPing cs')
        -- forM_ (csEstOffsetAndDrift cs') $ \(off, drift) -> do
        --   putStrLn $ "Offset: " ++ show off
        --   putStrLn $ "Drift: " ++ show drift
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  (Float -> IO Tick, Float -> Float -> Float -> IO (),
 IO (Maybe (Float, Float)))
-> IO
     (Float -> IO Tick, Float -> Float -> Float -> IO (),
      IO (Maybe (Float, Float)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> IO Tick
estimateServerTickPlusLatencyPlusBufferPlus, Float -> Float -> Float -> IO ()
recordClockSyncSample, IO (Maybe (Float, Float))
analytics)