{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.Client (
  runClientWith',
  ClientConfig (..),
  defaultClientConfig,
  Client,
  clientPlayerId,
  clientSample,
  clientSample',
  clientSetInput,
  clientStop,
) where

import Alpaca.NetCode.Internal.ClockSync
import Alpaca.NetCode.Internal.Common
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.STM as STM
import Control.Monad
import Data.Int (Int64)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust)
import qualified Data.Set as S
import Flat


-- | A Client. You'll generally obtain this via 'Alpaca.NetCode.runClient'.
data Client world input = Client
  { -- | The client's @PlayerId@
    Client world input -> PlayerId
clientPlayerId :: PlayerId
  , -- | Sample the world state. First, This will estimate the current tick
    -- based on ping and clock synchronization with the server. Then, the world
    -- state will be rollback and inputs replayed as necessary. This returns:
    --
    -- * New authoritative world states in chronological order since the last
    --   sample time. These world states are the True world states at each tick.
    --   This list will be empty if no new authoritative world states have been
    --   derived since that last call to this sample function. Though it's often
    --   simpler to just use the predicted world state, you can use these
    --   authoritative world states to render output when you're not willing to
    --   miss-predict but are willing to have greater latency. If the client has
    --   been stopped, this will be an empty list.
    --
    -- * The predicted current world state. This extrapolates past the latest
    --   know authoritative world state by assuming no user inputs have changed
    --   (unless otherwise known e.g. our own player's inputs are known). If the
    --   client has been stopped, this will return the last predicted world.
    Client world input -> IO ([world], world)
clientSample' :: IO ([world], world)
  , -- | Set the client's current input.
    Client world input -> input -> IO ()
clientSetInput :: input -> IO ()
  , -- | Stop the client.
    Client world input -> IO ()
clientStop :: IO ()
  }


-- | Sample the current world state.
--
-- . First, This will estimate the current tick based on ping and clock
-- synchronization with the server. Then, this extrapolates past the latest know
-- authoritative world state by assuming no user inputs have changed (unless
-- otherwise known e.g. our own player's inputs are known). If the client has
-- been stopped, this will return the last predicted world.
clientSample :: Client world input -> IO world
clientSample :: Client world input -> IO world
clientSample Client world input
client = ([world], world) -> world
forall a b. (a, b) -> b
snd (([world], world) -> world) -> IO ([world], world) -> IO world
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client world input -> IO ([world], world)
forall world input. Client world input -> IO ([world], world)
clientSample' Client world input
client


-- | Configuration options specific to clients.
data ClientConfig = ClientConfig
  { -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same
    -- across all clients and the server. Packet rate and hence network bandwidth
    -- will scale linearly with this the tick rate.
    ClientConfig -> Int
ccTickRate :: Int
  , -- | Add this constant amount of latency (in seconds) to this client's inputs.
    -- A good value is @0.03@ or something between @0@ and @0.1@. May differ
    -- between clients.
    --
    -- Too high of a value and the player will get annoyed at the extra input
    -- latency. On the other hand, a higher value means less miss-predictions of
    -- other clients. In the extreme case, set to something higher than ping,
    -- there will be no miss predictions: all clients will receive inputs before
    -- rendering the corresponding tick.
    ClientConfig -> Float
ccFixedInputLatency :: Float
  , -- | Maximum number of ticks to predict when sampling. 'defaultClientConfig'
    -- uses @ccTickRate / 2@. If the client is this many ticks behind the current
    -- tick, it will simply stop at an earlier tick. You may want to scale this
    -- value along with the tick rate. May differ between clients.
    ClientConfig -> Int
ccMaxPredictionTicks :: Int
  , -- | If the client's latest known authoritative world is this many ticks
    -- behind the current tick, no prediction will be done at all when sampling.
    -- 'defaultClientConfig' uses @ccTickRate * 3@. Useful because want to save
    -- CPU cycles for catching up with the server. You may want to scale this
    -- value along with the tick rate. May differ between clients.
    ClientConfig -> Int
ccResyncThresholdTicks :: Int
  , -- | When submitting inputs to the server, we also send a copy of
    -- @ccSubmitInputDuplication@ many recently submitted inputs in order to
    -- mittigate the effect for dropped packets. 'defaultClientConfig'
    -- uses @15@.
    ClientConfig -> Int
ccSubmitInputDuplication :: Int
  } deriving (Int -> ClientConfig -> ShowS
[ClientConfig] -> ShowS
ClientConfig -> String
(Int -> ClientConfig -> ShowS)
-> (ClientConfig -> String)
-> ([ClientConfig] -> ShowS)
-> Show ClientConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientConfig] -> ShowS
$cshowList :: [ClientConfig] -> ShowS
show :: ClientConfig -> String
$cshow :: ClientConfig -> String
showsPrec :: Int -> ClientConfig -> ShowS
$cshowsPrec :: Int -> ClientConfig -> ShowS
Show, ReadPrec [ClientConfig]
ReadPrec ClientConfig
Int -> ReadS ClientConfig
ReadS [ClientConfig]
(Int -> ReadS ClientConfig)
-> ReadS [ClientConfig]
-> ReadPrec ClientConfig
-> ReadPrec [ClientConfig]
-> Read ClientConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ClientConfig]
$creadListPrec :: ReadPrec [ClientConfig]
readPrec :: ReadPrec ClientConfig
$creadPrec :: ReadPrec ClientConfig
readList :: ReadS [ClientConfig]
$creadList :: ReadS [ClientConfig]
readsPrec :: Int -> ReadS ClientConfig
$creadsPrec :: Int -> ReadS ClientConfig
Read, ClientConfig -> ClientConfig -> Bool
(ClientConfig -> ClientConfig -> Bool)
-> (ClientConfig -> ClientConfig -> Bool) -> Eq ClientConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientConfig -> ClientConfig -> Bool
$c/= :: ClientConfig -> ClientConfig -> Bool
== :: ClientConfig -> ClientConfig -> Bool
$c== :: ClientConfig -> ClientConfig -> Bool
Eq, Eq ClientConfig
Eq ClientConfig
-> (ClientConfig -> ClientConfig -> Ordering)
-> (ClientConfig -> ClientConfig -> Bool)
-> (ClientConfig -> ClientConfig -> Bool)
-> (ClientConfig -> ClientConfig -> Bool)
-> (ClientConfig -> ClientConfig -> Bool)
-> (ClientConfig -> ClientConfig -> ClientConfig)
-> (ClientConfig -> ClientConfig -> ClientConfig)
-> Ord ClientConfig
ClientConfig -> ClientConfig -> Bool
ClientConfig -> ClientConfig -> Ordering
ClientConfig -> ClientConfig -> ClientConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ClientConfig -> ClientConfig -> ClientConfig
$cmin :: ClientConfig -> ClientConfig -> ClientConfig
max :: ClientConfig -> ClientConfig -> ClientConfig
$cmax :: ClientConfig -> ClientConfig -> ClientConfig
>= :: ClientConfig -> ClientConfig -> Bool
$c>= :: ClientConfig -> ClientConfig -> Bool
> :: ClientConfig -> ClientConfig -> Bool
$c> :: ClientConfig -> ClientConfig -> Bool
<= :: ClientConfig -> ClientConfig -> Bool
$c<= :: ClientConfig -> ClientConfig -> Bool
< :: ClientConfig -> ClientConfig -> Bool
$c< :: ClientConfig -> ClientConfig -> Bool
compare :: ClientConfig -> ClientConfig -> Ordering
$ccompare :: ClientConfig -> ClientConfig -> Ordering
$cp1Ord :: Eq ClientConfig
Ord)


