Skipping rounds

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