figure out timing problems

This commit is contained in:
nek0 2023-12-20 09:04:50 +01:00
parent 324a776227
commit a202ec17b3
6 changed files with 50 additions and 27 deletions

View file

@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock"
setMapRows : 40
setMapColumns : 40
setSpawnerProbability : 0.01
setFPS : 30
setFPS : 60

View file

@ -11,6 +11,8 @@ import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.UUID
import qualified Data.Vector.Storable as VS
import Foreign hiding (void)
@ -50,7 +52,6 @@ sendMessage msg sock = do
handleMessages
:: Game ()
handleMessages = do
sock <- asks rcSocket
queue <- asks rcQueue
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
@ -61,21 +62,21 @@ handleMessage
:: ServerMessage
-> Game ()
handleMessage ServerQuit = do
state <- get
let stateCont = scClientState state
st <- get
let stateCont = scClientState st
liftIO $ STM.atomically $ do
state <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ state
stateContainer <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ stateContainer
{ clientStop = True
}
put $ state
put $ st
{ scClientState = stateCont
}
liftIO $ putStrLn "Quitting due to server shutdown"
handleMessage (TickUpdate slice wizard) = do
modify' (\state@(StateContainer {..}) ->
state
modify' (\st@(StateContainer {}) ->
st
{ scWizard = wizard
, scMapSlice = slice
}
@ -103,8 +104,8 @@ receiveMessage sock queue = do
terminateGameOnSigint
:: Game ()
terminateGameOnSigint = do
sock <- asks rcSocket
clientId <- asks rcClientUUID
-- sock <- asks rcSocket
-- clientId <- asks rcClientUUID
clientState <- gets scClientState
void $ liftIO $ installHandler
keyboardSignal
@ -114,9 +115,16 @@ terminateGameOnSigint = do
void $ STM.swapTMVar clientState $ currentState { clientStop = True }
pure currentState
Vty.shutdown (clientVty currentState)
sendMessage (ClientMessage clientId ClientQuit) sock
close sock
-- partingMessage clientId sock
-- Raise SIGINT again so it does not get blocked
-- raiseSignal keyboardSignal
)
Nothing
partingMessage
:: UUID
-> Socket
-> IO ()
partingMessage clientId sock = do
sendMessage (ClientMessage clientId ClientQuit) sock
-- close sock

View file

@ -1,7 +1,11 @@
module Client.Game where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Loops
import Control.Monad.RWS
@ -15,9 +19,12 @@ import Library.Types
runGame :: Game ()
runGame = do
handleMessages
sock <- asks rcSocket
queue <- asks rcQueue
recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue
whileM_
(not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
(do
pure ()
handleMessages
)
liftIO $ killThread recvThread

View file

@ -7,16 +7,14 @@ import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Loops
import Control.Monad.RWS
import qualified Data.Matrix as M
import Graphics.Vty
import Network.Socket (close)
import Options.Applicative
-- internal imports
@ -78,6 +76,9 @@ main = do
)
initRead
initState
partingMessage clientId sock
threadDelay $ 1 * 10 ^ 6
close sock
where
opts = info (options <**> helper)
( fullDesc

View file

@ -23,6 +23,7 @@ import qualified Data.Matrix as M
import Data.Maybe
import Data.UUID
import Data.UUID.V4
import qualified Data.Vector.Storable as VS
@ -114,12 +115,13 @@ sendMessage msg sock = do
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
-- | receive incoming messages from clients
receiveMessages :: Game ()
receiveMessages = do
clientsVar <- gets scClientSockets
receiveMessages
:: STM.TMVar [(Maybe UUID, Socket)]
-> STM.TQueue ClientMessage
-> IO ()
receiveMessages clientsVar queue = do
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
queue <- gets scMessageQueue
void $ liftIO $ forkIO $ mapM_
mapM_
(\(_, clientSocket) -> do
receiveMessage clientSocket queue
)
@ -159,7 +161,7 @@ receiveMessage sock queue = do
(pure ())
(\msg -> do
liftIO $ STM.atomically $ STM.writeTQueue queue msg
when (msg == IdRequest) (threadDelay $ 10 ^ 3)
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
mmsg

View file

@ -9,6 +9,8 @@ import Control.Monad.RWS.Strict
import Control.Monad.Loops
import Control.Concurrent
import qualified Data.ByteString.Char8 as B8
import Data.Time
@ -27,6 +29,9 @@ import Server.Types
runGame :: Game ()
runGame = do
processRequests
clientsVar <- gets scClientSockets
queue <- gets scMessageQueue
recvThread <- liftIO $ forkIO $ forever $ receiveMessages clientsVar queue
whileM_
(not . serverStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scServerState))
(do
@ -34,7 +39,6 @@ runGame = do
now <- liftIO getCurrentTime
let delta = realToFrac $ diffUTCTime now before
liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> " \r"
receiveMessages
handleMessages
updateSpawners delta
updateWizards delta
@ -44,11 +48,12 @@ runGame = do
}
)
fps <- asks rcFPS
sendUpdates
-- sendUpdates
let remainingTime = recip (fromIntegral fps) - delta
when (remainingTime > 0) $
liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
)
liftIO $ killThread recvThread
updateSpawners :: Float -> Game ()
updateSpawners dt =