-- | Sensible defaults for @ClientConfig@ based on the tick rate.
defaultClientConfig ::
  -- | Tick rate (ticks per second). Must be the same across all clients and the
  -- server. Packet rate and hence network bandwidth will scale linearly with
  -- this the tick rate.
  Int ->
  ClientConfig
defaultClientConfig :: Int -> ClientConfig
defaultClientConfig Int
tickRate =
  ClientConfig :: Int -> Float -> Int -> Int -> Int -> ClientConfig
ClientConfig
    { ccTickRate :: Int
ccTickRate = Int
tickRate
    , ccFixedInputLatency :: Float
ccFixedInputLatency = Float
0.03
    , ccMaxPredictionTicks :: Int
ccMaxPredictionTicks = Int
tickRate Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
    , ccResyncThresholdTicks :: Int
ccResyncThresholdTicks = Int
tickRate Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
    , ccSubmitInputDuplication :: Int
ccSubmitInputDuplication = Int
15
    }


-- | Start a client. This blocks until the initial handshake with the
-- server is finished.
runClientWith' ::
  forall world input.
  Flat input =>
  -- | Function to send messages to the server. The underlying communication
  -- protocol need only guarantee data integrity but is otherwise free to drop
  -- and reorder packets. Typically this is backed by a UDP socket.
  (NetMsg input -> IO ()) ->
  -- | Blocking function to receive messages from the server. Has the same
  -- reliability requirements as the send function.
  (IO (NetMsg input)) ->
  -- | Optional simulation of network conditions. In production this should be
  -- `Nothing`. May differ between clients.
  Maybe SimNetConditions ->
  -- | The 'defaultClientConfig' works well for most cases.
  ClientConfig ->
  -- | Initial input for new players. Must be the same across all clients and
  -- the server. See 'Alpaca.NetCode.runClient'.
  input ->
  -- | Initial world state. Must be the same across all clients.
  world ->
  -- | A deterministic stepping function (for a single tick). Must be the same
  -- across all clients and the server. See 'Alpaca.NetCode.runClient'.
  ( M.Map PlayerId input ->
    Tick ->
    world ->
    world
  ) ->
  IO (Client world input)
runClientWith' :: (NetMsg input -> IO ())
-> IO (NetMsg input)
-> Maybe SimNetConditions
-> ClientConfig
-> input
-> world
-> (Map PlayerId input -> Tick -> world -> world)
-> IO (Client world input)
runClientWith' NetMsg input -> IO ()
sendToServer' IO (NetMsg input)
rcvFromServer' Maybe SimNetConditions
simNetConditionsMay ClientConfig
clientConfig input
input0 world
world0 Map PlayerId input -> Tick -> world -> world
stepOneTick = Int
-> (Float
    -> IO Float -> (UTCTime -> STM ()) -> IO (Client world input))
-> IO (Client world input)
forall a b.
Real a =>
a -> (Float -> IO Float -> (UTCTime -> STM ()) -> IO b) -> IO b
playCommon (ClientConfig -> Int
ccTickRate ClientConfig
clientConfig) ((Float
  -> IO Float -> (UTCTime -> STM ()) -> IO (Client world input))
 -> IO (Client world input))
