quyse/flaw

{-|
Module: Flaw.Game.Lockstep
Description: Deterministic synchronization using lockstep method.
License: MIT
-}

{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeFamilies, ViewPatterns #-}

module Flaw.Game.Lockstep
  ( Lockstep(..)
  , LockstepTick
  , LockstepTicked(..)
  , LockstepClient(..)
  , newLockstepClient
  , lockstepClientReceiveTick
  , lockstepClientRender
  ) where

import Control.Concurrent.STM
import Data.Word

-- | Lockstep synchronization.
-- Allows to support rich state between server and client,
-- using small amount of data sent over network
-- thanks to deterministic step function.
class Lockstep a where
  -- | Global immutable configuration for synchronization.
  data LockstepConfig a :: *
  -- | State of the logic without intents.
  data LockstepState a :: *
  -- | Player's intent.
  -- Piece of data client is sending to server.
  data LockstepIntent a :: *
  -- | State seed generated by server from previous state and intents.
  data LockstepSeed a :: *
  -- | Merge intents.
  lockstepMergeIntents :: LockstepConfig a -> LockstepIntent a -> LockstepIntent a -> LockstepIntent a
  default lockstepMergeIntents :: Monoid (LockstepIntent a) => LockstepConfig a -> LockstepIntent a -> LockstepIntent a -> LockstepIntent a
  lockstepMergeIntents _ = (<>)
  -- | Rebase intent onto other state.
  lockstepRebaseIntent :: LockstepConfig a -> LockstepState a -> LockstepState a -> LockstepIntent a -> LockstepIntent a
  -- | Deterministic simulation step.
  lockstepTick :: LockstepConfig a -> LockstepSeed a -> LockstepState a -> LockstepState a

type LockstepTick = Word64

data LockstepTicked a = LockstepTicked {-# UNPACK #-} !LockstepTick !a

data LockstepClient a = LockstepClient
  {
    lockstepClientConfig :: !(LockstepConfig a)
  -- | Null intent.
  , lockstepClientNullIntent :: !(LockstepIntent a)
  -- | Render delay, in ticks.
  , lockstepClientRenderDelay :: {-# UNPACK #-} !Float
  -- | Mininum render delay, in ticks.
  , lockstepClientMinRenderDelay :: {-# UNPACK #-} !Float
  -- | Maximum render delay, in ticks.
  , lockstepClientMaxRenderDelay :: {-# UNPACK #-} !Float
  -- | Time passed since start of the simulation, in ticks.
  , lockstepClientTimeVar :: {-# UNPACK #-} !(TVar Double)
  -- | Last actual state.
  , lockstepClientStateVar :: {-# UNPACK #-} !(TVar (LockstepTicked (LockstepState a)))
  -- | Predicted state queue.
  , lockstepClientStateQueueVar :: {-# UNPACK #-} !(TVar [LockstepTicked (LockstepState a)])
  -- | Intent queue.
  , lockstepClientIntentQueueVar :: {-# UNPACK #-} !(TVar [LockstepTicked (LockstepIntent a)])
  -- | Current intent.
  , lockstepClientIntentVar :: {-# UNPACK #-} !(TVar (LockstepIntent a))
  }

-- | Create lockstep client.
newLockstepClient :: LockstepConfig a -> LockstepState a -> LockstepIntent a -> Float -> Float -> Float -> STM (LockstepClient a)
newLockstepClient config initialState nullIntent renderDelay minRenderDelay maxRenderDelay = LockstepClient config nullIntent renderDelay minRenderDelay maxRenderDelay
  <$> newTVar 0
  <*> newTVar (LockstepTicked 0 initialState)
  <*> newTVar [LockstepTicked 0 initialState]
  <*> newTVar []
  <*> newTVar nullIntent

-- | Receive seed from server, advance client to next tick.
lockstepClientReceiveTick :: Lockstep a => LockstepClient a -> LockstepTick -> LockstepSeed a -> (LockstepIntent a -> LockstepSeed a) -> STM (LockstepTicked (LockstepIntent a))
lockstepClientReceiveTick LockstepClient
  { lockstepClientConfig = config
  , lockstepClientNullIntent = nullIntent
  , lockstepClientStateVar = stateVar
  , lockstepClientStateQueueVar = stateQueueVar
  , lockstepClientIntentQueueVar = intentQueueVar
  , lockstepClientIntentVar = intentVar
  } maxAppliedTick seed predictSeed = do
  -- get current tick and state
  LockstepTicked tick state <- readTVar stateVar
  -- get current intent (and clear the var)
  intent <- readTVar intentVar
  writeTVar intentVar nullIntent
  -- remove applied intents, and add new intent to intent queue
  newIntentQueue <- do
    let
      reduce intents = case intents of
        LockstepTicked baseTick _ : restIntents -> if baseTick <= maxAppliedTick then reduce restIntents else intents
        [] -> []
    intentQueue <- readTVar intentQueueVar
    let
      newIntentQueue = reduce intentQueue ++ [LockstepTicked tick intent]
    writeTVar intentQueueVar newIntentQueue
    return newIntentQueue
  -- calculate new predicted state for existing states (except the first two, as they are used for interpolation at the moment)
  do
    stateQueue <- readTVar stateQueueVar
    case stateQueue of
      s0 : s1 : ss -> writeTVar stateQueueVar $! s0 : s1 : map (\(LockstepTicked t s) -> LockstepTicked t $ lockstepTick config (predictSeed intent) s) ss
      _ -> return ()
  -- calculate next state and add to queue
  let
    nextState = lockstepTick config seed state
  writeTVar stateVar $ LockstepTicked (tick + 1) nextState
  modifyTVar stateQueueVar (++ [LockstepTicked (tick + 1) $ foldl (\s (LockstepTicked _ i) -> lockstepTick config (predictSeed i) s) nextState newIntentQueue])
  -- return current intent
  return $ LockstepTicked tick intent

-- | Perform rendering.
lockstepClientRender :: Lockstep a => LockstepClient a
  -> LockstepIntent a -- ^ Intent to append.
  -> Float -- ^ Time to advance in ticks.
  -> STM (LockstepTicked (LockstepState a), LockstepTicked (LockstepState a), Float)
lockstepClientRender LockstepClient
  { lockstepClientConfig = config
  , lockstepClientRenderDelay = realToFrac -> renderDelay
  , lockstepClientMinRenderDelay = realToFrac -> minRenderDelay
  , lockstepClientMaxRenderDelay = realToFrac -> maxRenderDelay
  , lockstepClientTimeVar = timeVar
  , lockstepClientStateVar = stateVar
  , lockstepClientStateQueueVar = stateQueueVar
  , lockstepClientIntentVar = intentVar
  } intent advanceTime = do
  -- append intent
  modifyTVar' intentVar $ \i -> lockstepMergeIntents config i intent

  time <- readTVar timeVar
  LockstepTicked tick _ <- readTVar stateVar
  let
    -- calculate actual render delay
    tickTime = fromIntegral tick
    actualRenderDelay = tickTime - time
    -- calculate new time
    newTime =
      -- if it's less than minimum render delay, don't change relative time (pause rendering)
      if actualRenderDelay < minRenderDelay then time
      -- if it's more than maximum render delay, force re-sync
      else if actualRenderDelay > maxRenderDelay then tickTime - renderDelay
      -- else everything is normal, simply advance time
      else time + realToFrac advanceTime
    -- calculate new time
    (renderTick, renderSubTick) = properFraction newTime

  -- remove old states (but don't remove last state)
  stateQueue <- readTVar stateQueueVar
  let
    reduceStateQueue states = case states of
      (LockstepTicked stateTick _) : restStates@(_ : _) -> if stateTick < renderTick then reduceStateQueue restStates else states
      _ -> states
    newStates = reduceStateQueue stateQueue
  writeTVar stateQueueVar newStates
  -- correct time if there's only one state, get states
  let
    (firstState, secondState, stateCoef, correctedTime) = case newStates of
      state1 : state2 : _ -> (state1, state2, realToFrac renderSubTick, newTime)
      [onlyState] -> (onlyState, onlyState, 0, fromIntegral renderTick)
      [] -> error "no states" -- impossible situation
  -- update time
  writeTVar timeVar correctedTime
  return (firstState, secondState, stateCoef)