From f2683ace66da18c374166ad35a920ed0b27b5663 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 3 Aug 2020 15:37:00 +0200 Subject: Full game flow --- client/src/Client.elm | 43 +++++++-- client/src/Messages.elm | 58 +++++++++--- client/style.css | 4 + server/cafp.cabal | 2 + server/lib/Cafp/Game.hs | 151 +++++++++++++++++++++++-------- server/lib/Cafp/Main/GenerateElmTypes.hs | 3 +- server/lib/Cafp/Messages.hs | 57 +++++++----- 7 files changed, 231 insertions(+), 87 deletions(-) diff --git a/client/src/Client.elm b/client/src/Client.elm index e3ecbf6..7cac663 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -26,6 +26,8 @@ type Msg -- Voting | SelectVote Int | SubmitVote + -- Tally + | ConfirmTally type alias Cards = {black : Array String, white : Array String} @@ -49,12 +51,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 +viewPlayer : Messages.PlayerView -> Html msg +viewPlayer player = Html.div [] <| + [ Html.text player.name ] ++ - (if opponent.admin then [Html.text " 👑"] else []) ++ - (if opponent.ready then [Html.text " ✅"] else []) + (if player.admin then [Html.text " 👑"] else []) ++ + (if player.ready then [Html.text " ✅"] else []) view : Model -> List (Html Msg) view model = case model of @@ -67,10 +69,10 @@ view model = case model of [Html.text <| "Connecting to room " ++ state.roomId ++ "..."] ] Game game -> - [ Html.h1 [] [Html.text "Opponents"] + [ Html.h1 [] [Html.text "Players"] , Html.ul [] <| List.map - (\o -> Html.li [] [viewOpponent o]) - game.view.opponents + (\o -> Html.li [] [viewPlayer o]) + game.view.players , Html.h1 [] [Html.text "You"] , Html.form [ Html.Attributes.action "" @@ -84,7 +86,8 @@ view model = case model of , Html.button [ Html.Attributes.type_ "submit" , Html.Attributes.disabled <| - game.view.myName == game.changeMyName + game.view.me.name == game.changeMyName || + String.length game.changeMyName > 32 ] [Html.text "Update name"] ] @@ -100,6 +103,7 @@ tableBlackCard : GameState -> Maybe BlackCard tableBlackCard game = case game.view.table of Messages.Proposing b _ -> Just b Messages.Voting b _ _ _ -> Just b + Messages.Tally b _ -> Just b selectedWhiteCards : GameState -> List WhiteCard selectedWhiteCards game = case game.view.table of @@ -148,6 +152,23 @@ viewTable game = case game.view.table of [Html.text "Vote"] ] + Messages.Tally black results -> Html.div [] <| + [Html.h2 [] [Html.text "Vote results"]] ++ + List.map (\voted -> + let attrs = + if List.length voted.winners > 0 then + [Html.Attributes.class "winner"] + else + [] in + blackCard attrs game.cards black voted.proposal) + results ++ + if not game.view.me.admin then + [] + else + [ Html.button + [Html.Events.onClick ConfirmTally] [Html.text "Next round"] + ] + intersperseWith : List a -> a -> List a -> List a intersperseWith values def list = case list of [] -> [] @@ -222,7 +243,7 @@ update msg model = case msg of ( Game { cards = {black = Array.empty, white = Array.empty} , view = gameView - , changeMyName = gameView.myName + , changeMyName = gameView.me.name , selectedWhiteCards = [] , selectedVote = Nothing } @@ -280,6 +301,8 @@ update msg model = case msg of _ -> (model, Cmd.none) _ -> (model, Cmd.none) + ConfirmTally -> (model, send <| Messages.ConfirmTally) + 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 3324886..a100dbf 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -56,25 +56,51 @@ jsonEncCards val = -type alias Opponent = +type alias PlayerView = { name: String , admin: Bool , ready: Bool + , points: Int } -jsonDecOpponent : Json.Decode.Decoder ( Opponent ) -jsonDecOpponent = - Json.Decode.succeed (\pname padmin pready -> {name = pname, admin = padmin, ready = pready}) +jsonDecPlayerView : Json.Decode.Decoder ( PlayerView ) +jsonDecPlayerView = + Json.Decode.succeed (\pname padmin pready ppoints -> {name = pname, admin = padmin, ready = pready, points = ppoints}) |> required "name" (Json.Decode.string) |> required "admin" (Json.Decode.bool) |> required "ready" (Json.Decode.bool) + |> required "points" (Json.Decode.int) -jsonEncOpponent : Opponent -> Value -jsonEncOpponent val = +jsonEncPlayerView : PlayerView -> Value +jsonEncPlayerView val = Json.Encode.object [ ("name", Json.Encode.string val.name) , ("admin", Json.Encode.bool val.admin) , ("ready", Json.Encode.bool val.ready) + , ("points", Json.Encode.int val.points) + ] + + + +type alias VotedView = + { proposal: (List WhiteCard) + , score: Int + , winners: (List String) + } + +jsonDecVotedView : Json.Decode.Decoder ( VotedView ) +jsonDecVotedView = + Json.Decode.succeed (\pproposal pscore pwinners -> {proposal = pproposal, score = pscore, winners = pwinners}) + |> required "proposal" (Json.Decode.list (jsonDecWhiteCard)) + |> required "score" (Json.Decode.int) + |> required "winners" (Json.Decode.list (Json.Decode.string)) + +jsonEncVotedView : VotedView -> Value +jsonEncVotedView val = + Json.Encode.object + [ ("proposal", (Json.Encode.list jsonEncWhiteCard) val.proposal) + , ("score", Json.Encode.int val.score) + , ("winners", (Json.Encode.list Json.Encode.string) val.winners) ] @@ -82,12 +108,14 @@ jsonEncOpponent val = type TableView = Proposing BlackCard (List WhiteCard) | Voting BlackCard (List (List WhiteCard)) Int (Maybe Int) + | Tally BlackCard (List VotedView) jsonDecTableView : Json.Decode.Decoder ( TableView ) jsonDecTableView = let jsonDecDictTableView = Dict.fromList [ ("Proposing", Json.Decode.lazy (\_ -> Json.Decode.map2 Proposing (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (jsonDecWhiteCard))))) , ("Voting", Json.Decode.lazy (\_ -> Json.Decode.map4 Voting (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (Json.Decode.list (jsonDecWhiteCard)))) (Json.Decode.index 2 (Json.Decode.int)) (Json.Decode.index 3 (Json.Decode.maybe (Json.Decode.int))))) + , ("Tally", Json.Decode.lazy (\_ -> Json.Decode.map2 Tally (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (jsonDecVotedView))))) ] in decodeSumObjectWithSingleField "TableView" jsonDecDictTableView @@ -96,30 +124,31 @@ jsonEncTableView val = let keyval v = case v of Proposing v1 v2 -> ("Proposing", encodeValue (Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list jsonEncWhiteCard) v2])) Voting v1 v2 v3 v4 -> ("Voting", encodeValue (Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list (Json.Encode.list jsonEncWhiteCard)) v2, Json.Encode.int v3, (maybeEncode (Json.Encode.int)) v4])) + Tally v1 v2 -> ("Tally", encodeValue (Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list jsonEncVotedView) v2])) in encodeSumObjectWithSingleField keyval val type alias GameView = - { opponents: (List Opponent) - , myName: String + { players: (List PlayerView) + , me: PlayerView , table: TableView , hand: (List WhiteCard) } 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 (jsonDecOpponent)) - |> required "myName" (Json.Decode.string) + Json.Decode.succeed (\pplayers pme ptable phand -> {players = pplayers, me = pme, table = ptable, hand = phand}) + |> required "players" (Json.Decode.list (jsonDecPlayerView)) + |> required "me" (jsonDecPlayerView) |> required "table" (jsonDecTableView) |> required "hand" (Json.Decode.list (jsonDecWhiteCard)) jsonEncGameView : GameView -> Value jsonEncGameView val = Json.Encode.object - [ ("opponents", (Json.Encode.list jsonEncOpponent) val.opponents) - , ("myName", Json.Encode.string val.myName) + [ ("players", (Json.Encode.list jsonEncPlayerView) val.players) + , ("me", jsonEncPlayerView val.me) , ("table", jsonEncTableView val.table) , ("hand", (Json.Encode.list jsonEncWhiteCard) val.hand) ] @@ -157,6 +186,7 @@ type ClientMessage = ChangeMyName String | ProposeWhiteCards (List WhiteCard) | SubmitVote Int + | ConfirmTally jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage ) jsonDecClientMessage = @@ -164,6 +194,7 @@ jsonDecClientMessage = [ ("ChangeMyName", Json.Decode.lazy (\_ -> Json.Decode.map ChangeMyName (Json.Decode.string))) , ("ProposeWhiteCards", Json.Decode.lazy (\_ -> Json.Decode.map ProposeWhiteCards (Json.Decode.list (jsonDecWhiteCard)))) , ("SubmitVote", Json.Decode.lazy (\_ -> Json.Decode.map SubmitVote (Json.Decode.int))) + , ("ConfirmTally", Json.Decode.lazy (\_ -> Json.Decode.succeed ConfirmTally)) ] in decodeSumObjectWithSingleField "ClientMessage" jsonDecDictClientMessage @@ -173,6 +204,7 @@ jsonEncClientMessage val = ChangeMyName v1 -> ("ChangeMyName", encodeValue (Json.Encode.string v1)) ProposeWhiteCards v1 -> ("ProposeWhiteCards", encodeValue ((Json.Encode.list jsonEncWhiteCard) v1)) SubmitVote v1 -> ("SubmitVote", encodeValue (Json.Encode.int v1)) + ConfirmTally -> ("ConfirmTally", encodeValue (Json.Encode.list identity [])) in encodeSumObjectWithSingleField keyval val diff --git a/client/style.css b/client/style.css index 4a134c6..e3824b6 100644 --- a/client/style.css +++ b/client/style.css @@ -25,6 +25,10 @@ html { background: #003300; } +.winner { + background: #701e58; +} + .white { color: black; background: white; diff --git a/server/cafp.cabal b/server/cafp.cabal index 14ef7ad..f80184c 100644 --- a/server/cafp.cabal +++ b/server/cafp.cabal @@ -35,6 +35,8 @@ Library text >= 1.2 && < 1.3, unordered-containers >= 0.2 && < 0.3, vector >= 0.12 && < 0.13, + vector-algorithms >= 0.8 && < 0.9, + vector-instances >= 3.4 && < 3.5, vector-shuffling >= 1.1 && < 1.2, wai >= 3.2 && < 3.3, wai-websockets >= 3.0 && < 3.1, diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 14228fd..379b3a5 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} @@ -19,26 +20,31 @@ module Cafp.Game ) where import Cafp.Messages -import Control.Lens (Lens', at, ix, orOf, over, to, - (%%=), (%=), (&), (.=), (.~), (^.), - (^..), (^?), _1, _2, _3) -import Control.Lens.TH (makeLenses, makePrisms) -import Control.Monad (guard) -import Control.Monad.State (State, execState, modify, runState, - state) -import Data.Bifunctor (first) -import qualified Data.HashMap.Strict as HMS -import Data.List (sort) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V -import System.Random (StdGen) -import VectorShuffling.Immutable (shuffle) +import Control.Lens (Lens', at, imap, ix, orOf, over, + to, (%%=), (%=), (&), (+=), (.=), + (.~), (^.), (^..), (^?), _1, _2, + _3) +import Control.Lens.TH (makeLenses, makePrisms) +import Control.Monad (guard) +import Data.Ord (comparing, Down (..)) +import Control.Monad.State (State, execState, modify, + runState, state) +import Data.Bifunctor (first) +import Data.Foldable (for_) +import qualified Data.HashMap.Strict as HMS +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Merge as V +import Data.Vector.Instances () +import System.Random (StdGen) +import VectorShuffling.Immutable (shuffle) type PlayerId = Int -type Proposal = [WhiteCard] +type Proposal = V.Vector WhiteCard data Table = TableProposing @@ -48,12 +54,16 @@ data Table !BlackCard !(V.Vector (Proposal, [PlayerId])) !(HMS.HashMap PlayerId Int) + | TableTally + !BlackCard + !(V.Vector VotedView) deriving (Show) data Player = Player - { _playerName :: !Text - , _playerHand :: !(V.Vector WhiteCard) - , _playerAdmin :: !Bool + { _playerName :: !Text + , _playerHand :: !(V.Vector WhiteCard) + , _playerAdmin :: !Bool + , _playerPoints :: !Int } deriving (Show) data Game = Game @@ -119,7 +129,7 @@ joinGame = runState $ do pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) let name = "Player " <> T.pack (show pid) hand <- V.replicateM 6 popWhiteCard - gamePlayers %= HMS.insert pid (Player name hand False) + gamePlayers %= HMS.insert pid (Player name hand False 0) modify assignAdmin pure pid @@ -130,9 +140,44 @@ blackCardBlanks :: Cards -> BlackCard -> Int blackCardBlanks cards (BlackCard c) = maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c +maximaOn :: Ord o => (a -> o) -> [a] -> [a] +maximaOn f = \case [] -> []; x : xs -> go [x] (f x) xs + where + go best _ [] = reverse best + go best bestScore (x : xs) = + let score = f x in + case compare score bestScore of + LT -> go best bestScore xs + EQ -> go (x : best) bestScore xs + GT -> go [x] score xs + +tallyVotes + :: Game + -> (V.Vector (Proposal, [PlayerId])) + -> (HMS.HashMap PlayerId Int) + -> (V.Vector VotedView, [PlayerId]) +tallyVotes game shuffled votes = + let counts :: HMS.HashMap Int Int -- Index, votes received. + counts = HMS.fromListWith (+) [(idx, 1) | (_, idx) <- HMS.toList votes] + best = map fst . maximaOn snd $ HMS.toList counts in + ( byScore $ V.imap (\i (proposal, players) -> VotedView + { votedProposal = proposal + , votedScore = fromMaybe 0 $ HMS.lookup i counts + , votedWinners = V.fromList $ do + guard $ i `elem` best + p <- players + game ^.. gamePlayers . ix p . playerName + }) + shuffled + , [player | idx <- best, player <- snd $ shuffled V.! idx] + ) + where + byScore = V.modify $ V.sortBy . comparing $ Down . votedScore + stepGame :: Game -> Game stepGame game = case game ^. gameTable of TableProposing black proposals + -- Everyone has proposed. | HMS.null ((game ^. gamePlayers) `HMS.difference` proposals) -> let proposalsMap = HMS.fromListWith (++) $ do (pid, proposal) <- HMS.toList proposals @@ -142,12 +187,22 @@ stepGame game = case game ^. gameTable of game & gameSeed .~ seed & gameTable .~ TableVoting black shuffled HMS.empty | otherwise -> game - TableVoting _ _ _ -> game + TableVoting black shuffled votes + -- Everyone has voted. + | HMS.null ((game ^. gamePlayers) `HMS.difference` votes) -> + let (voted, wins) = tallyVotes game shuffled votes in + flip execState game $ do + for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1 + gameTable .= TableTally black voted + | otherwise -> game + TableTally _ _ -> game processClientMessage :: PlayerId -> ClientMessage -> Game -> Game processClientMessage pid msg game = case msg of - ChangeMyName name -> - game & gamePlayers . ix pid . playerName .~ name + ChangeMyName name + | T.length name > 32 -> game + | otherwise -> game & gamePlayers . ix pid . playerName .~ name + ProposeWhiteCards cs -- Bad card(s) proposed, i.e. not in hand of player. | any (not . (`elem` hand)) cs -> game @@ -162,6 +217,7 @@ processClientMessage pid msg game = case msg of SubmitVote i -> case game ^. gameTable of TableProposing _ _ -> game + TableTally _ _ -> game TableVoting _ shuffled votes -- Vote out of bounds. | i < 0 || i >= V.length shuffled -> game @@ -172,32 +228,47 @@ processClientMessage pid msg game = case msg of -- Ok vote. | otherwise -> stepGame $ game & gameTable . _TableVoting . _3 . at pid .~ Just i + + ConfirmTally + | TableTally _ _ <- game ^. gameTable + , Just True <- game ^? gamePlayers . ix pid . playerAdmin -> + flip execState game $ do + black <- popBlackCard + gameTable .= TableProposing black HMS.empty + | otherwise -> game where hand = game ^.. gamePlayers . ix pid . playerHand . traverse gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = - let opponents = do - (pid, p) <- HMS.toList $ game ^. gamePlayers - guard $ pid /= self - let ready = case game ^. gameTable of - TableProposing _ proposals -> HMS.member pid proposals - TableVoting _ _ votes -> HMS.member pid votes - pure $ Opponent (p ^. playerName) (p ^. playerAdmin) ready - - player = game ^. gamePlayers . at self + let playerView pid player = PlayerView + { playerViewName = player ^. playerName + , playerViewAdmin = player ^. playerAdmin + , playerViewReady = case game ^. gameTable of + TableProposing _ proposals -> HMS.member pid proposals + TableVoting _ _ votes -> HMS.member pid votes + TableTally _ _ -> False + , playerViewPoints = player ^. playerPoints + } table = case game ^. gameTable of TableProposing black proposals -> - Proposing black . fromMaybe [] $ HMS.lookup self proposals + Proposing black . fromMaybe V.empty $ HMS.lookup self proposals TableVoting black shuffled votes -> Voting black - (fst <$> V.toList shuffled) + (fst <$> shuffled) (fromMaybe 0 $ V.findIndex ((self `elem`) . snd) shuffled) - (HMS.lookup self votes) in + (HMS.lookup self votes) + TableTally black voted -> Tally black voted in GameView - { gameViewOpponents = opponents - , gameViewMyName = maybe "" (^. playerName) player - , gameViewTable = table - , gameViewHand = player ^.. traverse . playerHand . traverse + { gameViewPlayers = V.fromList . map snd . HMS.toList + . HMS.delete self . imap playerView $ game ^. gamePlayers + , gameViewMe = maybe dummy (playerView self) $ + game ^? gamePlayers . ix self + , gameViewTable = table + , gameViewHand = fromMaybe V.empty $ + game ^? gamePlayers . ix self . playerHand } + + where + dummy = PlayerView "" False False 0 diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs index b1e6efe..ccf19e8 100644 --- a/server/lib/Cafp/Main/GenerateElmTypes.hs +++ b/server/lib/Cafp/Main/GenerateElmTypes.hs @@ -13,7 +13,8 @@ main = putStrLn $ makeElmModule "Messages" [ DefineElm (Proxy :: Proxy BlackCard) , DefineElm (Proxy :: Proxy WhiteCard) , DefineElm (Proxy :: Proxy Cards) - , DefineElm (Proxy :: Proxy Opponent) + , DefineElm (Proxy :: Proxy PlayerView) + , DefineElm (Proxy :: Proxy VotedView) , 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 cfc8597..4e5123d 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -4,7 +4,8 @@ module Cafp.Messages ( BlackCard (..) , WhiteCard (..) , Cards (..) - , Opponent (..) + , PlayerView (..) + , VotedView (..) , TableView (..) , GameView (..) , ServerMessage (..) @@ -26,49 +27,59 @@ data WhiteCard = WhiteCard Int deriving (Eq, Generic, Show) instance Hashable WhiteCard data Cards = Cards - { cardsBlack :: Vector Text - , cardsWhite :: Vector Text + { cardsBlack :: !(Vector Text) + , cardsWhite :: !(Vector Text) } deriving (Show) -data Opponent = Opponent - { opponentName :: Text - , opponentAdmin :: Bool - , opponentReady :: Bool +data PlayerView = PlayerView + { playerViewName :: !Text + , playerViewAdmin :: !Bool + , playerViewReady :: !Bool + , playerViewPoints :: !Int + } deriving (Show) + +data VotedView = VotedView + { votedProposal :: !(Vector WhiteCard) + , votedScore :: !Int + , votedWinners :: !(Vector Text) } deriving (Show) data TableView - = Proposing BlackCard [WhiteCard] + = Proposing !BlackCard !(Vector WhiteCard) | Voting - BlackCard - [[WhiteCard]] -- ^ Proposals to vote for - Int -- ^ My proposal - (Maybe Int) -- ^ My vote + !BlackCard + !(Vector (Vector WhiteCard)) -- ^ Proposals to vote for + !Int -- ^ My proposal + !(Maybe Int) -- ^ My vote + | Tally !BlackCard !(Vector VotedView) deriving (Show) data GameView = GameView - { gameViewOpponents :: [Opponent] - , gameViewMyName :: Text - , gameViewTable :: TableView - , gameViewHand :: [WhiteCard] + { gameViewPlayers :: !(Vector PlayerView) + , gameViewMe :: !PlayerView + , gameViewTable :: !TableView + , gameViewHand :: !(Vector WhiteCard) } deriving (Show) data ServerMessage - = Welcome Int - | SyncCards Cards - | SyncGameView GameView + = Welcome !Int + | SyncCards !Cards + | SyncGameView !GameView | Bye deriving (Show) data ClientMessage - = ChangeMyName Text - | ProposeWhiteCards [WhiteCard] - | SubmitVote Int + = ChangeMyName !Text + | ProposeWhiteCards !(Vector WhiteCard) + | SubmitVote !Int + | ConfirmTally deriving (Show) deriveBoth defaultOptions ''BlackCard deriveBoth defaultOptions ''WhiteCard deriveBoth (defaultOptionsDropLower 5) ''Cards -deriveBoth (defaultOptionsDropLower 8) ''Opponent +deriveBoth (defaultOptionsDropLower 10) ''PlayerView +deriveBoth (defaultOptionsDropLower 5) ''VotedView deriveBoth defaultOptions ''TableView deriveBoth (defaultOptionsDropLower 8) ''GameView deriveBoth defaultOptions ''ServerMessage -- cgit v1.2.3