-> (Float
    -> IO Float -> (UTCTime -> STM ()) -> IO (Client world input))
-> IO (Client world input)
forall a b. (a -> b) -> a -> b
$ \Float
tickTime IO Float
getTime UTCTime -> STM ()
_resetTime -> do
  (NetMsg input -> IO ()
sendToServer, IO (NetMsg input)
rcvFromServer) <-
    (NetMsg input -> IO ())
-> IO (NetMsg input)
-> Maybe SimNetConditions
-> IO (NetMsg input -> IO (), IO (NetMsg input))
forall msg.
(msg -> IO ())
-> IO msg -> Maybe SimNetConditions -> IO (msg -> IO (), IO msg)
simulateNetConditions
      NetMsg input -> IO ()
sendToServer'
      IO (NetMsg input)
rcvFromServer'
      Maybe SimNetConditions
simNetConditionsMay

  -- Authoritative Map from tick and PlayerId to inputs. The inner map is
  -- always complete (e.g. if we have the IntMap for tick i, then it contains
  -- the inputs for *all* known players)
  TVar (IntMap (Map PlayerId input))
authInputsTVar :: TVar (IntMap (M.Map PlayerId input)) <- IntMap (Map PlayerId input)
-> IO (TVar (IntMap (Map PlayerId input)))
forall a. a -> IO (TVar a)
newTVarIO (Int -> Map PlayerId input -> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a
IM.singleton Int
0 Map PlayerId input
forall k a. Map k a
M.empty)

  -- Tick to authoritative world state.
  TVar (IntMap world)
authWorldsTVar :: TVar (IntMap world) <- IntMap world -> IO (TVar (IntMap world))
forall a. a -> IO (TVar a)
newTVarIO (Int -> world -> IntMap world
forall a. Int -> a -> IntMap a
IM.singleton Int
0 world
world0)

  -- Max known auth inputs tick without any prior missing ticks.
  TVar Tick
maxAuthTickTVar :: TVar Tick <- Tick -> IO (TVar Tick)
forall a. a -> IO (TVar a)
newTVarIO Tick
0

  -- This client/host's PlayerId. Initially nothing, then set to Just the
  -- player ID on connection to the server. This is a constant thereafter.
  TVar (Maybe PlayerId)
myPlayerIdTVar <- Maybe PlayerId -> IO (TVar (Maybe PlayerId))
forall a. a -> IO (TVar a)
newTVarIO (Maybe PlayerId
forall a. Maybe a
Nothing :: Maybe PlayerId)

  -- Non-authoritative Map from tick and PlayerId to inputs. The inner map
  -- is NOT always complete (e.g. if we have the IntMap for tick i, then
  -- it may or may not yet contain all the inputs for *all* known players).
  TVar (IntMap (Map PlayerId input))
hintInputsTVar :: TVar (IntMap (M.Map PlayerId input)) <- IntMap (Map PlayerId input)
-> IO (TVar (IntMap (Map PlayerId input)))
forall a. a -> IO (TVar a)
newTVarIO (Int -> Map PlayerId input -> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a
IM.singleton Int
0 Map PlayerId input
forall k a. Map k a
M.empty)

  -- Clock Sync
  (Float -> IO Tick
estimateServerTickPlusLatencyPlusBufferPlus, Float -> Float -> Float -> IO ()
recordClockSyncSample, IO (Maybe (Float, Float))
clockAnalytics) <- Float
-> IO Float
-> IO
     (Float -> IO Tick, Float -> Float -> Float -> IO (),
      IO (Maybe (Float, Float)))
initializeClockSync Float
tickTime IO Float
getTime
  let estimateServerTickPlusLatencyPlusBuffer :: IO Tick
estimateServerTickPlusLatencyPlusBuffer = Float -> IO Tick
estimateServerTickPlusLatencyPlusBufferPlus Float
0

  -- Keep trying to connect to the server.
  ThreadId
heartbeatTid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    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
      Float
clientSendTime <- IO Float
getTime
      Bool
isConnected <- Maybe PlayerId -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PlayerId -> Bool) -> IO (Maybe PlayerId) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Maybe PlayerId) -> IO (Maybe PlayerId)
forall a. STM a -> IO a
atomically (TVar (Maybe PlayerId) -> STM (Maybe PlayerId)
forall a. TVar a -> STM a
readTVar TVar (Maybe PlayerId)
myPlayerIdTVar)
      NetMsg input -> IO ()
sendToServer ((if Bool
isConnected then Float -> NetMsg input
forall input. Float -> NetMsg input
Msg_Heartbeat else Float -> NetMsg input
forall input. Float -> NetMsg input
Msg_Connect) Float
clientSendTime)
      Bool
isClockReady <- Maybe (Float, Float) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Float, Float) -> Bool)
-> IO (Maybe (Float, Float)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Float, Float))
clockAnalytics
      Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$
        if Bool
isClockReady
          then Int
500000 -- 0.5 seconds
          else Int
50000 -- 0.05 seconds

  -- Main message processing loop
  ThreadId
msgLoopTid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    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
      NetMsg input
msg <- IO (NetMsg input)
rcvFromServer
      case NetMsg input
msg of
        Msg_Connect{} -> String -> IO ()
