aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-07-31 13:35:17 +0200
committerJasper Van der Jeugt2020-07-31 13:35:17 +0200
commit323ca81c96e4186747f06b6178d71d49e98c6066 (patch)
tree3d52febe85476fe31d64371e8335539c06ec83b3
parent88e5fd7b4701fcfc9dd355208435a37bf129a92f (diff)
Sync opponent proposals
-rw-r--r--client/src/Client.elm8
-rw-r--r--client/src/Messages.elm26
-rw-r--r--server/lib/Cafp/Game.hs10
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs1
-rw-r--r--server/lib/Cafp/Messages.hs9
5 files changed, 47 insertions, 7 deletions
diff --git a/client/src/Client.elm b/client/src/Client.elm
index 94e33cf..178e406 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -45,6 +45,12 @@ parseRoomId url = case String.split "/" url.path of
_ :: "rooms" :: roomId :: _ -> Ok roomId
_ -> Err <| "Invalid path: " ++ url.path
+viewOpponent : Messages.Opponent -> Html msg
+viewOpponent opponent = Html.div [] <|
+ [ Html.text opponent.name
+ ] ++
+ if opponent.ready then [Html.text " ✅"] else []
+
view : Model -> List (Html Msg)
view model = case model of
Error str ->
@@ -58,7 +64,7 @@ view model = case model of
Game game ->
[ Html.h1 [] [Html.text "Opponents"]
, Html.ul [] <| List.map
- (\p -> Html.li [] [Html.text p])
+ (\o -> Html.li [] [viewOpponent o])
game.view.opponents
, Html.h1 [] [Html.text "You"]
, Html.form
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 1188525..b38fbd5 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -56,6 +56,26 @@ jsonEncCards val =
+type alias Opponent =
+ { name: String
+ , ready: Bool
+ }
+
+jsonDecOpponent : Json.Decode.Decoder ( Opponent )
+jsonDecOpponent =
+ Json.Decode.succeed (\pname pready -> {name = pname, ready = pready})
+ |> required "name" (Json.Decode.string)
+ |> required "ready" (Json.Decode.bool)
+
+jsonEncOpponent : Opponent -> Value
+jsonEncOpponent val =
+ Json.Encode.object
+ [ ("name", Json.Encode.string val.name)
+ , ("ready", Json.Encode.bool val.ready)
+ ]
+
+
+
type TableView =
Proposing BlackCard (Maybe WhiteCard)
@@ -71,7 +91,7 @@ jsonEncTableView (Proposing v1 v2) =
type alias GameView =
- { opponents: (List String)
+ { opponents: (List Opponent)
, myName: String
, table: TableView
, hand: (List WhiteCard)
@@ -80,7 +100,7 @@ type alias GameView =
jsonDecGameView : Json.Decode.Decoder ( GameView )
jsonDecGameView =
Json.Decode.succeed (\popponents pmyName ptable phand -> {opponents = popponents, myName = pmyName, table = ptable, hand = phand})
- |> required "opponents" (Json.Decode.list (Json.Decode.string))
+ |> required "opponents" (Json.Decode.list (jsonDecOpponent))
|> required "myName" (Json.Decode.string)
|> required "table" (jsonDecTableView)
|> required "hand" (Json.Decode.list (jsonDecWhiteCard))
@@ -88,7 +108,7 @@ jsonDecGameView =
jsonEncGameView : GameView -> Value
jsonEncGameView val =
Json.Encode.object
- [ ("opponents", (Json.Encode.list Json.Encode.string) val.opponents)
+ [ ("opponents", (Json.Encode.list jsonEncOpponent) val.opponents)
, ("myName", Json.Encode.string val.myName)
, ("table", jsonEncTableView val.table)
, ("hand", (Json.Encode.list jsonEncWhiteCard) val.hand)
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index 336b85c..9c2d2e4 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -20,6 +20,7 @@ import Cafp.Messages
import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.),
(^?), _2)
import Control.Lens.TH (makeLenses, makePrisms)
+import Control.Monad (guard)
import qualified Data.HashMap.Strict as HMS
import Data.Maybe (fromMaybe)
import Data.Text (Text)
@@ -73,14 +74,19 @@ processClientMessage pid msg game = case msg of
-- Bad card proposed.
| not $ validWhiteCard (game ^. gameCards) c -> game
-- Proposal already made.
- | Just _ <- game ^? gameTable . _TableProposing . _2 . at pid -> game
+ | Just _ <- game ^? gameTable . _TableProposing . _2 . ix 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 =
- let opponents = map snd . HMS.toList . HMS.delete self $ game ^. gamePlayers
+ let opponents = do
+ (pid, oname) <- HMS.toList $ game ^. gamePlayers
+ guard $ pid /= self
+ pure $ Opponent oname $ case game ^. gameTable of
+ TableProposing _ proposals -> HMS.member pid proposals
+
name = fromMaybe "" $ game ^. gamePlayers . at self
table = case game ^. gameTable of
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 677bc5c..b1e6efe 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -13,6 +13,7 @@ main = putStrLn $ makeElmModule "Messages"
[ DefineElm (Proxy :: Proxy BlackCard)
, DefineElm (Proxy :: Proxy WhiteCard)
, DefineElm (Proxy :: Proxy Cards)
+ , DefineElm (Proxy :: Proxy Opponent)
, DefineElm (Proxy :: Proxy TableView)
, DefineElm (Proxy :: Proxy GameView)
, DefineElm (Proxy :: Proxy ServerMessage)
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index ff3f612..dc17168 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -3,6 +3,7 @@ module Cafp.Messages
( BlackCard (..)
, WhiteCard (..)
, Cards (..)
+ , Opponent (..)
, TableView (..)
, GameView (..)
, ServerMessage (..)
@@ -22,12 +23,17 @@ data Cards = Cards
, cardsWhite :: Vector Text
} deriving (Show)
+data Opponent = Opponent
+ { opponentName :: Text
+ , opponentReady :: Bool
+ } deriving (Show)
+
data TableView
= Proposing BlackCard (Maybe WhiteCard)
deriving (Show)
data GameView = GameView
- { gameViewOpponents :: [Text]
+ { gameViewOpponents :: [Opponent]
, gameViewMyName :: Text
, gameViewTable :: TableView
, gameViewHand :: [WhiteCard]
@@ -48,6 +54,7 @@ data ClientMessage
deriveBoth defaultOptions ''BlackCard
deriveBoth defaultOptions ''WhiteCard
deriveBoth (defaultOptionsDropLower 5) ''Cards
+deriveBoth (defaultOptionsDropLower 8) ''Opponent
deriveBoth defaultOptions ''TableView
deriveBoth (defaultOptionsDropLower 8) ''GameView
deriveBoth defaultOptions ''ServerMessage