116 lines
3.1 KiB
Haskell
116 lines
3.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Server.Game where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
|
|
import qualified Control.Concurrent.STM as STM
|
|
|
|
import Control.Monad.RWS.Strict
|
|
|
|
import Control.Monad.Loops
|
|
|
|
import Control.Concurrent
|
|
|
|
import qualified Data.ByteString.Char8 as B8
|
|
|
|
import Data.Time
|
|
|
|
import Data.String (fromString)
|
|
|
|
import System.IO (stdout)
|
|
|
|
-- internal imports
|
|
|
|
import Library.Types
|
|
|
|
import Server.Communication
|
|
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
|
|
before <- gets scServerLastTick
|
|
now <- liftIO getCurrentTime
|
|
let delta = realToFrac $ diffUTCTime now before
|
|
liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> " \r"
|
|
handleMessages
|
|
updateSpawners delta
|
|
updateWizards delta
|
|
modify'
|
|
(\s -> s
|
|
{ scServerLastTick = now
|
|
}
|
|
)
|
|
fps <- asks rcFPS
|
|
sendUpdates
|
|
let remainingTime = recip (fromIntegral fps) - delta
|
|
when (remainingTime > 0) $
|
|
liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
|
|
)
|
|
liftIO $ killThread recvThread
|
|
|
|
updateSpawners :: Float -> Game ()
|
|
updateSpawners dt =
|
|
modify' (\sc@(StateContainer spawners _ _ _ _ _) ->
|
|
let newSpawners = map
|
|
(\spawner -> do
|
|
let newTTL = spawnerReloadTTL spawner - dt
|
|
if newTTL < 0 && spawnerState spawner == SpawnerEmpty
|
|
then spawner
|
|
{ spawnerReloadTTL = fromIntegral $ spawnerReloadTime spawner
|
|
, spawnerState = SpawnerFull
|
|
}
|
|
else spawner
|
|
{ spawnerReloadTTL = spawnerReloadTTL spawner - dt
|
|
}
|
|
)
|
|
spawners
|
|
in sc
|
|
{ scSpawners = newSpawners
|
|
}
|
|
)
|
|
|
|
updateWizards :: Float -> Game ()
|
|
updateWizards dt = do
|
|
playersVar <- gets scPlayers
|
|
players <- liftIO $ STM.atomically $ STM.readTMVar playersVar
|
|
let newPlayers = map
|
|
(\player@(Player pId wizard@(Wizard _ _ health _ _ effects) readiness) ->
|
|
let newEffects = foldl
|
|
(\acc effect@(Effect _ ttl) ->
|
|
if ttl - dt < 0
|
|
then acc
|
|
else effect
|
|
{ effectTTL = ttl - dt
|
|
} : acc
|
|
)
|
|
[]
|
|
effects
|
|
effectDamage = foldl
|
|
(\acc (Effect kind _) ->
|
|
if kind `elem` harmingAfflictions
|
|
then acc + 1
|
|
else acc
|
|
)
|
|
0
|
|
effects
|
|
in
|
|
if readiness
|
|
then
|
|
player
|
|
{ playerWizard = wizard
|
|
{ wizardEffects = newEffects
|
|
, wizardHealth = health - effectDamage
|
|
}
|
|
}
|
|
else
|
|
player
|
|
)
|
|
players
|
|
void $ liftIO $ STM.atomically $ STM.swapTMVar playersVar newPlayers
|