debugStrLn String
"Client received unexpected Msg_Connect from the server. Ignoring."
        Msg_Connected PlayerId
playerId -> do
          IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
              Maybe PlayerId
playerIdMay <- TVar (Maybe PlayerId) -> STM (Maybe PlayerId)
forall a. TVar a -> STM a
readTVar TVar (Maybe PlayerId)
myPlayerIdTVar
              case Maybe PlayerId
playerIdMay of
                Maybe PlayerId
Nothing -> do
                  TVar (Maybe PlayerId) -> Maybe PlayerId -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe PlayerId)
myPlayerIdTVar (PlayerId -> Maybe PlayerId
forall a. a -> Maybe a
Just PlayerId
playerId)
                  IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Connected! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlayerId -> String
forall a. Show a => a -> String
show PlayerId
playerId)
                Just PlayerId
playerId' -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got Msg_Connected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlayerId -> String
forall a. Show a => a -> String
show PlayerId
playerId' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"but already connected (with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlayerId -> String
forall a. Show a => a -> String
show PlayerId
playerId
        Msg_SubmitInput{} -> String -> IO ()
debugStrLn String
"Client received unexpected Msg_SubmitInput from the server. Ignoring."
        Msg_Ack{} ->
          String -> IO ()
debugStrLn String
"Client received unexpected Msg_Ack from the server. Ignoring."
        Msg_Heartbeat{} ->
          String -> IO ()
debugStrLn String
"Client received unexpected Msg_Heartbeat from the server. Ignoring."
        Msg_HeartbeatResponse Float
clientSendTime Float
serverReceiveTime -> do
          -- Record times for ping/clock sync.
          Float
clientReceiveTime <- IO Float
getTime
          Float -> Float -> Float -> IO ()
recordClockSyncSample Float
clientSendTime Float
serverReceiveTime Float
clientReceiveTime
        Msg_AuthInput Tick
headTick CompactMaps PlayerId input
authInputssCompact CompactMaps PlayerId input
hintInputssCompact -> do
          let authInputss :: [Map PlayerId input]
authInputss = CompactMaps PlayerId input -> [Map PlayerId input]
forall key value.
Eq key =>
CompactMaps key value -> [Map key value]
fromCompactMaps CompactMaps PlayerId input
authInputssCompact
          let hintInputss :: [Map PlayerId input]
hintInputss = CompactMaps PlayerId input -> [Map PlayerId input]
forall key value.
Eq key =>
CompactMaps key value -> [Map key value]
fromCompactMaps CompactMaps PlayerId input
hintInputssCompact
          [Maybe String]
resMsgs <- do
            -- Update maxAuthTickTVar if needed and send heartbeat
            NetMsg input
ackMsg <- STM (NetMsg input) -> IO (NetMsg input)
forall a. STM a -> IO a
atomically (STM (NetMsg input) -> IO (NetMsg input))
-> STM (NetMsg input) -> IO (NetMsg input)
forall a b. (a -> b) -> a -> b
$ do
              Tick
maxAuthTick <- TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
maxAuthTickTVar
              let newestTick :: Tick
newestTick = Tick
headTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Int -> Tick
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Map PlayerId input] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Map PlayerId input]
authInputss) Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
                  maxAuthTick' :: Tick
maxAuthTick' =
                    if Tick
headTick Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
<= Tick
maxAuthTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1 Bool -> Bool -> Bool
&& Tick
maxAuthTick Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
< Tick
newestTick
                      then Tick
newestTick
                      else Tick
maxAuthTick
              TVar Tick -> Tick -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Tick
maxAuthTickTVar Tick
maxAuthTick'
              NetMsg input -> STM (NetMsg input)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tick -> NetMsg input
forall input. Tick -> NetMsg input
Msg_Ack Tick
maxAuthTick')
            NetMsg input -> IO ()
sendToServer NetMsg input
ackMsg

            -- Save new auth inputs
            let newAuthTickHi :: Tick
newAuthTickHi = Tick
headTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Int64 -> Tick
Tick (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ [Map PlayerId input] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Map PlayerId input]
authInputss)
            [Maybe String]
resMsg <- [(Tick, Map PlayerId input)]
-> ((Tick, Map PlayerId input) -> IO (Maybe String))
-> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Tick] -> [Map PlayerId input] -> [(Tick, Map PlayerId input)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Tick
headTick ..] [Map PlayerId input]
authInputss) (((Tick, Map PlayerId input) -> IO (Maybe String))
 -> IO [Maybe String])
-> ((Tick, Map PlayerId input) -> IO (Maybe String))
-> IO [Maybe String]
forall a b. (a -> b) -> a -> b
$ \(Tick
tick, Map PlayerId input
inputs) -> do
              STM (Maybe String) -> IO (Maybe String)
