diff --git a/src-lib/Library/Types.hs b/src-lib/Library/Types.hs index b2e8f9c..231c7a1 100644 --- a/src-lib/Library/Types.hs +++ b/src-lib/Library/Types.hs @@ -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 + ] diff --git a/src-server/Main.hs b/src-server/Main.hs index 65ae4a0..f76766e 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -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 + } + ) diff --git a/src-server/Server/Map.hs b/src-server/Server/Map.hs index 3287e49..27f68df 100644 --- a/src-server/Server/Map.hs +++ b/src-server/Server/Map.hs @@ -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 diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 11c76bf..79e5b2a 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -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 () diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index a27fb5c..747dda4 100644 --- a/wizard-wipeout.cabal +++ b/wizard-wipeout.cabal @@ -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