diff options
| -rw-r--r-- | client/src/Client.elm | 8 | ||||
| -rw-r--r-- | client/src/Messages.elm | 26 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 10 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/GenerateElmTypes.hs | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 9 |
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 |