forall a. STM a -> IO a
atomically (STM (Maybe String) -> IO (Maybe String))
-> STM (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                IntMap (Map PlayerId input)
authInputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
authInputsTVar
                -- when (tickInt `mod` 100 == 0) (putStrLn $ "Received auth tick: " ++ show tickInt)
                case IntMap (Map PlayerId input)
authInputs IntMap (Map PlayerId input) -> Int -> Maybe (Map PlayerId input)
forall a. IntMap a -> Int -> Maybe a
IM.!? Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick of
                  Just Map PlayerId input
_ -> Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> STM (Maybe String))
-> Maybe String -> STM (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Received a duplicate Msg_AuthInput for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
tick String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Ignoring."
                  Maybe (Map PlayerId input)
Nothing -> do
                    -- New auth inputs
                    TVar (IntMap (Map PlayerId input))
-> IntMap (Map PlayerId input) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (IntMap (Map PlayerId input))
authInputsTVar (Int
-> Map PlayerId input
-> IntMap (Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick) Map PlayerId input
inputs IntMap (Map PlayerId input)
authInputs)
                    Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Got auth-inputs for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
tick)

            -- Save new hint inputs, Excluding my own!
            [(Tick, Map PlayerId input)]
-> ((Tick, Map PlayerId input) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Tick] -> [Map PlayerId input] -> [(Tick, Map PlayerId input)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Tick -> Tick
forall a. Enum a => a -> a
succ Tick
newAuthTickHi ..] [Map PlayerId input]
hintInputss) (((Tick, Map PlayerId input) -> IO ()) -> IO ())
-> ((Tick, Map PlayerId input) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Tick
tick, Map PlayerId input
newHintinputs) ->
              STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Maybe PlayerId
myPlayerIdMay <- TVar (Maybe PlayerId) -> STM (Maybe PlayerId)
forall a. TVar a -> STM a
readTVar TVar (Maybe PlayerId)
myPlayerIdTVar
                TVar (IntMap (Map PlayerId input))
-> (IntMap (Map PlayerId input) -> IntMap (Map PlayerId input))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (IntMap (Map PlayerId input))
hintInputsTVar ((IntMap (Map PlayerId input) -> IntMap (Map PlayerId input))
 -> STM ())
-> (IntMap (Map PlayerId input) -> IntMap (Map PlayerId input))
-> STM ()
forall a b. (a -> b) -> a -> b
$
                  (Maybe (Map PlayerId input) -> Maybe (Map PlayerId input))
-> Int
-> IntMap (Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter
                    ( \case
                        Just Map PlayerId input
oldHintinputs
                          | Just PlayerId
myPlayerId <- Maybe PlayerId
myPlayerIdMay ->
                            Map PlayerId input -> Maybe (Map PlayerId input)
forall a. a -> Maybe a
Just (Map PlayerId input -> Set PlayerId -> Map PlayerId input
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys Map PlayerId input
oldHintinputs (PlayerId -> Set PlayerId
forall a. a -> Set a
S.singleton PlayerId
myPlayerId) Map PlayerId input -> Map PlayerId input -> Map PlayerId input
forall a. Semigroup a => a -> a -> a
<> Map PlayerId input
newHintinputs Map PlayerId input -> Map PlayerId input -> Map PlayerId input
forall a. Semigroup a => a -> a -> a
<> Map PlayerId input
oldHintinputs)
                        Maybe (Map PlayerId input)
_ -> Map PlayerId input -> Maybe (Map PlayerId input)
forall a. a -> Maybe a
Just Map PlayerId input
newHintinputs
                    )
                    (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick)

            [Maybe String] -> IO [Maybe String]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe String]
resMsg
          (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
debugStrLn ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
resMsgs)
        Msg_HintInput Tick
tick PlayerId
playerId input
inputs -> do
          Maybe String
res <- STM (Maybe String) -> IO (Maybe String)
forall a. STM a -> IO a
atomically (STM (Maybe String) -> IO (Maybe String))
-> STM (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
            IntMap (Map PlayerId input)
hintInputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
hintInputsTVar
            let hintInputsAtTick :: Map PlayerId input
hintInputsAtTick = Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
forall k a. Map k a
M.empty (IntMap (Map PlayerId input)
hintInputs IntMap (Map PlayerId input) -> Int -> Maybe (Map PlayerId input)
forall a. IntMap a -> Int -> Maybe a
IM.!? Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick)
            TVar (IntMap (Map PlayerId input))
-> IntMap (Map PlayerId input) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (IntMap (Map PlayerId input))
hintInputsTVar (Int
-> Map PlayerId input
-> IntMap (Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick) (PlayerId -> input -> Map PlayerId input -> Map PlayerId input
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PlayerId
playerId input
inputs Map PlayerId input
hintInputsAtTick) IntMap (Map PlayerId input)
hintInputs)
            Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Got hint-inputs for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
tick)
          (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
debugStrLn Maybe String
res

  -- Wait to be connected.
  PlayerId
myPlayerId <- STM PlayerId -> IO PlayerId
forall a. STM a -> IO a
atomically (STM PlayerId -> IO PlayerId) -> STM PlayerId -> IO PlayerId
forall a b. (a -> b) -> a -> b
$ do
    Maybe PlayerId
myPlayerIdMay <- TVar (Maybe PlayerId) -> STM (Maybe PlayerId)
forall a. TVar a -> STM a
readTVar TVar (Maybe PlayerId)
myPlayerIdTVar
    STM PlayerId
-> (PlayerId -> STM PlayerId) -> Maybe PlayerId -> STM PlayerId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM PlayerId
forall a. STM a
retry PlayerId -> STM PlayerId
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PlayerId
myPlayerIdMay

  -- Recently submitted inputs and their tick in reverse chronological order.
  TVar [(Tick, input)]
recentSubmittedInputsTVar <- [(Tick, input)] -> IO (TVar [(Tick, input)])
forall a. a -> IO (TVar a)
newTVarIO [(Int64 -> Tick
Tick Int64
0, input
input0)]
  -- last returned auth world tick (inclusive) from the sampling function
  TVar Tick
lastSampledAuthWorldTickTVar :: TVar Tick <- Tick -> IO (TVar Tick)
forall a. a -> IO (TVar a)
newTVarIO Tick
0
  -- last returned predicted world from the sampling function
  TVar world
lastSampledPredictedWorldTVar :: TVar world <- world -> IO (TVar world)
forall a. a -> IO (TVar a)
newTVarIO world
world0
  -- Is the client Stopped?
  TVar Bool
stoppedTVar :: TVar Bool <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False

  Client world input -> IO (Client world input)
forall (m :: * -> *) a. Monad m => a -> m a
return (Client world input -> IO (Client world input))
-> Client world input -> IO (Client world input)
forall a b. (a -> b) -> a -> b
$
    Client :: forall world input.
PlayerId
-> IO ([world], world)
-> (input -> IO ())
-> IO ()
-> Client world input
Client
      { clientPlayerId :: PlayerId
clientPlayerId = PlayerId
myPlayerId
      , clientSample' :: IO ([world], world)
clientSample' = do
          Bool
stopped <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
stoppedTVar
          if Bool
stopped
            then do
              world
lastPredictedWorld <- STM world -> IO world
forall a. STM a -> IO a
atomically (STM world -> IO world) -> STM world -> IO world
forall a b. (a -> b) -> a -> b
$ TVar world -> STM world
forall a. TVar a -> STM a
readTVar TVar world
lastSampledPredictedWorldTVar
              ([world], world) -> IO ([world], world)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], world
lastPredictedWorld)
            else do
              -- TODO we're just resimulating from the last snapshot every
              -- time. We may be able to reuse past simulation data if
              -- snapshot / inputs haven't changed.

              -- Since we are sending inputs for tick
              -- estimateServerTickPlusLatencyPlusBuffer and we want to minimize
              -- perceived input latency, we should target that same tick
              Tick
