aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/src/Client.elm34
-rw-r--r--client/src/Messages.elm12
-rw-r--r--server/lib/Cafp/Game.hs32
-rw-r--r--server/lib/Cafp/Messages.hs4
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 17:47:59 +0000