From 9b66d0821c3a948767b49dbf0908055cad4712f2 Mon Sep 17 00:00:00 2001 From: "Henry J. Wylde" Date: Wed, 17 Feb 2016 23:15:59 +1300 Subject: [PATCH] (#62) added the Scapegoat's ability to choose whom may vote on the next day when he is blamed --- CHANGELOG.md | 1 + app/Werewolf/Commands/Choose.hs | 16 +++- app/Werewolf/Commands/Help.hs | 5 +- app/Werewolf/Options.hs | 13 ++- src/Game/Werewolf/Command.hs | 39 ++++++-- src/Game/Werewolf/Engine.hs | 115 ++++++++++++++--------- src/Game/Werewolf/Game.hs | 57 ++++++----- src/Game/Werewolf/Response.hs | 29 +++++- src/Game/Werewolf/Role.hs | 11 ++- test/src/Game/Werewolf/Test/Arbitrary.hs | 68 +++++++++++--- test/src/Game/Werewolf/Test/Command.hs | 84 ++++++++++++++++- test/src/Game/Werewolf/Test/Engine.hs | 79 +++++++++++----- test/src/Game/Werewolf/Test/Game.hs | 31 ++++-- 13 files changed, 402 insertions(+), 146 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b809a93..9667371 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ *Minor* * Added the Village Idiot role. ([#41](https://github.com/hjwylde/werewolf/issues/41)) +* Added the Scapegoat's ability to choose whom may vote on the next day when he is blamed. ([#62](https://github.com/hjwylde/werewolf/issues/62)) *Revisions* diff --git a/app/Werewolf/Commands/Choose.hs b/app/Werewolf/Commands/Choose.hs index bfbce64..3ddfbcd 100644 --- a/app/Werewolf/Commands/Choose.hs +++ b/app/Werewolf/Commands/Choose.hs @@ -9,6 +9,8 @@ Maintainer : public@hjwylde.com Options and handler for the choose subcommand. -} +{-# LANGUAGE OverloadedStrings #-} + module Werewolf.Commands.Choose ( -- * Options Options(..), @@ -17,12 +19,14 @@ module Werewolf.Commands.Choose ( handle, ) where +import Control.Lens import Control.Monad.Except import Control.Monad.Extra import Control.Monad.State import Control.Monad.Writer -import Data.Text (Text) +import Data.Text (Text) +import qualified Data.Text as T import Game.Werewolf.Command import Game.Werewolf.Engine hiding (isWildChildsTurn) @@ -41,10 +45,12 @@ handle callerName (Options arg) = do game <- readGame - let command = (if isWildChildsTurn game - then choosePlayerCommand - else chooseAllegianceCommand - ) callerName arg + let command = case game ^. stage of + ScapegoatsTurn -> choosePlayersCommand callerName (T.splitOn "," arg) + WildChildsTurn -> choosePlayerCommand callerName arg + WolfHoundsTurn -> chooseAllegianceCommand callerName arg + -- TODO (hjw): throw an error + _ -> undefined case runExcept (runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game) of Left errorMessages -> exitWith failure { messages = errorMessages } diff --git a/app/Werewolf/Commands/Help.hs b/app/Werewolf/Commands/Help.hs index 740a867..d78b6ed 100644 --- a/app/Werewolf/Commands/Help.hs +++ b/app/Werewolf/Commands/Help.hs @@ -58,7 +58,7 @@ handle callerName (Options Nothing) = exitWith success commandsMessages :: [Text] commandsMessages = - [ "choose (ALLEGIANCE|PLAYER) - choose an allegiance or player." + [ "choose (ALLEGIANCE|PLAYER[,...]) - choose an allegiance or player(s)." , "end - ends the current game." , "heal - heal the devoured player." , "pass - pass on healing or poisoning a player." @@ -127,9 +127,10 @@ rulesMessages = map (T.intercalate "\n") , "8. The Witch wakes up and may heal the victim and/or poison someone." , "9. The village wakes up and find the victim." , "10. The village votes to lynch a suspect." + , "11. (When the Scapegoat is blamed) the Scapegot chooses whom may vote on the next day." , T.unwords [ "The game is over when only Villagers or Werewolves are left alive," - , "or one of the Loners completes their own objective." + , "or when one of the Loners completes their own objective." ] ] ] diff --git a/app/Werewolf/Options.hs b/app/Werewolf/Options.hs index 13f398d..d76d194 100644 --- a/app/Werewolf/Options.hs +++ b/app/Werewolf/Options.hs @@ -19,10 +19,9 @@ module Werewolf.Options ( werewolfPrefs, werewolfInfo, werewolf, ) where -import Data.List.Extra -import Data.Text (Text) -import qualified Data.Text as T -import Data.Version (showVersion) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Version (showVersion) import qualified Werewolf.Commands.Choose as Choose import qualified Werewolf.Commands.Help as Help @@ -89,7 +88,7 @@ werewolf = Options , help "Specify the calling player's name" ]) <*> subparser (mconcat - [ command "choose" $ info (helper <*> choose) (fullDesc <> progDesc "Choose an allegiance") + [ command "choose" $ info (helper <*> choose) (fullDesc <> progDesc "Choose an allegiance or player(s)") , command "end" $ info (helper <*> end) (fullDesc <> progDesc "End the current game") , command "heal" $ info (helper <*> heal) (fullDesc <> progDesc "Heal the devoured player") , command "help" $ info (helper <*> help_) (fullDesc <> progDesc "Help documents") @@ -107,7 +106,7 @@ werewolf = Options ]) choose :: Parser Command -choose = Choose . Choose.Options . T.pack <$> strArgument (metavar "ALLEGIANCE") +choose = Choose . Choose.Options . T.pack <$> strArgument (metavar "ALLEGIANCE|PLAYER[,...]") end :: Parser Command end = pure End @@ -149,7 +148,7 @@ see = See . See.Options <$> playerArgument start :: Parser Command start = fmap Start $ Start.Options - <$> fmap (map T.pack . wordsBy (',' ==)) (strOption $ mconcat + <$> fmap (T.splitOn "," . T.pack) (strOption $ mconcat [ long "extra-roles", metavar "ROLE,..." , value [] , help "Specify the extra roles to include" diff --git a/src/Game/Werewolf/Command.hs b/src/Game/Werewolf/Command.hs index fffff79..bda971b 100644 --- a/src/Game/Werewolf/Command.hs +++ b/src/Game/Werewolf/Command.hs @@ -19,8 +19,8 @@ module Game.Werewolf.Command ( Command(..), -- ** Instances - chooseAllegianceCommand, choosePlayerCommand, healCommand, noopCommand, passCommand, - pingCommand, poisonCommand, protectCommand, quitCommand, seeCommand, statusCommand, + chooseAllegianceCommand, choosePlayerCommand, choosePlayersCommand, healCommand, noopCommand, + passCommand, pingCommand, poisonCommand, protectCommand, quitCommand, seeCommand, statusCommand, voteDevourCommand, voteLynchCommand, ) where @@ -37,8 +37,9 @@ import Data.Text (Text) import qualified Data.Text as T import Game.Werewolf.Engine -import Game.Werewolf.Game hiding (getDevourEvent, getPendingVoters, getPlayerVote, - isDefendersTurn, isGameOver, isSeersTurn, isVillagesTurn, +import Game.Werewolf.Game hiding (getAllowedVoters, getDevourEvent, getPendingVoters, + getPlayerVote, isDefendersTurn, isGameOver, + isScapegoatsTurn, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, killPlayer, setPlayerRole) import Game.Werewolf.Player hiding (doesPlayerExist) @@ -72,6 +73,21 @@ choosePlayerCommand callerName targetName = Command $ do roleModel .= Just targetName +choosePlayersCommand :: Text -> [Text] -> Command +choosePlayersCommand callerName targetNames = Command $ do + whenM isGameOver $ throwError [gameIsOverMessage callerName] + unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] + unlessM (isPlayerScapegoat callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isScapegoatsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + when (null targetNames) $ throwError [playerMustChooseAtLeastOneTargetMessage callerName] + when (callerName `elem` targetNames) $ throwError [playerCannotChooseSelfMessage callerName] + forM_ targetNames $ validatePlayer callerName + whenM (use villageIdiotRevealed &&^ anyM isPlayerVillageIdiot targetNames) $ + throwError [playerCannotChooseVillageIdiotMessage callerName] + + allowedVoters .= targetNames + scapegoatBlamed .= False + healCommand :: Text -> Command healCommand callerName = Command $ do validateWitchsCommand callerName @@ -98,6 +114,11 @@ pingCommand = Command $ use stage >>= \stage' -> case stage' of tell [pingRoleMessage $ defender ^. role . Role.name] tell [pingPlayerMessage $ defender ^. name] + ScapegoatsTurn -> do + scapegoat <- findPlayerByRole_ scapegoatRole + + tell [pingRoleMessage $ scapegoat ^. role . Role.name] + tell [pingPlayerMessage $ scapegoat ^. name] SeersTurn -> do seer <- findPlayerByRole_ seerRole @@ -106,10 +127,11 @@ pingCommand = Command $ use stage >>= \stage' -> case stage' of Sunrise -> return () Sunset -> return () VillagesTurn -> do + allowedVoters <- getAllowedVoters pendingVoters <- getPendingVoters - tell [waitingOnMessage Nothing pendingVoters] - tell $ map (pingPlayerMessage . view name) pendingVoters + tell [waitingOnMessage Nothing $ allowedVoters `intersect` pendingVoters] + tell $ map (pingPlayerMessage . view name) (allowedVoters `intersect` pendingVoters) WerewolvesTurn -> do pendingVoters <- getPendingVoters @@ -193,10 +215,11 @@ statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of Sunset -> return () VillagesTurn -> do game <- get + allowedVoters <- getAllowedVoters pendingVoters <- getPendingVoters tell $ standardStatusMessages stage' (game ^. players) - tell [waitingOnMessage (Just callerName) pendingVoters] + tell [waitingOnMessage (Just callerName) (allowedVoters `intersect` pendingVoters)] WerewolvesTurn -> do game <- get pendingVoters <- filterWerewolves <$> getPendingVoters @@ -230,7 +253,7 @@ voteDevourCommand callerName targetName = Command $ do voteLynchCommand :: Text -> Text -> Command voteLynchCommand callerName targetName = Command $ do validatePlayer callerName callerName - whenM (use villageIdiotRevealed &&^ isPlayerVillageIdiot callerName) $ throwError [playerCannotDoThatMessage callerName] + whenM (uses allowedVoters (callerName `notElem`)) $ throwError [playerCannotDoThatMessage callerName] unlessM isVillagesTurn $ throwError [playerCannotDoThatRightNowMessage callerName] whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName] validatePlayer callerName targetName diff --git a/src/Game/Werewolf/Engine.hs b/src/Game/Werewolf/Engine.hs index f1bec8b..69182a9 100644 --- a/src/Game/Werewolf/Engine.hs +++ b/src/Game/Werewolf/Engine.hs @@ -26,9 +26,9 @@ module Game.Werewolf.Engine ( findPlayerByName_, findPlayerByRole_, -- ** Queries - isGameOver, isDefendersTurn, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWildChildsTurn, - isWitchsTurn, isWolfHoundsTurn, - getPlayerVote, getPendingVoters, getVoteResult, + isGameOver, isDefendersTurn, isScapegoatsTurn, isSeersTurn, isVillagesTurn, isWerewolvesTurn, + isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, + getPlayerVote, getAllowedVoters, getPendingVoters, getVoteResult, -- ** Reading and writing defaultFilePath, writeGame, readGame, deleteGame, doesGameExist, @@ -45,8 +45,8 @@ module Game.Werewolf.Engine ( -- ** Queries doesPlayerExist, - isPlayerDefender, isPlayerSeer, isPlayerVillageIdiot, isPlayerWildChild, isPlayerWitch, - isPlayerWolfHound, + isPlayerDefender, isPlayerScapegoat, isPlayerSeer, isPlayerVillageIdiot, isPlayerWildChild, + isPlayerWitch, isPlayerWolfHound, isPlayerWerewolf, isPlayerAlive, isPlayerDead, @@ -66,11 +66,12 @@ import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T -import Game.Werewolf.Game hiding (getDevourEvent, getPassers, getPendingVoters, - getPlayerVote, getVoteResult, isDefendersTurn, isGameOver, - isSeersTurn, isVillagesTurn, isWerewolvesTurn, - isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, - killPlayer, setPlayerAllegiance, setPlayerRole) +import Game.Werewolf.Game hiding (getAllowedVoters, getDevourEvent, getPassers, + getPendingVoters, getPlayerVote, getVoteResult, + isDefendersTurn, isGameOver, isScapegoatsTurn, isSeersTurn, + isVillagesTurn, isWerewolvesTurn, isWildChildsTurn, + isWitchsTurn, isWolfHoundsTurn, killPlayer, + setPlayerAllegiance, setPlayerRole) import qualified Game.Werewolf.Game as Game import Game.Werewolf.Player hiding (doesPlayerExist) import qualified Game.Werewolf.Player as Player @@ -101,6 +102,12 @@ checkStage' = use stage >>= \stage' -> case stage' of whenJustM (use protect) $ const advanceStage + ScapegoatsTurn -> unlessM (use scapegoatBlamed) $ do + allowedVoters' <- use allowedVoters + tell [scapegoatChoseAllowedVotersMessage allowedVoters'] + + advanceStage + SeersTurn -> do seer <- findPlayerByRole_ seerRole @@ -116,11 +123,10 @@ checkStage' = use stage >>= \stage' -> case stage' of Sunrise -> do round += 1 - whenJustM (findPlayerByRole angelRole) $ \angel -> - when (isAlive angel) $ do - tell [angelJoinedVillagersMessage] + whenJustM (findAlivePlayerByRole angelRole) $ \angel -> do + tell [angelJoinedVillagersMessage] - setPlayerRole (angel ^. name) simpleVillagerRole + setPlayerRole (angel ^. name) simpleVillagerRole advanceStage @@ -138,41 +144,24 @@ checkStage' = use stage >>= \stage' -> case stage' of advanceStage - VillagesTurn -> do - alivePlayers <- uses players filterAlive - playersCount <- ifM (use villageIdiotRevealed) - (return . length $ filter (not . isVillageIdiot) alivePlayers) - (return $ length alivePlayers) - votes' <- use votes - - when (playersCount == Map.size votes') $ do - tell $ map (uncurry playerMadeLynchVoteMessage) (Map.toList votes') - - getVoteResult >>= \votees -> case votees of - [votee] -> if isVillageIdiot votee - then villageIdiotRevealed .= True >> tell [villageIdiotLynchedMessage $ votee ^. name] - else killPlayer (votee ^. name) >> tell [playerLynchedMessage votee] - _ -> - findPlayerByRole scapegoatRole >>= \mScapegoat -> case mScapegoat of - Just scapegoat -> killPlayer (scapegoat ^. name) >> tell [scapegoatLynchedMessage (scapegoat ^. name)] - _ -> tell [noPlayerLynchedMessage] + VillagesTurn -> whenM (null <$> liftM2 intersect getAllowedVoters getPendingVoters) $ do + tell . map (uncurry playerMadeLynchVoteMessage) =<< uses votes Map.toList - advanceStage + getVoteResult >>= lynchVotees - WerewolvesTurn -> do - aliveWerewolves <- uses players (filterAlive . filterWerewolves) + allowedVoters' <- ifM (use villageIdiotRevealed) + (uses players (filter $ not . isVillageIdiot)) + (use players) + allowedVoters .= map (view name) (filterAlive allowedVoters') - whenM (uses votes $ (length aliveWerewolves ==) . Map.size) $ do - getVoteResult >>= \votees -> case votees of - [target] -> - ifM (uses protect $ maybe False (== target ^. name)) - (events %= cons NoDevourEvent) - (events %= cons (DevourEvent $ target ^. name)) - _ -> events %= cons NoDevourEvent + advanceStage - protect .= Nothing + WerewolvesTurn -> whenM (null . filterWerewolves <$> getPendingVoters) $ do + getVoteResult >>= devourVotees - advanceStage + protect .= Nothing + + advanceStage WildChildsTurn -> do whenM (isDead <$> findPlayerByRole_ wildChildRole) advanceStage @@ -197,6 +186,29 @@ checkStage' = use stage >>= \stage' -> case stage' of WolfHoundsTurn -> unlessM (uses players (any isWolfHound . filterAlive)) advanceStage +lynchVotees :: (MonadState Game m, MonadWriter [Message] m) => [Player] -> m () +lynchVotees [votee] + | isVillageIdiot votee = do + villageIdiotRevealed .= True + + tell [villageIdiotLynchedMessage $ votee ^. name] + | otherwise = do + killPlayer (votee ^. name) + tell [playerLynchedMessage votee] +lynchVotees _ = findAlivePlayerByRole scapegoatRole >>= \mScapegoat -> case mScapegoat of + Just scapegoat -> do + scapegoatBlamed .= True + + killPlayer (scapegoat ^. name) + tell [scapegoatLynchedMessage (scapegoat ^. name)] + _ -> tell [noPlayerLynchedMessage] + +devourVotees :: (MonadState Game m, MonadWriter [Message] m) => [Player] -> m () +devourVotees [votee] = ifM (uses protect $ maybe False (== votee ^. name)) + (events %= cons NoDevourEvent) + (events %= cons (DevourEvent $ votee ^. name)) +devourVotees _ = events %= cons NoDevourEvent + advanceStage :: (MonadState Game m, MonadWriter [Message] m) => m () advanceStage = do game <- get @@ -279,15 +291,18 @@ setPlayerAllegiance name allegiance = modify $ Game.setPlayerAllegiance name all findPlayerByName_ :: MonadState Game m => Text -> m Player findPlayerByName_ name = uses players $ findByName_ name -findPlayerByRole :: MonadState Game m => Role -> m (Maybe Player) -findPlayerByRole role = uses players $ findByRole role - findPlayerByRole_ :: MonadState Game m => Role -> m Player findPlayerByRole_ role = uses players $ findByRole_ role +findAlivePlayerByRole :: MonadState Game m => Role -> m (Maybe Player) +findAlivePlayerByRole role = uses players $ findByRole role . filterAlive + isDefendersTurn :: MonadState Game m => m Bool isDefendersTurn = gets Game.isDefendersTurn +isScapegoatsTurn :: MonadState Game m => m Bool +isScapegoatsTurn = gets Game.isScapegoatsTurn + isSeersTurn :: MonadState Game m => m Bool isSeersTurn = gets Game.isSeersTurn @@ -315,6 +330,9 @@ getPassers = gets Game.getPassers getPlayerVote :: MonadState Game m => Text -> m (Maybe Text) getPlayerVote playerName = gets $ Game.getPlayerVote playerName +getAllowedVoters :: MonadState Game m => m [Player] +getAllowedVoters = gets Game.getAllowedVoters + getPendingVoters :: MonadState Game m => m [Player] getPendingVoters = gets Game.getPendingVoters @@ -351,6 +369,9 @@ doesPlayerExist name = uses players $ Player.doesPlayerExist name isPlayerDefender :: MonadState Game m => Text -> m Bool isPlayerDefender name = isDefender <$> findPlayerByName_ name +isPlayerScapegoat :: MonadState Game m => Text -> m Bool +isPlayerScapegoat name = isScapegoat <$> findPlayerByName_ name + isPlayerSeer :: MonadState Game m => Text -> m Bool isPlayerSeer name = isSeer <$> findPlayerByName_ name diff --git a/src/Game/Werewolf/Game.hs b/src/Game/Werewolf/Game.hs index f0d28ec..c2da8b1 100644 --- a/src/Game/Werewolf/Game.hs +++ b/src/Game/Werewolf/Game.hs @@ -13,8 +13,8 @@ Game and stage data structures. module Game.Werewolf.Game ( -- * Game - Game, stage, round, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect, - protect, roleModel, see, villageIdiotRevealed, votes, + Game, stage, round, players, events, passes, allowedVoters, heal, healUsed, poison, poisonUsed, + priorProtect, protect, roleModel, scapegoatBlamed, see, villageIdiotRevealed, votes, newGame, -- ** Manipulations @@ -22,7 +22,7 @@ module Game.Werewolf.Game ( -- ** Queries isFirstRound, - getPassers, getPlayerVote, getPendingVoters, getVoteResult, + getPassers, getPlayerVote, getAllowedVoters, getPendingVoters, getVoteResult, -- * Stage Stage(..), @@ -30,8 +30,8 @@ module Game.Werewolf.Game ( stageCycle, stageAvailable, -- ** Queries - isGameOver, isDefendersTurn, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn, - isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, + isDefendersTurn, isGameOver, isScapegoatsTurn, isSeersTurn, isSunrise, isSunset, isVillagesTurn, + isWerewolvesTurn, isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, -- * Event Event(..), @@ -59,6 +59,7 @@ data Game = Game , _players :: [Player] , _events :: [Event] , _passes :: [Text] + , _allowedVoters :: [Text] , _heal :: Bool , _healUsed :: Bool , _poison :: Maybe Text @@ -66,13 +67,14 @@ data Game = Game , _priorProtect :: Maybe Text , _protect :: Maybe Text , _roleModel :: Maybe Text + , _scapegoatBlamed :: Bool , _see :: Maybe Text , _villageIdiotRevealed :: Bool , _votes :: Map Text Text } deriving (Eq, Read, Show) -data Stage = GameOver | DefendersTurn | SeersTurn | Sunrise | Sunset | VillagesTurn - | WerewolvesTurn | WildChildsTurn | WitchsTurn | WolfHoundsTurn +data Stage = GameOver | DefendersTurn | ScapegoatsTurn | SeersTurn | Sunrise | Sunset + | VillagesTurn | WerewolvesTurn | WildChildsTurn | WitchsTurn | WolfHoundsTurn deriving (Eq, Read, Show) data Event = DevourEvent Text | NoDevourEvent | PoisonEvent Text @@ -91,6 +93,7 @@ newGame players = game & stage .~ head (filter (stageAvailable game) stageCycle) , _players = players , _events = [] , _passes = [] + , _allowedVoters = map (view name) players , _heal = False , _healUsed = False , _poison = Nothing @@ -98,6 +101,7 @@ newGame players = game & stage .~ head (filter (stageAvailable game) stageCycle) , _priorProtect = Nothing , _protect = Nothing , _roleModel = Nothing + , _scapegoatBlamed = False , _see = Nothing , _villageIdiotRevealed = False , _votes = Map.empty @@ -124,6 +128,11 @@ getPassers game = map (`findByName_` players') passes' getPlayerVote :: Text -> Game -> Maybe Text getPlayerVote playerName game = game ^. votes . at playerName +getAllowedVoters :: Game -> [Player] +getAllowedVoters game = map (`findByName_` players') (game ^. allowedVoters) + where + players' = game ^. players + getPendingVoters :: Game -> [Player] getPendingVoters game = filter (flip Map.notMember votes' . view name) alivePlayers where @@ -139,21 +148,8 @@ getVoteResult game = map (`findByName_` players') result allStages :: [Stage] allStages = - [ GameOver - , DefendersTurn - , SeersTurn - , Sunrise - , Sunset - , VillagesTurn - , WerewolvesTurn - , WildChildsTurn - , WitchsTurn - , WolfHoundsTurn - ] - -stageCycle :: [Stage] -stageCycle = cycle [ VillagesTurn + , ScapegoatsTurn , Sunset , SeersTurn , WildChildsTurn @@ -162,17 +158,23 @@ stageCycle = cycle , WerewolvesTurn , WitchsTurn , Sunrise + , GameOver ] +stageCycle :: [Stage] +stageCycle = cycle $ allStages \\ [GameOver] + stageAvailable :: Game -> Stage -> Bool -stageAvailable _ GameOver = False stageAvailable game DefendersTurn = any isDefender (filterAlive $ game ^. players) +stageAvailable _ GameOver = False +stageAvailable game ScapegoatsTurn = game ^. scapegoatBlamed stageAvailable game SeersTurn = any isSeer (filterAlive $ game ^. players) stageAvailable _ Sunrise = True stageAvailable _ Sunset = True stageAvailable game VillagesTurn = - any isAngel (filterAlive $ game ^. players) - || not (isFirstRound game) + (any isAngel (filterAlive $ game ^. players) + || not (isFirstRound game)) + && any isAlive (getAllowedVoters game) stageAvailable game WerewolvesTurn = any isWerewolf (filterAlive $ game ^. players) stageAvailable game WildChildsTurn = any isWildChild (filterAlive $ game ^. players) @@ -182,11 +184,14 @@ stageAvailable game WitchsTurn = && (not (game ^. healUsed) || not (game ^. poisonUsed)) stageAvailable game WolfHoundsTurn = any isWolfHound (filterAlive $ game ^. players) +isDefendersTurn :: Game -> Bool +isDefendersTurn game = game ^. stage == DefendersTurn + isGameOver :: Game -> Bool isGameOver game = game ^. stage == GameOver -isDefendersTurn :: Game -> Bool -isDefendersTurn game = game ^. stage == DefendersTurn +isScapegoatsTurn :: Game -> Bool +isScapegoatsTurn game = game ^. stage == ScapegoatsTurn isSeersTurn :: Game -> Bool isSeersTurn game = game ^. stage == SeersTurn diff --git a/src/Game/Werewolf/Response.hs b/src/Game/Werewolf/Response.hs index f814555..949caa0 100644 --- a/src/Game/Werewolf/Response.hs +++ b/src/Game/Werewolf/Response.hs @@ -53,6 +53,10 @@ module Game.Werewolf.Response ( -- ** Defender's turn messages playerCannotProtectSamePlayerTwiceInARowMessage, + -- ** Scapegoat's turn messages + scapegoatChoseAllowedVotersMessage, playerMustChooseAtLeastOneTargetMessage, + playerCannotChooseVillageIdiotMessage, + -- ** Seer's turn messages playerSeenMessage, @@ -215,6 +219,7 @@ stageMessages :: Game -> [Message] stageMessages game = case game ^. stage of GameOver -> [] DefendersTurn -> defendersTurnMessages defendersName + ScapegoatsTurn -> scapegoatsTurnMessages scapegoatsName SeersTurn -> seersTurnMessages seersName Sunrise -> [sunriseMessage] Sunset -> [nightFallsMessage] @@ -230,6 +235,7 @@ stageMessages game = case game ^. stage of where players' = game ^. players defendersName = findByRole_ defenderRole players' ^. name + scapegoatsName = findByRole_ scapegoatRole players' ^. name seersName = findByRole_ seerRole players' ^. name aliveWerewolfNames = map (view name) . filterAlive $ filterWerewolves players' wildChildsName = findByRole_ wildChildRole players' ^. name @@ -241,6 +247,12 @@ defendersTurnMessages to = , privateMessage to "Whom would you like to `protect`?" ] +scapegoatsTurnMessages :: Text -> [Message] +scapegoatsTurnMessages scapegoatsName = + [ publicMessage "Just before he burns to a complete crisp, he cries out a dying wish." + , publicMessage $ T.concat [scapegoatsName, ", whom do you `choose` to vote on the next day?"] + ] + seersTurnMessages :: Text -> [Message] seersTurnMessages to = [ publicMessage "The Seer wakes up." @@ -397,6 +409,7 @@ currentStageMessages to turn = [privateMessage to $ T.concat showTurn :: Stage -> Text showTurn DefendersTurn = "Defender's" showTurn GameOver = undefined + showTurn ScapegoatsTurn = "Scapegoat's" showTurn SeersTurn = "Seer's" showTurn Sunrise = undefined showTurn Sunset = undefined @@ -450,6 +463,20 @@ playerCannotProtectSamePlayerTwiceInARowMessage :: Text -> Message playerCannotProtectSamePlayerTwiceInARowMessage to = privateMessage to "You cannot protect the same player twice in a row!" +scapegoatChoseAllowedVotersMessage :: [Text] -> Message +scapegoatChoseAllowedVotersMessage allowedVoters = publicMessage $ T.unwords + [ "On the next day only", T.intercalate ", " allowedVoters, "shall be allowed to vote." + , "The town crier, realising how foolish it was to kill him, grants him this wish." + ] + +playerMustChooseAtLeastOneTargetMessage :: Text -> Message +playerMustChooseAtLeastOneTargetMessage to = + privateMessage to "You must choose at least 1 target!" + +playerCannotChooseVillageIdiotMessage :: Text -> Message +playerCannotChooseVillageIdiotMessage to = + privateMessage to "You cannot choose the Village Idiot!" + playerSeenMessage :: Text -> Player -> Message playerSeenMessage to target = privateMessage to $ T.concat [ targetName, " is aligned with the ", T.pack $ show allegiance', "." @@ -485,7 +512,7 @@ playerLynchedMessage player noPlayerLynchedMessage :: Message noPlayerLynchedMessage = publicMessage $ T.unwords [ "Daylight is wasted as the townsfolk squabble over whom to tie up." - , "Looks like no one is being burned this day." + , "Looks like no-one is being burned this day." ] scapegoatLynchedMessage :: Text -> Message diff --git a/src/Game/Werewolf/Role.hs b/src/Game/Werewolf/Role.hs index ad378f4..1e45386 100644 --- a/src/Game/Werewolf/Role.hs +++ b/src/Game/Werewolf/Role.hs @@ -207,6 +207,9 @@ defenderRole = Role -- /unjustly suffers the consequences./ -- -- If the village's vote ends in a tie, it's the Scapegoat who is eliminated instead of no-one. +-- +-- In this event, the Scapegoat has one last task to complete: he must choose whom is permitted to +-- vote or not on the next day. scapegoatRole :: Role scapegoatRole = Role { _name = "Scapegoat" @@ -215,7 +218,13 @@ scapegoatRole = Role [ "It's sad to say, but in Miller's Hollow, when something doesn't go right" , "it's always him who unjustly suffers the consequences." ] - , _advice = "Cross your fingers that the votes don't end up tied." + , _advice = T.unwords + [ "Cross your fingers that the votes don't end up tied." + , "If you do so happen to be that unlucky," + , "then be wary of whom you allow to vote on the next day." + , "If you choose only one player and the Werewolves devour them in the night," + , "then there will be no village vote." + ] } -- | /A fortunate teller by other names, with the ability to see into fellow townsfolk and/ diff --git a/test/src/Game/Werewolf/Test/Arbitrary.hs b/test/src/Game/Werewolf/Test/Arbitrary.hs index a235fa6..df8f659 100644 --- a/test/src/Game/Werewolf/Test/Arbitrary.hs +++ b/test/src/Game/Werewolf/Test/Arbitrary.hs @@ -13,14 +13,16 @@ module Game.Werewolf.Test.Arbitrary ( -- ** Game NewGame(..), - GameAtDefendersTurn(..), GameAtGameOver(..), GameAtSeersTurn(..), GameAtSunrise(..), - GameAtVillagesTurn(..), GameAtWerewolvesTurn(..), GameAtWildChildsTurn(..), + GameAtDefendersTurn(..), GameAtGameOver(..), GameAtScapegoatsTurn(..), GameAtSeersTurn(..), + GameAtSunrise(..), GameAtVillagesTurn(..), GameAtWerewolvesTurn(..), GameAtWildChildsTurn(..), GameAtWitchsTurn(..), GameAtWolfHoundsTurn(..), GameOnSecondRound(..), - GameWithDeadPlayers(..), GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..), - GameWithLynchVotes(..), GameWithOneAllegianceAlive(..), GameWithPoison(..), GameWithProtect(..), + GameWithAllowedVoters(..), GameWithDeadPlayers(..), GameWithDevourEvent(..), + GameWithDevourVotes(..), GameWithHeal(..), GameWithLynchVotes(..), + GameWithOneAllegianceAlive(..), GameWithPoison(..), GameWithProtect(..), GameWithProtectAndDevourVotes(..), GameWithRoleModel(..), GameWithRoleModelAtVillagesTurn(..), - GameWithSee(..), GameWithVillageIdiotRevealedAtVillagesTurn(..), GameWithZeroAllegiancesAlive(..), + GameWithScapegoatBlamed(..), GameWithSee(..), GameWithVillageIdiotRevealedAtVillagesTurn(..), + GameWithZeroAllegiancesAlive(..), -- ** Player arbitraryPlayerSet, @@ -29,9 +31,9 @@ module Game.Werewolf.Test.Arbitrary ( -- ** Command arbitraryCommand, arbitraryChooseAllegianceCommand, arbitraryChoosePlayerCommand, - arbitraryHealCommand, arbitraryPassCommand, arbitraryPoisonCommand, arbitraryProtectCommand, - arbitraryQuitCommand, arbitrarySeeCommand, arbitraryVoteDevourCommand, - arbitraryVoteLynchCommand, + arbitraryChoosePlayersCommand, arbitraryHealCommand, arbitraryPassCommand, + arbitraryPoisonCommand, arbitraryProtectCommand, arbitraryQuitCommand, arbitrarySeeCommand, + arbitraryVoteDevourCommand, arbitraryVoteLynchCommand, runArbitraryCommands, -- ** Player @@ -105,6 +107,15 @@ instance Arbitrary GameAtGameOver where return $ GameAtGameOver (game & stage .~ GameOver) +newtype GameAtScapegoatsTurn = GameAtScapegoatsTurn Game + deriving (Eq, Show) + +instance Arbitrary GameAtScapegoatsTurn where + arbitrary = do + (GameWithScapegoatBlamed game) <- arbitrary + + return $ GameAtScapegoatsTurn (run_ checkStage game) + newtype GameAtSeersTurn = GameAtSeersTurn Game deriving (Eq, Show) @@ -177,14 +188,24 @@ instance Arbitrary GameOnSecondRound where return $ GameOnSecondRound (game & round .~ 1) +newtype GameWithAllowedVoters = GameWithAllowedVoters Game + deriving (Eq, Show) + +instance Arbitrary GameWithAllowedVoters where + arbitrary = do + (GameAtScapegoatsTurn game) <- arbitrary + (Blind command) <- arbitraryChoosePlayersCommand game + + return $ GameWithAllowedVoters (run_ (apply command) game) + newtype GameWithDeadPlayers = GameWithDeadPlayers Game deriving (Eq, Show) instance Arbitrary GameWithDeadPlayers where arbitrary = do - game <- arbitrary - players' <- sublistOf $ game ^. players - let game' = foldr killPlayer game (map (view name) players') + game <- arbitrary + (NonEmpty players') <- NonEmpty <$> sublistOf (game ^. players) + let game' = foldr killPlayer game (map (view name) players') return $ GameWithDeadPlayers (run_ checkStage game') @@ -312,6 +333,15 @@ instance Arbitrary GameWithRoleModelAtVillagesTurn where return $ GameWithRoleModelAtVillagesTurn (game & stage .~ VillagesTurn) +newtype GameWithScapegoatBlamed = GameWithScapegoatBlamed Game + deriving (Eq, Show) + +instance Arbitrary GameWithScapegoatBlamed where + arbitrary = do + (GameWithLynchVotes game) <- suchThat arbitrary $ \(GameWithLynchVotes game) -> length (getVoteResult game) > 1 + + return $ GameWithScapegoatBlamed game + newtype GameWithSee = GameWithSee Game deriving (Eq, Show) @@ -328,9 +358,11 @@ newtype GameWithVillageIdiotRevealed = GameWithVillageIdiotRevealed Game instance Arbitrary GameWithVillageIdiotRevealed where arbitrary = do - game <- arbitrary + game <- arbitrary + let villageIdiot = findByRole_ villageIdiotRole (game ^. players) + let game' = game & villageIdiotRevealed .~ True & allowedVoters %~ delete (villageIdiot ^. name) - return $ GameWithVillageIdiotRevealed (game & villageIdiotRevealed .~ True) + return $ GameWithVillageIdiotRevealed game' newtype GameWithVillageIdiotRevealedAtVillagesTurn = GameWithVillageIdiotRevealedAtVillagesTurn Game deriving (Eq, Show) @@ -367,6 +399,7 @@ arbitraryCommand :: Game -> Gen (Blind Command) arbitraryCommand game = case game ^. stage of GameOver -> return $ Blind noopCommand DefendersTurn -> arbitraryProtectCommand game + ScapegoatsTurn -> arbitraryChoosePlayersCommand game Sunrise -> return $ Blind noopCommand Sunset -> return $ Blind noopCommand SeersTurn -> arbitrarySeeCommand game @@ -394,6 +427,13 @@ arbitraryChoosePlayerCommand game = do return . Blind $ choosePlayerCommand (wildChild ^. name) (target ^. name) +arbitraryChoosePlayersCommand :: Game -> Gen (Blind Command) +arbitraryChoosePlayersCommand game = do + let scapegoat = findByRole_ scapegoatRole (game ^. players) + (NonEmpty players') <- NonEmpty <$> sublistOf (filterAlive $ game ^. players) + + return . Blind $ choosePlayersCommand (scapegoat ^. name) (map (view name) players') + arbitraryHealCommand :: Game -> Gen (Blind Command) arbitraryHealCommand game = do let witch = findByRole_ witchRole (game ^. players) @@ -457,7 +497,7 @@ arbitraryVoteDevourCommand game = do arbitraryVoteLynchCommand :: Game -> Gen (Blind Command) arbitraryVoteLynchCommand game = do - let applicableCallers = getPendingVoters game + let applicableCallers = getAllowedVoters game `intersect` getPendingVoters game target <- arbitraryPlayer game if null applicableCallers diff --git a/test/src/Game/Werewolf/Test/Command.hs b/test/src/Game/Werewolf/Test/Command.hs index c28525a..f788ef7 100644 --- a/test/src/Game/Werewolf/Test/Command.hs +++ b/test/src/Game/Werewolf/Test/Command.hs @@ -22,6 +22,7 @@ import Data.Text (Text) import qualified Data.Text as T import Game.Werewolf.Command +import Game.Werewolf.Engine (checkStage) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Role hiding (name) @@ -51,6 +52,15 @@ allCommandTests = , testProperty "choose player command errors when caller not wild-child" prop_choosePlayerCommandErrorsWhenCallerNotWildChild , testProperty "choose player command sets role model" prop_choosePlayerCommandSetsRoleModel + , testProperty "choose players command errors when game is over" prop_choosePlayersCommandErrorsWhenGameIsOver + , testProperty "choose players command errors when caller does not exist" prop_choosePlayersCommandErrorsWhenCallerDoesNotExist + , testProperty "choose players command errors when any target does not exist" prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist + , testProperty "choose players command errors when any target is dead" prop_choosePlayersCommandErrorsWhenAnyTargetIsDead + , testProperty "choose players command errors when not scapegoat's turn" prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn + , testProperty "choose players command errors when caller not scapegoat" prop_choosePlayersCommandErrorsWhenCallerNotScapegoat + , testProperty "choose players command sets allowed voters" prop_choosePlayersCommandSetsAllowedVoters + , testProperty "choose players command resets scapegoat blamed" prop_choosePlayersCommandResetsScapegoatBlamed + , testProperty "heal command errors when game is over" prop_healCommandErrorsWhenGameIsOver , testProperty "heal command errors when caller does not exist" prop_healCommandErrorsWhenCallerDoesNotExist , testProperty "heal command errors when caller is dead" prop_healCommandErrorsWhenCallerIsDead @@ -105,7 +115,7 @@ allCommandTests = , testProperty "quit command clears player's devour vote" prop_quitCommandClearsPlayersDevourVote , testProperty "quit command clears player's lynch vote" prop_quitCommandClearsPlayersLynchVote , testProperty "quit command clears role model when caller is wild-child" prop_quitCommandClearsRoleModelWhenCallerIsWildChild - , testProperty "quit command sets angel's role when caller is angel" prop_quitCommandSetsAngelsRoleWhenCallerIsAngel + , testProperty "quit command sets angel's role when caller is angel" prop_quitCommandSetsAngelsRoleWhenCallerIsAngel , testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver , testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist @@ -134,6 +144,7 @@ allCommandTests = , testProperty "vote lynch command errors when target is dead" prop_voteLynchCommandErrorsWhenTargetIsDead , testProperty "vote lynch command errors when not villages turn" prop_voteLynchCommandErrorsWhenNotVillagesTurn , testProperty "vote lynch command errors when caller has voted" prop_voteLynchCommandErrorsWhenCallerHasVoted + , testProperty "vote lynch command errors when caller is not in allowed voters" prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters , testProperty "vote lynch command errors when caller is known village idiot" prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot , testProperty "vote lynch command errors when target is known village idiot" prop_voteLynchCommandErrorsWhenTargetIsKnownVillageIdiot , testProperty "vote lynch command updates votes" prop_voteLynchCommandUpdatesVotes @@ -255,7 +266,7 @@ prop_choosePlayerCommandErrorsWhenCallerNotWildChild (GameAtWildChildsTurn game) prop_choosePlayerCommandSetsRoleModel :: GameAtWildChildsTurn -> Property prop_choosePlayerCommandSetsRoleModel (GameAtWildChildsTurn game) = do - let wildChild = findByRole_ wildChildRole (game ^. players) + let wildChild = findByRole_ wildChildRole (game ^. players) forAll (suchThat (arbitraryPlayer game) (not . isWildChild)) $ \target -> do let command = choosePlayerCommand (wildChild ^. name) (target ^. name) @@ -263,6 +274,65 @@ prop_choosePlayerCommandSetsRoleModel (GameAtWildChildsTurn game) = do fromJust (game' ^. roleModel) === target ^. name +prop_choosePlayersCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_choosePlayersCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryChoosePlayersCommand game) $ verbose_runCommandErrors game . getBlind + +prop_choosePlayersCommandErrorsWhenCallerDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property +prop_choosePlayersCommandErrorsWhenCallerDoesNotExist (GameAtScapegoatsTurn game) caller = + forAll (NonEmpty <$> sublistOf (filterAlive $ game ^. players)) $ \(NonEmpty targets) -> do + let command = choosePlayersCommand (caller ^. name) (map (view name) targets) + + not (doesPlayerExist (caller ^. name) (game ^. players)) + ==> verbose_runCommandErrors game command + +prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property +prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist (GameAtScapegoatsTurn game) target = do + let scapegoat = findByRole_ scapegoatRole (game ^. players) + let command = choosePlayersCommand (scapegoat ^. name) [target ^. name] + + not (doesPlayerExist (target ^. name) (game ^. players)) + ==> verbose_runCommandErrors game command + +prop_choosePlayersCommandErrorsWhenAnyTargetIsDead :: GameAtScapegoatsTurn -> Property +prop_choosePlayersCommandErrorsWhenAnyTargetIsDead (GameAtScapegoatsTurn game) = do + let scapegoat = findByRole_ scapegoatRole (game ^. players) + + forAll (NonEmpty <$> sublistOf (filterAlive $ game ^. players)) $ \(NonEmpty targets) -> + forAll (elements targets) $ \target -> do + let game' = killPlayer (target ^. name) game + let command = choosePlayersCommand (scapegoat ^. name) (map (view name) targets) + + verbose_runCommandErrors game' command + +prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn :: Game -> Property +prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn game = + not (isScapegoatsTurn game) + ==> forAll (arbitraryChoosePlayersCommand game) $ verbose_runCommandErrors game . getBlind + +prop_choosePlayersCommandErrorsWhenCallerNotScapegoat :: GameAtScapegoatsTurn -> Property +prop_choosePlayersCommandErrorsWhenCallerNotScapegoat (GameAtScapegoatsTurn game) = + forAll (suchThat (arbitraryPlayer game) (not . isScapegoat)) $ \caller -> + forAll (NonEmpty <$> sublistOf (filterAlive $ game ^. players)) $ \(NonEmpty targets) -> do + let command = choosePlayersCommand (caller ^. name) (map (view name) targets) + + verbose_runCommandErrors game command + +prop_choosePlayersCommandSetsAllowedVoters :: GameAtScapegoatsTurn -> Property +prop_choosePlayersCommandSetsAllowedVoters (GameAtScapegoatsTurn game) = do + let scapegoat = findByRole_ scapegoatRole (game ^. players) + + forAll (NonEmpty <$> sublistOf (filterAlive $ game ^. players)) $ \(NonEmpty targets) -> do + let command = choosePlayersCommand (scapegoat ^. name) (map (view name) targets) + let game' = run_ (apply command) game + + game' ^. allowedVoters === map (view name) targets + +prop_choosePlayersCommandResetsScapegoatBlamed :: GameAtScapegoatsTurn -> Property +prop_choosePlayersCommandResetsScapegoatBlamed (GameAtScapegoatsTurn game) = do + forAll (arbitraryChoosePlayersCommand game) $ \(Blind command) -> + not $ run_ (apply command) game ^. scapegoatBlamed + prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = do let witch = findByRole_ witchRole (game ^. players) @@ -779,6 +849,16 @@ prop_voteLynchCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) = verbose_runCommandErrors game command +prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters :: GameWithAllowedVoters -> Property +prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters (GameWithAllowedVoters game) = + forAll (suchThat (arbitraryPlayer game') (`notElem` getAllowedVoters game')) $ \caller -> + forAll (arbitraryPlayer game') $ \target -> do + let command = voteLynchCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game' command + where + game' = run_ checkStage game + prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot :: GameWithVillageIdiotRevealedAtVillagesTurn -> Property prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot (GameWithVillageIdiotRevealedAtVillagesTurn game) = forAll (arbitraryPlayer game) $ \target -> do diff --git a/test/src/Game/Werewolf/Test/Engine.hs b/test/src/Game/Werewolf/Test/Engine.hs index fca014d..e851ff1 100644 --- a/test/src/Game/Werewolf/Test/Engine.hs +++ b/test/src/Game/Werewolf/Test/Engine.hs @@ -26,9 +26,9 @@ import Data.Text (Text) import Game.Werewolf.Command import Game.Werewolf.Engine hiding (doesPlayerExist, getDevourEvent, getVoteResult, isDefendersTurn, isGameOver, - isSeersTurn, isVillagesTurn, isWerewolvesTurn, - isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, - killPlayer) + isScapegoatsTurn, isSeersTurn, isVillagesTurn, + isWerewolvesTurn, isWildChildsTurn, isWitchsTurn, + isWolfHoundsTurn, killPlayer) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Role hiding (name) @@ -46,7 +46,9 @@ import Test.Tasty.QuickCheck allEngineTests :: [TestTree] allEngineTests = [ testProperty "check stage skips defender's turn when no defender" prop_checkStageSkipsDefendersTurnWhenNoDefender + , testProperty "check stage skips scapegoat's turn when no seer" prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat , testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer + , testProperty "check stage skips village's turn when allowed voters empty" prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty , testProperty "check stage skips wild-child's turn when no wild-child" prop_checkStageSkipsWildChildsTurnWhenNoWildChild , testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch , testProperty "check stage skips wolf-hound's turn when no wolf-hound" prop_checkStageSkipsWolfHoundsTurnWhenNoWolfHound @@ -56,6 +58,9 @@ allEngineTests = , testProperty "check defender's turn advances when no defender" prop_checkDefendersTurnAdvancesWhenNoDefender , testProperty "check defender's turn does nothing unless protected" prop_checkDefendersTurnDoesNothingUnlessProtected + , testProperty "check scapegoat's turn advances to seer's turn" prop_checkScapegoatsTurnAdvancesToSeersTurn + , testProperty "check scapegoat's turn does nothing while scapegoat blamed" prop_checkScapegoatsTurnDoesNothingWhileScapegoatBlamed + , testProperty "check seer's turn advances to wild-child's turn" prop_checkSeersTurnAdvancesToWildChildsTurn , testProperty "check seer's turn advances when no seer" prop_checkSeersTurnAdvancesWhenNoSeer , testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee @@ -66,12 +71,13 @@ allEngineTests = , testProperty "check sunset sets wild-child's allegiance when role model dead" prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead - , testProperty "check villages' turn advances to seer's turn" prop_checkVillagesTurnAdvancesToSeersTurn + , testProperty "check villages' turn advances to scapegoat's turn" prop_checkVillagesTurnAdvancesToScapegoatsTurn , testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus , testProperty "check villages' turn lynches no one when target is village idiot" prop_checkVillagesTurnLynchesNoOneWhenTargetIsVillageIdiot , testProperty "check villages' turn lynches no one when conflicted and no scapegoats" prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats , testProperty "check villages' turn lynches scapegoat when conflicted" prop_checkVillagesTurnLynchesScapegoatWhenConflicted , testProperty "check villages' turn resets votes" prop_checkVillagesTurnResetsVotes + , testProperty "check villages' turn sets allowed voters" prop_checkVillagesTurnSetsAllowedVoters , testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted , testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn @@ -137,14 +143,25 @@ prop_checkStageSkipsDefendersTurnWhenNoDefender (GameWithRoleModel game) = defendersName = findByRole_ defenderRole (game ^. players) ^. name game' = killPlayer defendersName game +prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat :: GameAtScapegoatsTurn -> Bool +prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat (GameAtScapegoatsTurn game) = + isScapegoatsTurn $ run_ checkStage game + prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithLynchVotes -> Property prop_checkStageSkipsSeersTurnWhenNoSeer (GameWithLynchVotes game) = isAlive (findByRole_ angelRole $ run_ checkStage game' ^. players) - ==> isWildChildsTurn game' || isDefendersTurn game' + ==> isScapegoatsTurn game' || isWildChildsTurn game' || isDefendersTurn game' where seersName = findByRole_ seerRole (game ^. players) ^. name game' = run_ (apply (quitCommand seersName) >> checkStage) game +prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty :: GameAtWitchsTurn -> Property +prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty (GameAtWitchsTurn game) = + forAll (arbitraryPassCommand game') $ \(Blind passCommand) -> do + isSeersTurn $ run_ (apply passCommand >> checkStage) game' + where + game' = game & allowedVoters .~ [] + prop_checkStageSkipsWildChildsTurnWhenNoWildChild :: GameWithSee -> Bool prop_checkStageSkipsWildChildsTurnWhenNoWildChild (GameWithSee game) = isDefendersTurn $ run_ checkStage game' @@ -178,14 +195,22 @@ prop_checkDefendersTurnAdvancesToWolfHoundsTurn (GameWithProtect game) = prop_checkDefendersTurnAdvancesWhenNoDefender :: GameAtDefendersTurn -> Bool prop_checkDefendersTurnAdvancesWhenNoDefender (GameAtDefendersTurn game) = do let defender = findByRole_ defenderRole (game ^. players) - let game' = killPlayer (defender ^. name) game + let command = quitCommand $ defender ^. name - not . isDefendersTurn $ run_ checkStage game' + not . isDefendersTurn $ run_ (apply command >> checkStage) game prop_checkDefendersTurnDoesNothingUnlessProtected :: GameAtDefendersTurn -> Bool prop_checkDefendersTurnDoesNothingUnlessProtected (GameAtDefendersTurn game) = isDefendersTurn $ run_ checkStage game +prop_checkScapegoatsTurnAdvancesToSeersTurn :: GameWithAllowedVoters -> Bool +prop_checkScapegoatsTurnAdvancesToSeersTurn (GameWithAllowedVoters game) = + isSeersTurn $ run_ checkStage game + +prop_checkScapegoatsTurnDoesNothingWhileScapegoatBlamed :: GameAtScapegoatsTurn -> Bool +prop_checkScapegoatsTurnDoesNothingWhileScapegoatBlamed (GameAtScapegoatsTurn game) = + isScapegoatsTurn $ run_ checkStage game + prop_checkSeersTurnAdvancesToWildChildsTurn :: GameWithSee -> Bool prop_checkSeersTurnAdvancesToWildChildsTurn (GameWithSee game) = isWildChildsTurn $ run_ checkStage game @@ -193,9 +218,9 @@ prop_checkSeersTurnAdvancesToWildChildsTurn (GameWithSee game) = prop_checkSeersTurnAdvancesWhenNoSeer :: GameAtSeersTurn -> Bool prop_checkSeersTurnAdvancesWhenNoSeer (GameAtSeersTurn game) = do let seer = findByRole_ seerRole (game ^. players) - let game' = killPlayer (seer ^. name) game + let command = quitCommand $ seer ^. name - not . isSeersTurn $ run_ checkStage game' + not . isSeersTurn $ run_ (apply command >> checkStage) game prop_checkSeersTurnResetsSee :: GameWithSee -> Bool prop_checkSeersTurnResetsSee (GameWithSee game) = @@ -225,11 +250,9 @@ prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead (GameWithRoleModelAtVi where roleModel' = findByName_ (fromJust $ game ^. roleModel) (game ^. players) -prop_checkVillagesTurnAdvancesToSeersTurn :: GameWithLynchVotes -> Property -prop_checkVillagesTurnAdvancesToSeersTurn (GameWithLynchVotes game) = - isAlive (findByRole_ seerRole $ run_ checkStage game ^. players) - && isAlive (findByRole_ angelRole $ run_ checkStage game ^. players) - ==> isSeersTurn $ run_ checkStage game +prop_checkVillagesTurnAdvancesToScapegoatsTurn :: GameWithScapegoatBlamed -> Bool +prop_checkVillagesTurnAdvancesToScapegoatsTurn (GameWithScapegoatBlamed game) = + isScapegoatsTurn $ run_ checkStage game prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: GameWithLynchVotes -> Property prop_checkVillagesTurnLynchesOnePlayerWhenConsensus (GameWithLynchVotes game) = @@ -258,15 +281,23 @@ prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats game = game' = killPlayer scapegoatsName game & stage .~ VillagesTurn n = length $ game' ^. players -prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: GameWithLynchVotes -> Property -prop_checkVillagesTurnLynchesScapegoatWhenConflicted (GameWithLynchVotes game) = - length (getVoteResult game) > 1 - ==> isDead . findByRole_ scapegoatRole $ run_ checkStage game ^. players +prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: GameAtScapegoatsTurn -> Bool +prop_checkVillagesTurnLynchesScapegoatWhenConflicted (GameAtScapegoatsTurn game) = + isDead . findByRole_ scapegoatRole $ run_ checkStage game ^. players prop_checkVillagesTurnResetsVotes :: GameWithLynchVotes -> Bool prop_checkVillagesTurnResetsVotes (GameWithLynchVotes game) = Map.null $ run_ checkStage game ^. votes +prop_checkVillagesTurnSetsAllowedVoters :: GameWithLynchVotes -> Property +prop_checkVillagesTurnSetsAllowedVoters (GameWithLynchVotes game) = + game' ^. allowedVoters === map (view name) expectedAllowedVoters + where + game' = run_ checkStage game + expectedAllowedVoters + | game' ^. villageIdiotRevealed = filter (not . isVillageIdiot) $ game' ^. players + | otherwise = filterAlive $ game' ^. players + prop_checkVillagesTurnDoesNothingUnlessAllVoted :: GameAtVillagesTurn -> Property prop_checkVillagesTurnDoesNothingUnlessAllVoted (GameAtVillagesTurn game) = forAll (runArbitraryCommands n game) $ \game' -> @@ -326,9 +357,9 @@ prop_checkWildChildsTurnAdvancesToDefendersTurn (GameAtWildChildsTurn game) = prop_checkWildChildsTurnAdvancesWhenNoWildChild :: GameAtWildChildsTurn -> Bool prop_checkWildChildsTurnAdvancesWhenNoWildChild (GameAtWildChildsTurn game) = do let wildChild = findByRole_ wildChildRole (game ^. players) - let game' = killPlayer (wildChild ^. name) game + let command = quitCommand $ wildChild ^. name - not . isWildChildsTurn $ run_ checkStage game' + not . isWildChildsTurn $ run_ (apply command >> checkStage) game prop_checkWildChildsTurnDoesNothingUnlessRoleModelChosen :: GameAtWildChildsTurn -> Bool prop_checkWildChildsTurnDoesNothingUnlessRoleModelChosen (GameAtWildChildsTurn game) = @@ -342,9 +373,9 @@ prop_checkWitchsTurnAdvancesToVillagesTurn (GameAtWitchsTurn game) = prop_checkWitchsTurnAdvancesWhenNoWitch :: GameAtWitchsTurn -> Bool prop_checkWitchsTurnAdvancesWhenNoWitch (GameAtWitchsTurn game) = do let witch = findByRole_ witchRole (game ^. players) - let game' = killPlayer (witch ^. name) game + let command = quitCommand $ witch ^. name - not . isWitchsTurn $ run_ checkStage game' + not . isWitchsTurn $ run_ (apply command >> checkStage) game prop_checkWitchsTurnHealsDevoureeWhenHealed :: GameWithHeal -> Property prop_checkWitchsTurnHealsDevoureeWhenHealed (GameWithHeal game) = @@ -388,9 +419,9 @@ prop_checkWolfHoundsTurnAdvancesToWerewolvesTurn (GameAtWolfHoundsTurn game) = prop_checkWolfHoundsTurnAdvancesWhenNoWolfHound :: GameAtWolfHoundsTurn -> Bool prop_checkWolfHoundsTurnAdvancesWhenNoWolfHound (GameAtWolfHoundsTurn game) = do let wolfHound = findByRole_ wolfHoundRole (game ^. players) - let game' = killPlayer (wolfHound ^. name) game + let command = quitCommand $ wolfHound ^. name - not . isWolfHoundsTurn $ run_ checkStage game' + not . isWolfHoundsTurn $ run_ (apply command >> checkStage) game prop_checkWolfHoundsTurnDoesNothingUnlessChosen :: GameAtWolfHoundsTurn -> Bool prop_checkWolfHoundsTurnDoesNothingUnlessChosen (GameAtWolfHoundsTurn game) = diff --git a/test/src/Game/Werewolf/Test/Game.hs b/test/src/Game/Werewolf/Test/Game.hs index aa5744b..52f1acb 100644 --- a/test/src/Game/Werewolf/Test/Game.hs +++ b/test/src/Game/Werewolf/Test/Game.hs @@ -33,13 +33,16 @@ allGameTests = , testProperty "new game starts on first round" prop_newGameStartsOnFirstRound , testProperty "new game starts with events empty" prop_newGameStartsWithEventsEmpty , testProperty "new game starts with passes empty" prop_newGameStartsWithPassesEmpty - , testProperty "new game starts with no heal" prop_newGameStartsWithNoHeal - , testProperty "new game starts with no heal used" prop_newGameStartsWithNoHealUsed + , testProperty "new game starts with allowed voters full" prop_newGameStartsWithAllowedVotersFull + , testProperty "new game starts with heal false" prop_newGameStartsWithHealFalse + , testProperty "new game starts with heal used false" prop_newGameStartsWithHealUsedFalse , testProperty "new game starts with no poison" prop_newGameStartsWithNoPoison - , testProperty "new game starts with no poison used" prop_newGameStartsWithNoPoisonUsed + , testProperty "new game starts with poison used false" prop_newGameStartsWithPoisonUsedFalse , testProperty "new game starts with no prior protect" prop_newGameStartsWithNoPriorProtect , testProperty "new game starts with no protect" prop_newGameStartsWithNoProtect + , testProperty "new game starts with scapegoat blamed false" prop_newGameStartsWithScapegoatBlamedFalse , testProperty "new game starts with no see" prop_newGameStartsWithNoSee + , testProperty "new game starts with village idiot revealed false" prop_newGameStartsWithVillageIdiotRevealedFalse , testProperty "new game starts with votes empty" prop_newGameStartsWithVotesEmpty , testProperty "new game uses given players" prop_newGameUsesGivenPlayers ] @@ -63,17 +66,20 @@ prop_newGameStartsWithEventsEmpty players = null $ newGame players ^. events prop_newGameStartsWithPassesEmpty :: [Player] -> Bool prop_newGameStartsWithPassesEmpty players = null $ newGame players ^. passes -prop_newGameStartsWithNoHeal :: [Player] -> Bool -prop_newGameStartsWithNoHeal players = not $ newGame players ^. heal +prop_newGameStartsWithAllowedVotersFull :: [Player] -> Property +prop_newGameStartsWithAllowedVotersFull players = newGame players ^. allowedVoters === map (view name) players -prop_newGameStartsWithNoHealUsed :: [Player] -> Bool -prop_newGameStartsWithNoHealUsed players = not $ newGame players ^. healUsed +prop_newGameStartsWithHealFalse :: [Player] -> Bool +prop_newGameStartsWithHealFalse players = not $ newGame players ^. heal + +prop_newGameStartsWithHealUsedFalse :: [Player] -> Bool +prop_newGameStartsWithHealUsedFalse players = not $ newGame players ^. healUsed prop_newGameStartsWithNoPoison :: [Player] -> Bool prop_newGameStartsWithNoPoison players = isNothing $ newGame players ^. poison -prop_newGameStartsWithNoPoisonUsed :: [Player] -> Bool -prop_newGameStartsWithNoPoisonUsed players = not $ newGame players ^. poisonUsed +prop_newGameStartsWithPoisonUsedFalse :: [Player] -> Bool +prop_newGameStartsWithPoisonUsedFalse players = not $ newGame players ^. poisonUsed prop_newGameStartsWithNoPriorProtect :: [Player] -> Bool prop_newGameStartsWithNoPriorProtect players = isNothing $ newGame players ^. priorProtect @@ -81,9 +87,16 @@ prop_newGameStartsWithNoPriorProtect players = isNothing $ newGame players ^. pr prop_newGameStartsWithNoProtect :: [Player] -> Bool prop_newGameStartsWithNoProtect players = isNothing $ newGame players ^. protect +prop_newGameStartsWithScapegoatBlamedFalse :: [Player] -> Bool +prop_newGameStartsWithScapegoatBlamedFalse players = not $ newGame players ^. scapegoatBlamed + prop_newGameStartsWithNoSee :: [Player] -> Bool prop_newGameStartsWithNoSee players = isNothing $ newGame players ^. see +prop_newGameStartsWithVillageIdiotRevealedFalse :: [Player] -> Bool +prop_newGameStartsWithVillageIdiotRevealedFalse players = + not $ newGame players ^. villageIdiotRevealed + prop_newGameStartsWithVotesEmpty :: [Player] -> Bool prop_newGameStartsWithVotesEmpty players = Map.null $ newGame players ^. votes