targetTick <- IO Tick
estimateServerTickPlusLatencyPlusBuffer
              (IntMap (Map PlayerId input)
inputs, IntMap (Map PlayerId input)
hintInputs, Int
startTickInt, world
startWorld) <- STM
  (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
   world)
-> IO
     (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
      world)
forall a. STM a -> IO a
atomically (STM
   (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
    world)
 -> IO
      (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
       world))
-> STM
     (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
      world)
-> IO
     (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
      world)
forall a b. (a -> b) -> a -> b
$ do
                (Int
startTickInt, world
startWorld) <-
                  (Int, world) -> Maybe (Int, world) -> (Int, world)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Int, world)
forall a. HasCallStack => String -> a
error (String -> (Int, world)) -> String -> (Int, world)
forall a b. (a -> b) -> a -> b
$ String
"No authoritative world found <= " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
targetTick) -- We have at least the initial world
                    (Maybe (Int, world) -> (Int, world))
-> (IntMap world -> Maybe (Int, world))
-> IntMap world
-> (Int, world)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap world -> Maybe (Int, world)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupLE (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
targetTick)
                    (IntMap world -> (Int, world))
-> STM (IntMap world) -> STM (Int, world)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (IntMap world) -> STM (IntMap world)
forall a. TVar a -> STM a
readTVar TVar (IntMap world)
authWorldsTVar
                IntMap (Map PlayerId input)
inputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
authInputsTVar
                IntMap (Map PlayerId input)
hintInputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
hintInputsTVar
                (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
 world)
-> STM
     (IntMap (Map PlayerId input), IntMap (Map PlayerId input), Int,
      world)
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (Map PlayerId input)
inputs, IntMap (Map PlayerId input)
hintInputs, Int
startTickInt, world
startWorld)
              let startInputs :: Map PlayerId input
startInputs =
                    Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe
                      (String -> Map PlayerId input
forall a. HasCallStack => String -> a
error (String -> Map PlayerId input) -> String -> Map PlayerId input
forall a b. (a -> b) -> a -> b
$ String
"Have auth world but no authoritative inputs at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
startTick) -- We assume that we always have auth inputs on ticks where we have auth worlds.
                      (Int -> IntMap (Map PlayerId input) -> Maybe (Map PlayerId input)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
startTickInt IntMap (Map PlayerId input)
inputs)
                  startTick :: Tick
startTick = Int64 -> Tick
Tick (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
startTickInt)

                  predict ::
                    Int64 -> -- How many ticks of prediction to allow
                    Tick -> -- Some tick i
                    M.Map PlayerId input -> -- inputs at tick i
                    world -> -- world at tick i if simulated
                    Bool -> -- Is the world authoritative?
                    IO world -- world at targetTick (or latest tick if predictionAllowance ran out)
                  predict :: Int64 -> Tick -> Map PlayerId input -> world -> Bool -> IO world
predict Int64
predictionAllowance Tick
tick Map PlayerId input
tickInputs world
world Bool
isWAuth = case Tick -> Tick -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Tick
tick Tick
targetTick of
                    Ordering
LT -> do
                      let tickNext :: Tick
tickNext = Tick
tick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1

                          inputsNextAuthMay :: Maybe (Map PlayerId input)
