wizard-wipeout/src-server/Server/Game.hs

{-# 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 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
  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"
      receiveMessages
      handleMessages
      updateSpawners delta
      updateWizards delta
      sendUpdates
      modify'
        (\s -> s
          { scServerLastTick = now
          }
        )
      fps <- asks rcFPS
      let remainingTime = recip (fromIntegral fps) - delta
      when (remainingTime > 0) $
        liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
    )

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)) ->
          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 player {
               playerWizard = wizard
                 { wizardEffects = newEffects
                 , wizardHealth  = health - effectDamage
                 }
             }
        )
        players
  void $ liftIO $ STM.atomically $ STM.swapTMVar playersVar newPlayers