From 88e5fd7b4701fcfc9dd355208435a37bf129a92f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Jul 2020 13:06:38 +0200 Subject: Send proposals to server --- client/src/Client.elm | 23 +++++++++++++++++++++-- client/src/Messages.elm | 15 +++++++++++---- server/lib/Cafp/Game.hs | 18 ++++++++++++++++-- server/lib/Cafp/Main/Server.hs | 3 ++- server/lib/Cafp/Messages.hs | 8 +++++--- 5 files changed, 55 insertions(+), 12 deletions(-) diff --git a/client/src/Client.elm b/client/src/Client.elm index ea1a737..94e33cf 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -22,6 +22,7 @@ type Msg | SubmitMyName -- Card selection | SelectWhiteCard WhiteCard + | ProposeWhiteCards type alias Cards = {black : Array String, white : Array String} @@ -74,7 +75,7 @@ view model = case model of , Html.Attributes.disabled <| game.view.myName == game.changeMyName ] - [Html.text "change"] + [Html.text "Update name"] ] ] ++ [viewTable game] ++ @@ -96,6 +97,15 @@ viewTable game = case game.view.table of [ blackCard game.cards c <| case selectedWhiteCard game of Nothing -> [] Just wc -> [wc] + , Html.button + [ Html.Attributes.disabled <| case my of + Just _ -> True + _ -> case selectedWhiteCard game of + Nothing -> True + Just _ -> False + , Html.Events.onClick ProposeWhiteCards + ] + [Html.text "Propose"] ] intersperseWith : List a -> a -> List a -> List a @@ -174,13 +184,22 @@ update msg model = case msg of Game game -> (Game {game | changeMyName = name}, Cmd.none) _ -> (model, Cmd.none) SubmitMyName -> case model of - Game game -> (model , send <| Messages.ChangeMyName game.changeMyName) + Game game -> (model, send <| Messages.ChangeMyName game.changeMyName) _ -> (model, Cmd.none) SelectWhiteCard card -> case model of Game game -> (Game {game | selectedWhiteCard = Just card}, Cmd.none) _ -> (model, Cmd.none) + ProposeWhiteCards -> case model of + Game game -> + ( Game {game | selectedWhiteCard = Nothing} + , case game.selectedWhiteCard of + Nothing -> Cmd.none + Just c -> send <| Messages.ProposeWhiteCards c + ) + _ -> (model, Cmd.none) + main : Program () Model Msg main = Browser.application { init = \() url key -> case parseRoomId url of diff --git a/client/src/Messages.elm b/client/src/Messages.elm index 69d0eff..1188525 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -125,14 +125,21 @@ jsonEncServerMessage val = type ClientMessage = ChangeMyName String + | ProposeWhiteCards WhiteCard jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage ) jsonDecClientMessage = - Json.Decode.lazy (\_ -> Json.Decode.map ChangeMyName (Json.Decode.string)) - + let jsonDecDictClientMessage = Dict.fromList + [ ("ChangeMyName", Json.Decode.lazy (\_ -> Json.Decode.map ChangeMyName (Json.Decode.string))) + , ("ProposeWhiteCards", Json.Decode.lazy (\_ -> Json.Decode.map ProposeWhiteCards (jsonDecWhiteCard))) + ] + in decodeSumObjectWithSingleField "ClientMessage" jsonDecDictClientMessage jsonEncClientMessage : ClientMessage -> Value -jsonEncClientMessage (ChangeMyName v1) = - Json.Encode.string v1 +jsonEncClientMessage val = + let keyval v = case v of + ChangeMyName v1 -> ("ChangeMyName", encodeValue (Json.Encode.string v1)) + ProposeWhiteCards v1 -> ("ProposeWhiteCards", encodeValue (jsonEncWhiteCard v1)) + in encodeSumObjectWithSingleField keyval val diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 3a67ef6..336b85c 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -18,12 +18,13 @@ module Cafp.Game import Cafp.Messages import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), - (^?)) -import Control.Lens.TH (makeLenses) + (^?), _2) +import Control.Lens.TH (makeLenses, makePrisms) import qualified Data.HashMap.Strict as HMS import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Vector as V type PlayerId = Int @@ -38,6 +39,7 @@ data Game = Game , _gameNextPlayerId :: !Int } deriving (Show) +makePrisms ''Table makeLenses ''Game newGame :: Cards -> Game @@ -59,10 +61,22 @@ joinGame game = leaveGame :: PlayerId -> Game -> Game leaveGame pid = over gamePlayers $ HMS.delete pid +validWhiteCard :: Cards -> WhiteCard -> Bool +validWhiteCard cards (WhiteCard c) = + let len = V.length $ cardsWhite cards in c >= 0 && c < len + processClientMessage :: PlayerId -> ClientMessage -> Game -> Game processClientMessage pid msg game = case msg of ChangeMyName name -> game & gamePlayers . ix pid .~ name + ProposeWhiteCards c + -- Bad card proposed. + | not $ validWhiteCard (game ^. gameCards) c -> game + -- Proposal already made. + | Just _ <- game ^? gameTable . _TableProposing . _2 . at pid -> game + -- TODO: Check that the card is in the hand of the player. + | otherwise -> + game & gameTable . _TableProposing . _2 . at pid .~ Just c gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index e6e353f..13b1f6b 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -22,6 +22,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Vector as V +import qualified Data.Vector as V import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs @@ -51,7 +52,7 @@ readCards = Cards <$> fmap parseCards (T.readFile "assets/black.txt") <*> fmap parseCards (T.readFile "assets/white.txt") where - parseCards = + parseCards = V.fromList . filter (not . T.isPrefixOf "#") . filter (not . T.null) . T.lines newServer :: IO Server diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index de0ae26..ff3f612 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -9,7 +9,8 @@ module Cafp.Messages , ClientMessage (..) ) where -import Data.Text (Text) +import Data.Text (Text) +import Data.Vector (Vector) import Elm.Derive data BlackCard = BlackCard Int deriving (Show) @@ -17,8 +18,8 @@ data BlackCard = BlackCard Int deriving (Show) data WhiteCard = WhiteCard Int deriving (Show) data Cards = Cards - { cardsBlack :: [Text] - , cardsWhite :: [Text] + { cardsBlack :: Vector Text + , cardsWhite :: Vector Text } deriving (Show) data TableView @@ -41,6 +42,7 @@ data ServerMessage data ClientMessage = ChangeMyName Text + | ProposeWhiteCards WhiteCard -- TODO: Needs to be a list? deriving (Show) deriveBoth defaultOptions ''BlackCard -- cgit v1.2.3