inputsNextAuthMay = IntMap (Map PlayerId input)
inputs IntMap (Map PlayerId input) -> Int -> Maybe (Map PlayerId input)
forall a. IntMap a -> Int -> Maybe a
IM.!? (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tickNext) -- auth input
                          isInputsNextAuth :: Bool
isInputsNextAuth = Maybe (Map PlayerId input) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Map PlayerId input)
inputsNextAuthMay
                          isWNextAuth :: Bool
isWNextAuth = Bool
isWAuth Bool -> Bool -> Bool
&& Bool
isInputsNextAuth
                      if Bool
isWNextAuth Bool -> Bool -> Bool
|| Int64
predictionAllowance Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0
                        then do
                          let inputsNextHintPart :: Map PlayerId input
inputsNextHintPart = Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
forall k a. Map k a
M.empty (IntMap (Map PlayerId input)
hintInputs IntMap (Map PlayerId input) -> Int -> Maybe (Map PlayerId input)
forall a. IntMap a -> Int -> Maybe a
IM.!? (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tickNext)) -- partial hint inputs
                              inputsNextHintFilled :: Map PlayerId input
inputsNextHintFilled = Map PlayerId input
inputsNextHintPart Map PlayerId input -> Map PlayerId input -> Map PlayerId input
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map PlayerId input
tickInputs -- hint input (filled with previous input)
                              inputsNext :: Map PlayerId input
inputsNext = Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
inputsNextHintFilled Maybe (Map PlayerId input)
inputsNextAuthMay
                              wNext :: world
wNext = Map PlayerId input -> Tick -> world -> world
stepOneTick Map PlayerId input
inputsNext Tick
tickNext world
world

                              pruneOldAuthWorlds :: Bool
pruneOldAuthWorlds = Bool
True
                          -- TODO ^^ in the future we may wan to keep all auth
                          -- worlds to implement a time traveling debugger
                          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isWNextAuth (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                              TVar (IntMap world) -> (IntMap world -> IntMap world) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (IntMap world)
authWorldsTVar (Int -> world -> IntMap world -> IntMap world
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tickNext) world
wNext)
                              Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pruneOldAuthWorlds (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
                                -- We keep all new authworlds as we used them in
                                -- `newAuthWorlds` and ultimately return them on
                                -- sample.
                                Tick
lastSampledAuthWorldTick <- TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
lastSampledAuthWorldTickTVar
                                TVar (IntMap world) -> (IntMap world -> IntMap world) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (IntMap world)
authWorldsTVar ((IntMap world, IntMap world) -> IntMap world
forall a b. (a, b) -> b
snd ((IntMap world, IntMap world) -> IntMap world)
-> (IntMap world -> (IntMap world, IntMap world))
-> IntMap world
-> IntMap world
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap world -> (IntMap world, IntMap world)
forall a. Int -> IntMap a -> (IntMap a, IntMap a)
IM.split (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
lastSampledAuthWorldTick))

                          let predictionAllowance' :: Int64
predictionAllowance' = if Bool
isWNextAuth then Int64
predictionAllowance else Int64
predictionAllowance Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1
                          Int64 -> Tick -> Map PlayerId input -> world -> Bool -> IO world
predict Int64
predictionAllowance' Tick
tickNext Map PlayerId input
inputsNext world
wNext Bool
isWNextAuth
                        else world -> IO world
forall (m :: * -> *) a. Monad m => a -> m a
return world
world
                    Ordering
EQ -> world -> IO world
forall (m :: * -> *) a. Monad m => a -> m a
return world
world
                    Ordering
GT -> String -> IO world
forall a. HasCallStack => String -> a
error String
"Impossible! simulated past target tick!"

              -- If very behind the server, we want to do 0 prediction
              Tick
maxAuthTick <- 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
$ TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
maxAuthTickTVar
              let predictionAllowance :: Int64
predictionAllowance =
                    if Tick
targetTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
maxAuthTick Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Tick
Tick (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ ClientConfig -> Int
ccResyncThresholdTicks ClientConfig
clientConfig)
                      then Int64
0
                      else Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ClientConfig -> Int
ccMaxPredictionTicks ClientConfig
clientConfig)

              world
predictedTargetW <- Int64 -> Tick -> Map PlayerId input -> world -> Bool -> IO world
predict Int64
predictionAllowance Tick
startTick Map PlayerId input
startInputs world
startWorld Bool
True
              STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar world -> world -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar world
lastSampledPredictedWorldTVar world
predictedTargetW
              [world]
newAuthWorlds :: [world] <- STM [world] -> IO [world]
forall a. STM a -> IO a
atomically (STM [world] -> IO [world]) -> STM [world] -> IO [world]
forall a b. (a -> b) -> a -> b
$ do
                Tick
lastSampledAuthWorldTick <- TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
lastSampledAuthWorldTickTVar
                IntMap world
authWorlds <- TVar (IntMap world) -> STM (IntMap world)
forall a. TVar a -> STM a
readTVar TVar (IntMap world)
authWorldsTVar
                let latestAuthWorldTick :: Tick
latestAuthWorldTick = Int64 -> Tick
Tick (Int64 -> Tick) -> Int64 -> Tick
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ (Int, world) -> Int
forall a b. (a, b) -> a
fst ((Int, world) -> Int) -> (Int, world) -> Int
forall a b. (a -> b) -> a -> b
$ IntMap world -> (Int, world)
forall a. IntMap a -> (Int, a)
IM.findMax IntMap world
authWorlds
                TVar Tick -> Tick -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Tick
