diff options
| author | Jasper Van der Jeugt | 2020-08-06 20:09:14 +0200 |
|---|---|---|
| committer | Jasper Van der Jeugt | 2020-08-06 20:09:14 +0200 |
| commit | b8a5f115793a9f1b39c236e0862ead27b76cc92a (patch) | |
| tree | 24ee04384d215aefda5a0e5f458dc7a553b16c3f /server | |
| parent | f57f7ff6ca1441cfabb921bdf7267012bae3b172 (diff) | |
Skipping rounds
Diffstat (limited to 'server')
| -rw-r--r-- | server/lib/Cafp/Game.hs | 32 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 4 |
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 |