From afa21eaece1794704095edfd730409d7b9f2b6ed Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 11 Dec 2023 17:21:24 +0100 Subject: [PATCH] restructure of library and introducing channels to client --- src-client/Client/Communication.hs | 17 +++-- src-client/Main.hs | 19 +++-- src-lib/Library/Types.hs | 43 +----------- src-lib/Library/Types/Communication.hs | 4 ++ src-lib/Library/Types/Map.hs | 96 ++++++++++++++++++++++++++ wizard-wipeout.cabal | 2 + 6 files changed, 127 insertions(+), 54 deletions(-) create mode 100644 src-lib/Library/Types/Map.hs diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 2d90317..a549ce3 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase #-} module Client.Communication where +import qualified Control.Concurrent.STM as STM + import Control.Monad (void) import qualified Data.Aeson as A @@ -8,6 +10,8 @@ import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as B8 +import Data.Maybe (fromJust) + import qualified Data.Vector.Storable as VS import Foreign hiding (void) @@ -41,16 +45,15 @@ sendMessage msg sock = do receiveMessage :: Socket - -> IO ServerMessage -receiveMessage sock = do + -> STM.TQueue ServerMessage + -> IO () +receiveMessage sock queue = do let maxBufferLength = 4096 ptr <- mallocArray maxBufferLength bufferLength <- recvBuf sock ptr maxBufferLength msg <- B.pack <$> peekArray bufferLength ptr let mJsonMsg = A.decode' $ B8.fromStrict msg - jsonMsg <- maybe - (error $ "unexpected message from Server: " <> show msg) - pure + maybe + (pure ()) + (STM.atomically . STM.writeTQueue queue) mJsonMsg - free ptr - pure jsonMsg diff --git a/src-client/Main.hs b/src-client/Main.hs index ad052db..57283f6 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -3,6 +3,8 @@ module Main where import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.STM as STM + import Options.Applicative -- internal imports @@ -18,17 +20,24 @@ main = do (Options socketLocation) <- execParser opts putStrLn $ "connecting to Socket " <> socketLocation sock <- connectSocket socketLocation + queue <- STM.newTQueueIO putStrLn "connected" sendMessage (IdRequest) sock - threadDelay $ 5 * 10 ^ 6 - clientIdMsg <- receiveMessage sock + threadDelay $ 1 * 10 ^ 6 + receiveMessage sock queue + threadDelay $ 1 * 10 ^ 6 + clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue) let clientId = acClientUUID clientIdMsg putStrLn $ "received client UUID: " <> show clientId - threadDelay $ 5 * 10 ^ 6 + threadDelay $ 1 * 10 ^ 6 putStrLn welcomeText threadDelay $ 15 * 10 ^ 6 + putStrLn welcomeText sendMessage (ClientMessage clientId ClientRequestWizard) sock - playerWizard <- receiveMessage sock + threadDelay $ 1 * 10 ^ 6 + receiveMessage sock queue + threadDelay $ 1 * 10 ^ 6 + playerWizard <- head <$> STM.atomically (STM.flushTQueue queue) putStrLn "received wizard" print (initWizard playerWizard) let initRead = ReaderContainer sock clientId @@ -50,7 +59,7 @@ welcomeText = mconcat $ map (<> "\n") , "" , "Some last hints before you enter the fighting grounds:" , "" - , "press [SpACE] to fire your wand" + , "press [SPACE] to fire your wand" , "press [1] through [9] to change wands, if you have collected more wands" , "press [ESC] to leave" , "" diff --git a/src-lib/Library/Types.hs b/src-lib/Library/Types.hs index 2674f43..3eb6033 100644 --- a/src-lib/Library/Types.hs +++ b/src-lib/Library/Types.hs @@ -1,48 +1,7 @@ module Library.Types ( module T - , module Library.Types ) where -import Data.Matrix -import Graphics.Vty - import Library.Types.Communication as T import Library.Types.Player as T - --- | Data object for storing the client's state -data ClientState = ClientState - { clientVty :: Vty -- ^ Context object for graphics - , clientGameOver :: Bool -- ^ client game over (contestant died) - , clientStop :: Bool -- ^ client shutdown - } - --- | Type synonym for the Map. Translates to a Matrix of 'Tile's -type ServerMap = Matrix Tile - --- | Type synonym for the Map. Translates to a Matrix of 'Maybe Tile's -type ClientMap = Matrix (Maybe Tile) - -data Tile - = Air -- ^ walkable area - | Wall -- ^ obstacle - deriving (Show, Eq) - -data Arena = Arena - { arenaMap :: ServerMap - , arenaSpawners :: [Spawner] - } - deriving (Show, Eq) - -data Spawner = Spawner - { spawnerPowerup :: Wand -- ^ Which 'Powerup' is being spawned - , spawnerReloadTime :: Int -- ^ How long does it take for the 'Powerup' to reappear - , spawnerState :: SpawnerState - , spawnerReloadTTL :: Float - , spawnerPosition :: Position -- ^ Position of the `Spawner` on the map - } - deriving (Show, Eq) - -data SpawnerState - = SpawnerFull - | SpawnerEmpty - deriving (Eq, Show) +import Library.Types.Map as T diff --git a/src-lib/Library/Types/Communication.hs b/src-lib/Library/Types/Communication.hs index 4cc62d3..26c8a42 100644 --- a/src-lib/Library/Types/Communication.hs +++ b/src-lib/Library/Types/Communication.hs @@ -19,6 +19,10 @@ data ServerMessage | ProvideInitialWizard { initWizard :: Wizard } + | TickUpdate + { tuMapSlice :: MapSlice + , tuWizard :: Wizard + } deriving (Eq, Show, Generic) instance FromJSON ServerMessage diff --git a/src-lib/Library/Types/Map.hs b/src-lib/Library/Types/Map.hs new file mode 100644 index 0000000..3f3293f --- /dev/null +++ b/src-lib/Library/Types/Map.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveGeneric #-} +module Library.Types.Map where + +import Data.Matrix + +import GHC.Generics + +import Graphics.Vty + +-- internal imports + +import Library.Types.Player +import Data.Aeson (ToJSON, FromJSON) + +-- | Data object for storing the client's state +data ClientState = ClientState + { clientVty :: Vty -- ^ Context object for graphics + , clientGameOver :: Bool -- ^ client game over (contestant died) + , clientStop :: Bool -- ^ client shutdown + } + +-- | Type synonym for the Map. Translates to a Matrix of 'Tile's +type ServerMap = Matrix Tile + +-- | Type synonym for the Map. Translates to a Matrix of 'Maybe Tile's +type ClientMap = Matrix (Maybe Tile) + +instance ToJSON ClientMap + +instance FromJSON ClientMap + +data Tile + = Air -- ^ walkable area + | Wall -- ^ obstacle + deriving (Show, Eq, Generic) + +instance ToJSON Tile + +instance FromJSON Tile + +data Arena = Arena + { arenaMap :: ServerMap + , arenaSpawners :: [Spawner] + } + deriving (Show, Eq) + +data Spawner = Spawner + { spawnerPowerup :: Wand -- ^ Which 'Powerup' is being spawned + , spawnerReloadTime :: Int -- ^ How long does it take for the 'Powerup' to reappear + , spawnerState :: SpawnerState + , spawnerReloadTTL :: Float + , spawnerPosition :: Position -- ^ Position of the `Spawner` on the map + } + deriving (Show, Eq) + +data SpawnerState + = SpawnerFull + | SpawnerEmpty + deriving (Eq, Show) + +data MapSlice = MapSlice + { msViewMap :: ClientMap + , msViewOffset :: Position + , msContents :: [Effigy] + } + deriving (Eq, Show, Generic) + +instance ToJSON MapSlice + +instance FromJSON MapSlice + +data Effigy = Effigy + { effPosition :: Position + , effType :: EffigyType + } + deriving (Eq, Show, Generic) + +instance ToJSON Effigy + +instance FromJSON Effigy + +data EffigyType + = EffZap + | EffBigZap + | EffFire + | EffIce + | EffBigWand + | EffFireWand + | EffIceWand + | EffWizard + | EffCorpse + deriving (Eq, Show, Generic) + +instance ToJSON EffigyType + +instance FromJSON EffigyType diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index 8eb4f95..53991c7 100644 --- a/wizard-wipeout.cabal +++ b/wizard-wipeout.cabal @@ -20,6 +20,7 @@ library import: warnings exposed-modules: Library.Types Library.Types.Communication + Library.Types.Map Library.Types.Player build-depends: base ^>=4.17.2.1 , aeson @@ -44,6 +45,7 @@ executable wizard-wipeout-client , mtl , network , optparse-applicative + , stm , uuid , vector , vty