lastSampledAuthWorldTickTVar Tick
latestAuthWorldTick
                [world] -> STM [world]
forall (m :: * -> *) a. Monad m => a -> m a
return ((IntMap world
authWorlds IntMap world -> Int -> world
forall a. IntMap a -> Int -> a
IM.!) (Int -> world) -> (Tick -> Int) -> Tick -> world
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tick -> world) -> [Tick] -> [world]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tick
lastSampledAuthWorldTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1 .. Tick
latestAuthWorldTick])

              ([world], world) -> IO ([world], world)
forall (m :: * -> *) a. Monad m => a -> m a
return ([world]
newAuthWorlds, world
predictedTargetW)
      , clientSetInput :: input -> IO ()
clientSetInput =
          -- TODO We can send (non-auth) inputs p2p!

          -- TODO this mechanism minimizes latency when `targetTick > lastTick` by
          -- sending the input to the server immediately, but when `targetTick <=
          -- lastTick`, then the input will be ghosted!
          \input
newInput -> do
            Bool
stopped <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
stoppedTVar
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
stopped) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              -- We submit events as soon as we expect the server to be on a future
              -- tick. Else we just store the new input.
              Tick
targetTick <- Float -> IO Tick
estimateServerTickPlusLatencyPlusBufferPlus (ClientConfig -> Float
ccFixedInputLatency ClientConfig
clientConfig)
              IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
                  Tick
lastTick <-
                    ( \case
                        [] -> Int64 -> Tick
Tick Int64
0
                        (Tick
t, input
_) : [(Tick, input)]
_ -> Tick
t
                      )
                      ([(Tick, input)] -> Tick) -> STM [(Tick, input)] -> STM Tick
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [(Tick, input)] -> STM [(Tick, input)]
forall a. TVar a -> STM a
readTVar TVar [(Tick, input)]
recentSubmittedInputsTVar
                  if Tick
targetTick Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
> Tick
lastTick
                    then do
                      -- Store our own inputs as a hint so we get 0 latency. This is
                      -- only a hint and not authoritative as it's still possible that
                      -- submitted inputs are dropped or rejected by the server. If
                      -- we've jumped a few ticks forward than we keep we don't attempt
                      -- to submit inputs to "fill in the gap". We assume constant as
                      -- the server and other clients predicted those inputs as constant
                      -- anyway.
                      TVar (IntMap (Map PlayerId input))
-> (IntMap (Map PlayerId input) -> IntMap (Map PlayerId input))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (IntMap (Map PlayerId input))
hintInputsTVar ((IntMap (Map PlayerId input) -> IntMap (Map PlayerId input))
 -> STM ())
-> (IntMap (Map PlayerId input) -> IntMap (Map PlayerId input))
-> STM ()
forall a b. (a -> b) -> a -> b
$
                        (Maybe (Map PlayerId input) -> Maybe (Map PlayerId input))
-> Int
-> IntMap (Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter
                          (Map PlayerId input -> Maybe (Map PlayerId input)
forall a. a -> Maybe a
Just (Map PlayerId input -> Maybe (Map PlayerId input))
-> (Maybe (Map PlayerId input) -> Map PlayerId input)
-> Maybe (Map PlayerId input)
-> Maybe (Map PlayerId input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayerId -> input -> Map PlayerId input -> Map PlayerId input
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PlayerId
myPlayerId input
newInput (Map PlayerId input -> Map PlayerId input)
-> (Maybe (Map PlayerId input) -> Map PlayerId input)
-> Maybe (Map PlayerId input)
-> Map PlayerId input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
forall k a. Map k a
M.empty)
                          (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
targetTick)

                      TVar [(Tick, input)]
-> ([(Tick, input)] -> [(Tick, input)]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [(Tick, input)]
recentSubmittedInputsTVar (([(Tick, input)] -> [(Tick, input)]) -> STM ())
-> ([(Tick, input)] -> [(Tick, input)]) -> STM ()
forall a b. (a -> b) -> a -> b
$
                        Int -> [(Tick, input)] -> [(Tick, input)]
forall a. Int -> [a] -> [a]
take (ClientConfig -> Int
ccSubmitInputDuplication ClientConfig
clientConfig)
                          ([(Tick, input)] -> [(Tick, input)])
-> ([(Tick, input)] -> [(Tick, input)])
-> [(Tick, input)]
-> [(Tick, input)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Tick
targetTick, input
newInput) (Tick, input) -> [(Tick, input)] -> [(Tick, input)]
forall a. a -> [a] -> [a]
:)
                      [(Tick, input)]
inputsToSubmit <- TVar [(Tick, input)] -> STM [(Tick, input)]
forall a. TVar a -> STM a
readTVar TVar [(Tick, input)]
recentSubmittedInputsTVar
                      IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (NetMsg input -> IO ()
sendToServer ([(Tick, input)] -> NetMsg input
forall input. [(Tick, input)] -> NetMsg input
Msg_SubmitInput [(Tick, input)]
inputsToSubmit))
                    else IO () -> STM (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
      , clientStop :: IO ()
clientStop = do
          Bool
stopped <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
stoppedTVar)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
stopped) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ThreadId -> IO ()
killThread ThreadId
msgLoopTid
            ThreadId -> IO ()
killThread ThreadId
heartbeatTid
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
stoppedTVar Bool
True
      }