start creating amin server loop

This commit is contained in:
nek0 2023-12-08 05:19:32 +01:00
parent bf2310a011
commit 7516364193
5 changed files with 181 additions and 12 deletions

View file

@ -19,7 +19,7 @@ data Wizard = Wizard
-- ^ Player's Mana (magic fuel)
, wizardWands :: [Wand]
-- ^ Player's wands (read: weapons)
, wizardEffect :: [Effect]
, wizardEffects :: [Effect]
-- ^ 'Effect's affecting the player
}
deriving (Show, Eq)
@ -49,12 +49,6 @@ data Tile
| Wall -- ^ obstacle
deriving (Show, Eq)
data ServerOptions = ServerOptions
{ serOptMapWidth :: Int -- ^ Map width
, serOptMapHeight :: Int -- ^ Map height
}
deriving (Show, Eq)
data Arena = Arena
{ arenaMap :: ServerMap
, arenaSpawners :: [Spawner]
@ -97,3 +91,9 @@ data Affliction
| Frozen -- ^ Unable to perform any action
| Shielded -- ^ invulnerable until next hit or time runs out.
deriving (Show, Eq)
harmingAfflictions :: [ Affliction ]
harmingAfflictions =
[ Burning
, Frozen
]

View file

@ -1,4 +1,126 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (threadDelay)
import Control.Monad.Loops
import Control.Monad.RWS.Strict
import qualified Data.ByteString.Char8 as B8
import Data.String (fromString)
import Data.Time
import Data.Yaml
import Options.Applicative
-- internal imports
import Library.Types
import Server.Types
import Server.Map (generateArena)
main :: IO ()
main = putStrLn "Hello, Haskell!"
main = do
putStrLn "Hello, Wizards!"
(Options optSettingLoc) <- execParser opts
raw <- B8.readFile optSettingLoc
case decodeEither' raw of
Left msg ->
error (optSettingLoc <> ":" <>
" error: " <>
fromString (prettyPrintParseException msg)
)
Right (Settings {..}) -> do
arena <- generateArena setMapRows setMapColumns setSpawnerProbability
putStrLn "generated arena:"
print (arenaMap arena)
putStrLn "-----------------------------------------------------------------------------------"
putStrLn "starting game…"
now <- getCurrentTime
let initRead = ReaderContainer (arenaMap arena) setFPS
initState = StateContainer (arenaSpawners arena) [] (ServerState False False) now
(finalState, finalWrite) <- execRWST runGame initRead initState
print finalWrite
where
opts = info (options <**> helper)
( fullDesc
<> progDesc "Run the \"wizard-wipeout\" Server."
<> header "wizard-wipeout - Last Mage standing"
)
runGame :: Game
runGame = do
whileM_
(not . serverStop <$> gets scServerState)
(do
before <- gets scServerLastTick
now <- liftIO getCurrentTime
let delta = realToFrac $ diffUTCTime now before
updateSpawners delta
updateWizards delta
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 =
modify' (\sc@(StateContainer _ wizards _ _) ->
let newWizards = map
(\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 wizard
{ wizardEffects = newEffects
, wizardHealth = health - effectDamage
}
)
wizards
in sc
{ scPlayers = newWizards
}
)

View file

@ -30,7 +30,10 @@ generateArena arenaRows arenaColumns spawnerChance = do
Spawner
(wands !! randomWandIndex)
randomReloadTime
(V2 (fromIntegral r) (fromIntegral c) + V2 0.5 0.5) : acc
SpawnerFull
0
(V2 (fromIntegral r) (fromIntegral c) + V2 0.5 0.5)
: acc
else
pure acc
_ -> pure acc

View file

@ -1,19 +1,53 @@
{-# LANGUAGE DeriveGeneric #-}
module Server.Options where
module Server.Types where
import Control.Monad.RWS.Strict
import qualified Data.Aeson as Aeson
import Data.Time.Clock
import GHC.Generics
import Options.Applicative as O
import Library.Types
data Settings = Settings
{ setSocketPath :: FilePath
, setMapRows :: Int
, setMapColumns :: Int
, setSpawnerProbability :: Float
, setFPS :: Int
}
deriving (Show, Generic)
instance Aeson.FromJSON Settings
data Options = Options
newtype Options = Options
{ optConfLoc :: FilePath
}
options :: O.Parser Options
options = Options
<$> strOption
( long "configuration"
<> short 'c'
<> metavar "FILEPATH"
<> help "Location of the configuration YAML-file"
)
data ReaderContainer = ReaderContainer
{ rcMap :: ServerMap
, rcFPS :: Int
}
deriving (Eq, Show)
data StateContainer = StateContainer
{ scSpawners :: [ Spawner ]
, scPlayers :: [ Wizard ]
, scServerState :: ServerState
, scServerLastTick :: UTCTime
}
type Game = RWST ReaderContainer String StateContainer IO ()

View file

@ -33,7 +33,10 @@ executable wizard-wipeout-client
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.17.2.1
, monad-loops
, mtl
, network
, vty
, wizard-wipeout
hs-source-dirs: src-client
default-language: GHC2021
@ -42,14 +45,21 @@ executable wizard-wipeout-server
import: warnings
main-is: Main.hs
other-modules: Server.Map
Server.Map.Snippets
Server.Types
-- other-extensions:
build-depends: base ^>=4.17.2.1
, aeson
, bytestring
, linear
, matrix
, monad-loops
, mtl
, network
, optparse-applicative
, text
, time
, random
, wizard-wipeout
, yaml
hs-source-dirs: src-server
default-language: GHC2021