aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-08-06 20:09:14 +0200
committerJasper Van der Jeugt2020-08-06 20:09:14 +0200
commitb8a5f115793a9f1b39c236e0862ead27b76cc92a (patch)
tree24ee04384d215aefda5a0e5f458dc7a553b16c3f /server
parentf57f7ff6ca1441cfabb921bdf7267012bae3b172 (diff)
Skipping rounds
Diffstat (limited to '')
-rw-r--r--server/lib/Cafp/Game.hs32
-rw-r--r--server/lib/Cafp/Messages.hs4
2 files changed, 24 insertions, 12 deletions
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