From b8a5f115793a9f1b39c236e0862ead27b76cc92a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 6 Aug 2020 20:09:14 +0200 Subject: Skipping rounds --- client/src/Client.elm | 34 ++++++++++++++++++++++++++-------- client/src/Messages.elm | 12 +++++++++--- server/lib/Cafp/Game.hs | 32 +++++++++++++++++++++----------- server/lib/Cafp/Messages.hs | 4 +++- 4 files changed, 59 insertions(+), 23 deletions(-) diff --git a/client/src/Client.elm b/client/src/Client.elm index fd4663e..840e9b6 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -23,11 +23,13 @@ type Msg -- Card selection | SelectWhiteCard WhiteCard | ProposeWhiteCards + | AdminSkipProposals -- Voting | SelectVote Int | SubmitVote + | AdminSkipVotes -- Tally - | ConfirmTally + | AdminConfirmTally type alias Cards = {black : Array String, white : Array String} @@ -159,7 +161,12 @@ viewTable game = case game.view.table of , Html.Events.onClick ProposeWhiteCards ] [Html.text "Propose"] - ] + ] ++ + ifAdmin game.view + [ Html.button + [Html.Events.onClick AdminSkipProposals] + [Html.text "Skip remaining players"] + ] Messages.Voting black proposals myProposal myVote -> Html.div [] <| [Html.p [] [Html.text <| "Vote for the funniest combination"]] ++ List.indexedMap (\i proposal -> @@ -183,7 +190,12 @@ viewTable game = case game.view.table of , Html.Events.onClick SubmitVote ] [Html.text "Vote"] - ] + ] ++ + ifAdmin game.view + [ Html.button + [Html.Events.onClick AdminSkipVotes] + [Html.text "Skip remaining players"] + ] Messages.Tally black results -> Html.div [] <| [Html.p [] [Html.text "Vote results"]] ++ @@ -201,13 +213,15 @@ viewTable game = case game.view.table of ] ]) results ++ - if not game.view.me.admin then - [] - else + ifAdmin game.view [ Html.button - [Html.Events.onClick ConfirmTally] [Html.text "Next round"] + [Html.Events.onClick AdminConfirmTally] + [Html.text "Next round"] ] +ifAdmin : GameView -> List (Html a) -> List (Html a) +ifAdmin gameView html = if gameView.me.admin then html else [] + intersperseWith : List a -> a -> List a -> List a intersperseWith values def list = case list of [] -> [] @@ -326,6 +340,8 @@ update msg model = case msg of ) _ -> (model, Cmd.none) + AdminSkipProposals -> (model, send Messages.AdminSkipProposals) + SelectVote i -> case model of Game game -> case game.view.table of Messages.Voting _ _ _ Nothing -> @@ -333,6 +349,8 @@ update msg model = case msg of _ -> (model, Cmd.none) _ -> (model, Cmd.none) + AdminSkipVotes -> (model, send Messages.AdminSkipVotes) + SubmitVote -> case model of Game game -> case game.selectedVote of Just vote -> @@ -342,7 +360,7 @@ update msg model = case msg of _ -> (model, Cmd.none) _ -> (model, Cmd.none) - ConfirmTally -> (model, send <| Messages.ConfirmTally) + AdminConfirmTally -> (model, send Messages.AdminConfirmTally) main : Program () Model Msg main = Browser.application diff --git a/client/src/Messages.elm b/client/src/Messages.elm index fb244f9..02d2a37 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -183,7 +183,9 @@ type ClientMessage = ChangeMyName String | ProposeWhiteCards (List WhiteCard) | SubmitVote Int - | ConfirmTally + | AdminSkipProposals + | AdminSkipVotes + | AdminConfirmTally jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage ) jsonDecClientMessage = @@ -191,7 +193,9 @@ 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)) + , ("AdminSkipProposals", Json.Decode.lazy (\_ -> Json.Decode.succeed AdminSkipProposals)) + , ("AdminSkipVotes", Json.Decode.lazy (\_ -> Json.Decode.succeed AdminSkipVotes)) + , ("AdminConfirmTally", Json.Decode.lazy (\_ -> Json.Decode.succeed AdminConfirmTally)) ] in decodeSumObjectWithSingleField "ClientMessage" jsonDecDictClientMessage @@ -201,7 +205,9 @@ 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 [])) + AdminSkipProposals -> ("AdminSkipProposals", encodeValue (Json.Encode.list identity [])) + AdminSkipVotes -> ("AdminSkipVotes", encodeValue (Json.Encode.list identity [])) + AdminConfirmTally -> ("AdminConfirmTally", encodeValue (Json.Encode.list identity [])) in encodeSumObjectWithSingleField keyval val diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 2df1ee5..9ed3cc1 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -206,11 +206,11 @@ votedMessages cards (BlackCard black) voteds = do | WhiteCard i <- V.toList $ votedProposal voted ] -stepGame :: Game -> Game -stepGame game = case game ^. gameTable of +stepGame :: Bool -> Game -> Game +stepGame skip game = case game ^. gameTable of TableProposing black proposals -- Everyone has proposed. - | iall (\pid _ -> HMS.member pid proposals) (game ^. gamePlayers) -> + | skip || iall (const . (`HMS.member` proposals)) (game ^. gamePlayers) -> let proposalsMap = HMS.fromListWith (++) $ do (pid, proposal) <- HMS.toList proposals pure (proposal, [pid]) @@ -218,7 +218,7 @@ stepGame game = case game ^. gameTable of (V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in -- There's a recursive call because in some one-player cases we -- skip the voting process entirely. - stepGame $ game + stepGame False $ game & gameSeed .~ seed & gameTable .~ TableVoting black shuffled HMS.empty & gamePlayers %~ imap (\pid player -> @@ -228,7 +228,7 @@ stepGame game = case game ^. gameTable of TableVoting black shuffled votes -- Everyone has voted. - | iall hasVoted (game ^. gamePlayers) -> + | skip || iall hasVoted (game ^. gamePlayers) -> let (voted, wins) = tallyVotes game shuffled votes in flip execState game $ do for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1 @@ -259,7 +259,7 @@ processClientMessage pid msg game = case msg of | Just b <- game ^? gameTable . _TableProposing . _1 , blackCardBlanks (game ^. gameCards) b /= length cs -> game -- All good. - | otherwise -> stepGame $ + | otherwise -> stepGame False $ game & gameTable . _TableProposing . _2 . at pid .~ Just cs SubmitVote i -> case game ^. gameTable of @@ -273,19 +273,29 @@ processClientMessage pid msg game = case msg of -- Can't vote for self. | pid `elem` snd (shuffled V.! i) -> game -- Ok vote. - | otherwise -> stepGame $ game + | otherwise -> stepGame False $ game & gameTable . _TableVoting . _3 . at pid .~ Just i - ConfirmTally - | TableTally _ _ <- game ^. gameTable - , Just True <- game ^? gamePlayers . ix pid . playerAdmin -> + AdminConfirmTally + | TableTally _ _ <- game ^. gameTable, admin -> flip execState game $ do black <- popBlackCard gameTable .= TableProposing black HMS.empty modify drawNewWhiteCards | otherwise -> game + + AdminSkipProposals + | TableProposing _ _ <- game ^. gameTable, admin -> stepGame True $ + game & gameLog %~ ("Admin skipped proposals" :) + | otherwise -> game + + AdminSkipVotes + | TableVoting _ _ _ <- game ^. gameTable, admin -> stepGame True $ + game & gameLog %~ ("Admin skipped votes" :) + | otherwise -> game where - hand = game ^.. gamePlayers . ix pid . playerHand . traverse + hand = game ^.. gamePlayers . ix pid . playerHand . traverse + admin = fromMaybe False $ game ^? gamePlayers . ix pid . playerAdmin gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index a02058f..5066447 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -71,7 +71,9 @@ data ClientMessage = ChangeMyName !Text | ProposeWhiteCards !(Vector WhiteCard) | SubmitVote !Int - | ConfirmTally + | AdminSkipProposals + | AdminSkipVotes + | AdminConfirmTally deriving (Show) deriveBoth defaultOptions ''BlackCard -- cgit v1.2.3