diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,18 +2,11 @@ #### Upcoming -#### v0.4.2.3 - -*Revisions* - -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) -* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82)) - -#### v0.4.2.2 +#### v0.4.3 -*Revisions* +*Minor* -* Fixed a bug causing the Witch being unable to heal themselves. ([#76](https://github.com/hjwylde/werewolf/issues/76)) +* Added the Defender role. ([#38](https://github.com/hjwylde/werewolf/issues/38)) #### v0.4.2.1 @@ -25,21 +18,7 @@ *Minor* -* Added the Villager role. ([#37](https://github.com/hjwylde/werewolf/issues/37)) - -#### v0.4.1.3 - -*Revisions* - -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) -* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82)) - -#### v0.4.1.2 - -*Revisions* - -* Added missing module to Cabal file. - +* Added the Villager-Villager role. ([#37](https://github.com/hjwylde/werewolf/issues/37)) #### v0.4.1.1 @@ -52,12 +31,6 @@ *Minor* * Added the Witch role. ([#5](https://github.com/hjwylde/werewolf/issues/5)) - -#### v0.4.0.1 - -*Revisions* - -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) #### v0.4.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,6 +20,7 @@ #### Roles The current implemented roles are: +* Defender. * Scapegoat. * Seer. * Villager. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -29,6 +29,7 @@ import qualified Werewolf.Commands.Pass as Pass import qualified Werewolf.Commands.Ping as Ping import qualified Werewolf.Commands.Poison as Poison +import qualified Werewolf.Commands.Protect as Protect import qualified Werewolf.Commands.Quit as Quit import qualified Werewolf.Commands.See as See import qualified Werewolf.Commands.Start as Start @@ -59,6 +60,7 @@ Pass -> Pass.handle callerName Ping -> Ping.handle callerName Poison options -> Poison.handle callerName options + Protect options -> Protect.handle callerName options Quit -> Quit.handle callerName See options -> See.handle callerName options Start options -> Start.handle callerName options diff --git a/app/Werewolf/Commands/End.hs b/app/Werewolf/Commands/End.hs --- a/app/Werewolf/Commands/End.hs +++ b/app/Werewolf/Commands/End.hs @@ -32,14 +32,14 @@ -- | Handle. handle :: MonadIO m => Text -> m () handle callerName = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame - when (isNothing $ findByName callerName (game ^. players)) $ exitWith failure { - messages = [playerCannotDoThatMessage callerName] + when (isNothing $ findByName callerName (game ^. players)) $ exitWith failure + { messages = [playerCannotDoThatMessage callerName] } deleteGame diff --git a/app/Werewolf/Commands/Heal.hs b/app/Werewolf/Commands/Heal.hs deleted file mode 100644 --- a/app/Werewolf/Commands/Heal.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-| -Module : Werewolf.Commands.Heal -Description : Handler for the heal subcommand. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -Handler for the heal subcommand. --} - -{-# LANGUAGE OverloadedStrings #-} - -module Werewolf.Commands.Heal ( - -- * Handle - handle, -) where - -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.State -import Control.Monad.Writer - -import Data.Text (Text) - -import Game.Werewolf.Command -import Game.Werewolf.Engine -import Game.Werewolf.Response - --- | Handle. -handle :: MonadIO m => Text -> m () -handle callerName = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] - } - - game <- readGame - - let command = healCommand callerName - - case runExcept (runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game) of - Left errorMessages -> exitWith failure { messages = errorMessages } - Right (game', messages) -> writeGame game' >> exitWith success { messages = messages } diff --git a/app/Werewolf/Commands/Help.hs b/app/Werewolf/Commands/Help.hs --- a/app/Werewolf/Commands/Help.hs +++ b/app/Werewolf/Commands/Help.hs @@ -39,125 +39,99 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () -handle callerName (Options (Just Commands)) = exitWith success { - messages = map (privateMessage callerName) commandsMessages +handle callerName (Options (Just Commands)) = exitWith success + { messages = map (privateMessage callerName) commandsMessages } -handle callerName (Options (Just Description)) = exitWith success { - messages = map (privateMessage callerName) descriptionMessages +handle callerName (Options (Just Description)) = exitWith success + { messages = map (privateMessage callerName) descriptionMessages } -handle callerName (Options (Just Roles)) = exitWith success { - messages = map (\role -> privateMessage callerName $ T.intercalate "\n" [ - T.snoc (role ^. Role.name) ':', - role ^. description, - role ^. advice +handle callerName (Options (Just Roles)) = exitWith success + { messages = map (\role -> privateMessage callerName $ T.intercalate "\n" + [ T.snoc (role ^. Role.name) ':' + , role ^. description + , role ^. advice ]) allRoles } -handle callerName (Options (Just Rules)) = exitWith success { - messages = map (privateMessage callerName) rulesMessages +handle callerName (Options (Just Rules)) = exitWith success + { messages = map (privateMessage callerName) rulesMessages } -handle callerName (Options Nothing) = exitWith success { - messages = map (privateMessage callerName) helpMessages +handle callerName (Options Nothing) = exitWith success + { messages = map (privateMessage callerName) helpMessages } commandsMessages :: [Text] -commandsMessages = map (T.intercalate "\n") [[ - "end", - "- Ends the current game." - ], [ - "heal", - "- Heal the devoured player. The Witch may heal the devoured player at nighttime." - ], [ - "pass", - "- Pass. A Witch may pass on poisoning a player." - ], [ - "ping", - "- Pings the status of the current game publicly." - ], [ - "poison PLAYER", - "- Poison a player. The Witch may poison a player at nighttime." - ], [ - "quit", - "- Quit the current game." - ], [ - "see PLAYER", - "- See a player's allegiance. The Seer may determine a player's allegiance once per day." - ], [ - "start [--extra-roles ROLE,...] PLAYER ...", - "- Starts a new game with the given players and extra roles. A game requires at least 7 players." - ], [ - "status", - "- Gets the status of the current game." - ], [ - "vote PLAYER", - T.unwords [ - "- Vote against a player.", - "A townsperson may vote at daytime to lynch someone", - "and a Werewolf may vote at nighttime to devour a Villager." - ] - ]] +commandsMessages = + [ "end - ends the current game." + , "heal PLAYER - heal a devoured player." + , "pass - pass on healing or poisoning a player." + , "ping - pings the status of the current game publicly." + , "poison PLAYER - poison a player." + , "protect PLAYER - protect a player." + , "quit - quit the current game." + , "see PLAYER - see a player's allegiance." + , "start [--extra-roles ROLE,...] PLAYER... - starts a new game with the given players and extra roles. A game requires at least 7 players." + , "status - gets the status of the current game." + , "vote PLAYER - vote against a player." + ] descriptionMessages :: [Text] -descriptionMessages = map (T.intercalate "\n") [[ - T.unwords [ - "Deep in the American countryside,", - "the little town of Millers Hollow has recently been infiltrated by Werewolves." - ], - T.unwords [ - "Each night, murders are committed by the Villagers,", - "who due to some mysterious phenomenon (possibly the greenhouse effect)", - "have become Werewolves." - ], - T.unwords [ - "It is now time to take control and eliminate this ancient evil,", - "before the town loses its last few inhabitants." +descriptionMessages = map (T.intercalate "\n") + [ [ T.unwords + [ "Deep in the American countryside," + , "the little town of Millers Hollow has recently been infiltrated by Werewolves." ] - ], [ - "Objective of the Game:", - "For the Villagers: lynch all of the Werewolves.", - "For the Werewolves: devour all of the Villagers." - ]] + , T.unwords + [ "Each night, murders are committed by the Villagers," + , "who due to some mysterious phenomenon (possibly the greenhouse effect)" + , "have become Werewolves." + ] + , T.unwords + [ "It is now time to take control and eliminate this ancient evil," + , "before the town loses its last few inhabitants." + ] + ] + , [ "Objective of the Game:" + , "For the Villagers: lynch all of the Werewolves." + , "For the Werewolves: devour all of the Villagers." + ] + ] rulesMessages :: [Text] -rulesMessages = map (T.intercalate "\n") [[ - T.unwords [ - "Each night, the Werewolves bite, kill and devour one Villager.", - "During the day they try to conceal their identity and vile deeds from the Villagers.", - "The number of Werewolves in play depends upon", - " the number of players and variants used in the game," - ], - T.unwords [ - "Each day,", - "the survivors gather in the town square and try to discover who the Werewolves are.", - "This is done by studying the other player's social behaviours", - "for hidden signs of lycanthropy.", - "After discussing and debating, the village votes to lynch a suspect,", - "who is then hanged, burned and eliminated from the game." +rulesMessages = map (T.intercalate "\n") + [ [ T.unwords + [ "Each night, the Werewolves bite, kill and devour one Villager." + , "During the day they try to conceal their identity and vile deeds from the Villagers." + , "The number of Werewolves in play depends upon" + , " the number of players and variants used in the game." ] - ], [ - T.unwords [ - "Each player is informed of their role (see `help roles' for a list)", - "at the start of the game. A game begins at night and follows a standard cycle." - ], - "1. The village falls asleep.", - "2. The Seer wakes up and sees someone's allegiance.", - "3. The Werewolves wake up and select a victim.", - "4. The Witch wakes up and may heal the victim and/or poison someone.", - "5. The village wakes up and find the victim.", - "6. The village votes to lynch a suspect.", - "The game is over when only Villagers or Werewolves are left alive." - ]] + , T.unwords + [ "Each day," + , "the survivors gather in the town square and try to discover who the Werewolves are." + , "This is done by studying the other player's social behaviours" + , "for hidden signs of lycanthropy." + , "After discussing and debating, the village votes to lynch a suspect," + , "who is then hanged, burned and eliminated from the game." + ] + ] + , [ T.unwords + [ "Each player is informed of their role (see `help roles' for a list)" + , "at the start of the game. A game begins at night and follows a standard cycle." + ] + , "1. The village falls asleep." + , "2. The Defender wakes up and protects someone." + , "3. The Seer wakes up and sees someone's allegiance." + , "4. The Werewolves wake up and select a victim." + , "5. The Witch wakes up and may heal the victim and/or poison someone." + , "6. The village wakes up and find the victim." + , "7. The village votes to lynch a suspect." + , "The game is over when only Villagers or Werewolves are left alive." + ] + ] helpMessages :: [Text] -helpMessages = map (T.intercalate "\n") [[ - "help commands", - "- Print the in-game commands." - ], [ - "help description", - "- Print the game description." - ], [ - "help roles", - "- Print the roles and their description." - ], [ - "help rules", - "- Print the game rules." - ]] +helpMessages = + [ "help commands - print the in-game commands." + , "help description - print the game description." + , "help roles - print the roles and their description." + , "help rules - print the game rules." + ] diff --git a/app/Werewolf/Commands/Pass.hs b/app/Werewolf/Commands/Pass.hs --- a/app/Werewolf/Commands/Pass.hs +++ b/app/Werewolf/Commands/Pass.hs @@ -28,8 +28,8 @@ -- | Handle. handle :: MonadIO m => Text -> m () handle callerName = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Commands/Ping.hs b/app/Werewolf/Commands/Ping.hs --- a/app/Werewolf/Commands/Ping.hs +++ b/app/Werewolf/Commands/Ping.hs @@ -28,8 +28,8 @@ -- | Handle. handle :: MonadIO m => Text -> m () handle callerName = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Commands/Poison.hs b/app/Werewolf/Commands/Poison.hs --- a/app/Werewolf/Commands/Poison.hs +++ b/app/Werewolf/Commands/Poison.hs @@ -36,8 +36,8 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () handle callerName (Options targetName) = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Commands/Protect.hs b/app/Werewolf/Commands/Protect.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Commands/Protect.hs @@ -0,0 +1,49 @@ +{-| +Module : Werewolf.Commands.Protect +Description : Options and handler for the protect subcommand. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Options and handler for the protect subcommand. +-} + +module Werewolf.Commands.Protect ( + -- * Options + Options(..), + + -- * Handle + handle, +) where + +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf.Command +import Game.Werewolf.Engine +import Game.Werewolf.Response + +-- | Options. +data Options = Options + { argTarget :: Text + } deriving (Eq, Show) + +-- | Handle. +handle :: MonadIO m => Text -> Options -> m () +handle callerName (Options targetName) = do + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] + } + + game <- readGame + + let command = protectCommand callerName targetName + + case runExcept (runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game) of + Left errorMessages -> exitWith failure { messages = errorMessages } + Right (game', messages) -> writeGame game' >> exitWith success { messages = messages } diff --git a/app/Werewolf/Commands/Quit.hs b/app/Werewolf/Commands/Quit.hs --- a/app/Werewolf/Commands/Quit.hs +++ b/app/Werewolf/Commands/Quit.hs @@ -28,8 +28,8 @@ -- | Handle. handle :: MonadIO m => Text -> m () handle callerName = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Commands/See.hs b/app/Werewolf/Commands/See.hs --- a/app/Werewolf/Commands/See.hs +++ b/app/Werewolf/Commands/See.hs @@ -36,8 +36,8 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () handle callerName (Options targetName) = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Commands/Start.hs b/app/Werewolf/Commands/Start.hs --- a/app/Werewolf/Commands/Start.hs +++ b/app/Werewolf/Commands/Start.hs @@ -40,8 +40,8 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () handle callerName (Options extraRoleNames playerNames) = do - whenM doesGameExist . whenM (fmap (not . isGameOver) readGame) $ exitWith failure { - messages = [gameAlreadyRunningMessage callerName] + whenM (doesGameExist &&^ fmap (not . isGameOver) readGame) $ exitWith failure + { messages = [gameAlreadyRunningMessage callerName] } result <- runExceptT $ do diff --git a/app/Werewolf/Commands/Status.hs b/app/Werewolf/Commands/Status.hs --- a/app/Werewolf/Commands/Status.hs +++ b/app/Werewolf/Commands/Status.hs @@ -28,8 +28,8 @@ -- | Handle. handle :: MonadIO m => Text -> m () handle callerName = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Commands/Vote.hs b/app/Werewolf/Commands/Vote.hs --- a/app/Werewolf/Commands/Vote.hs +++ b/app/Werewolf/Commands/Vote.hs @@ -37,8 +37,8 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () handle callerName (Options targetName) = do - unlessM doesGameExist $ exitWith failure { - messages = [noGameRunningMessage callerName] + unlessM doesGameExist $ exitWith failure + { messages = [noGameRunningMessage callerName] } game <- readGame diff --git a/app/Werewolf/Options.hs b/app/Werewolf/Options.hs --- a/app/Werewolf/Options.hs +++ b/app/Werewolf/Options.hs @@ -27,6 +27,7 @@ import qualified Werewolf.Commands.Help as Help import qualified Werewolf.Commands.Interpret as Interpret import qualified Werewolf.Commands.Poison as Poison +import qualified Werewolf.Commands.Protect as Protect import qualified Werewolf.Commands.See as See import qualified Werewolf.Commands.Start as Start import qualified Werewolf.Commands.Vote as Vote @@ -49,6 +50,7 @@ | Pass | Ping | Poison Poison.Options + | Protect Protect.Options | Quit | See See.Options | Start Start.Options @@ -66,38 +68,39 @@ werewolfInfo = info (infoOptions <*> werewolf) (fullDesc <> header' <> progDesc') where infoOptions = helper <*> version - version = infoOption ("Version " ++ showVersion This.version) $ mconcat [ - long "version", short 'V', hidden, - help "Show this binary's version" + version = infoOption ("Version " ++ showVersion This.version) $ mconcat + [ long "version", short 'V', hidden + , help "Show this binary's version" ] header' = header "A game engine for running werewolf in a chat client." - progDesc' = progDesc $ unwords [ - "This engine is based off of Werewolves of Millers Hollow", - "(http://www.games-wiki.org/wiki/Werewolves_of_Millers_Hollow/).", - "See https://github.com/hjwylde/werewolf for help on writing chat interfaces." + progDesc' = progDesc $ unwords + [ "This engine is based off of Werewolves of Millers Hollow" + , "(http://www.games-wiki.org/wiki/Werewolves_of_Millers_Hollow/)." + , "See https://github.com/hjwylde/werewolf for help on writing chat interfaces." ] -- | An options parser. werewolf :: Parser Options werewolf = Options - <$> fmap T.pack (strOption $ mconcat [ - long "caller", metavar "PLAYER", - help "Specify the calling player's name" + <$> fmap T.pack (strOption $ mconcat + [ long "caller", metavar "PLAYER" + , help "Specify the calling player's name" ]) - <*> subparser (mconcat [ - 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"), - command "interpret" $ info (helper <*> interpret) (fullDesc <> progDesc "Interpret a command" <> noIntersperse), - command "pass" $ info (helper <*> pass) (fullDesc <> progDesc "Pass"), - command "ping" $ info (helper <*> ping) (fullDesc <> progDesc "Pings the status of the current game publicly"), - command "poison" $ info (helper <*> poison) (fullDesc <> progDesc "Poison a player"), - command "quit" $ info (helper <*> quit) (fullDesc <> progDesc "Quit the current game"), - command "see" $ info (helper <*> see) (fullDesc <> progDesc "See a player's allegiance"), - command "start" $ info (helper <*> start) (fullDesc <> progDesc "Start a new game"), - command "status" $ info (helper <*> status) (fullDesc <> progDesc "Get the status of the current game"), - command "vote" $ info (helper <*> vote) (fullDesc <> progDesc "Vote against a player") + <*> subparser (mconcat + [ 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") + , command "interpret" $ info (helper <*> interpret) (fullDesc <> progDesc "Interpret a command" <> noIntersperse) + , command "pass" $ info (helper <*> pass) (fullDesc <> progDesc "Pass") + , command "ping" $ info (helper <*> ping) (fullDesc <> progDesc "Pings the status of the current game publicly") + , command "poison" $ info (helper <*> poison) (fullDesc <> progDesc "Poison a player") + , command "protect" $ info (helper <*> protect) (fullDesc <> progDesc "Protect a player") + , command "quit" $ info (helper <*> quit) (fullDesc <> progDesc "Quit the current game") + , command "see" $ info (helper <*> see) (fullDesc <> progDesc "See a player's allegiance") + , command "start" $ info (helper <*> start) (fullDesc <> progDesc "Start a new game") + , command "status" $ info (helper <*> status) (fullDesc <> progDesc "Get the status of the current game") + , command "vote" $ info (helper <*> vote) (fullDesc <> progDesc "Vote against a player") ]) end :: Parser Command @@ -108,15 +111,17 @@ help_ :: Parser Command help_ = Help . Help.Options - <$> optional (subparser $ mconcat [ - command "commands" $ info (pure Help.Commands) (fullDesc <> progDesc "Print the in-game commands"), - command "description" $ info (pure Help.Description) (fullDesc <> progDesc "Print the game description"), - command "rules" $ info (pure Help.Rules) (fullDesc <> progDesc "Print the game rules"), - command "roles" $ info (pure Help.Roles) (fullDesc <> progDesc "Print the roles and their descriptions") + <$> optional (subparser $ mconcat + [ command "commands" $ info (pure Help.Commands) (fullDesc <> progDesc "Print the in-game commands") + , command "description" $ info (pure Help.Description) (fullDesc <> progDesc "Print the game description") + , command "rules" $ info (pure Help.Rules) (fullDesc <> progDesc "Print the game rules") + , command "roles" $ info (pure Help.Roles) (fullDesc <> progDesc "Print the roles and their descriptions") ]) interpret :: Parser Command -interpret = Interpret . Interpret.Options <$> many (T.pack <$> strArgument (metavar "-- COMMAND ARG...")) +interpret = Interpret . Interpret.Options <$> many ( + T.pack <$> strArgument (metavar "-- COMMAND ARG...") + ) pass :: Parser Command pass = pure Pass @@ -125,20 +130,23 @@ ping = pure Ping poison :: Parser Command -poison = Poison . Poison.Options . T.pack <$> strArgument (metavar "PLAYER") +poison = Poison . Poison.Options <$> playerArgument +protect :: Parser Command +protect = Protect . Protect.Options <$> playerArgument + quit :: Parser Command quit = pure Quit see :: Parser Command -see = See . See.Options . T.pack <$> strArgument (metavar "PLAYER") +see = See . See.Options <$> playerArgument start :: Parser Command start = fmap Start $ Start.Options - <$> fmap (map T.pack . wordsBy (',' ==)) (strOption $ mconcat [ - long "extra-roles", metavar "ROLE,...", - value [], - help "Specify the extra roles to include" + <$> fmap (map T.pack . wordsBy (',' ==)) (strOption $ mconcat + [ long "extra-roles", metavar "ROLE,..." + , value [] + , help "Specify the extra roles to include" ]) <*> many (T.pack <$> strArgument (metavar "PLAYER...")) @@ -146,4 +154,7 @@ status = pure Status vote :: Parser Command -vote = Vote . Vote.Options . T.pack <$> strArgument (metavar "PLAYER") +vote = Vote . Vote.Options <$> playerArgument + +playerArgument :: Parser Text +playerArgument = T.pack <$> strArgument (metavar "PLAYER") diff --git a/src/Game/Werewolf/Command.hs b/src/Game/Werewolf/Command.hs --- a/src/Game/Werewolf/Command.hs +++ b/src/Game/Werewolf/Command.hs @@ -19,7 +19,7 @@ -- ** Instances devourVoteCommand, healCommand, lynchVoteCommand, noopCommand, passCommand, pingCommand, - poisonCommand, quitCommand, seeCommand, statusCommand, + poisonCommand, protectCommand, quitCommand, seeCommand, statusCommand, ) where import Control.Lens hiding (only) @@ -34,9 +34,9 @@ import Data.Text (Text) import Game.Werewolf.Engine -import Game.Werewolf.Game hiding (getDevourEvent, getPendingVoters, getPlayerVote, isGameOver, - isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, - killPlayer) +import Game.Werewolf.Game hiding (getDevourEvent, getPendingVoters, getPlayerVote, + isDefendersTurn, isGameOver, isSeersTurn, isVillagesTurn, + isWerewolvesTurn, isWitchsTurn, killPlayer) import Game.Werewolf.Player hiding (doesPlayerExist) import Game.Werewolf.Response @@ -91,8 +91,13 @@ pingCommand :: Command pingCommand = Command $ use stage >>= \stage' -> case stage' of GameOver -> return () + DefendersTurn -> do + defender <- uses players $ head . filterDefenders + + tell [pingDefenderMessage] + tell [pingPlayerMessage $ defender ^. name] SeersTurn -> do - seer <- uses players $ head . filterAlive . filterSeers + seer <- uses players $ head . filterSeers tell [pingSeerMessage] tell [pingPlayerMessage $ seer ^. name] @@ -109,7 +114,7 @@ tell [pingWerewolvesMessage] tell $ map (pingPlayerMessage . _name) (filterWerewolves pendingVoters) WitchsTurn -> do - witch <- uses players $ head . filterAlive . filterWitches + witch <- uses players $ head . filterWitches tell [pingWitchMessage] tell [pingPlayerMessage $ witch ^. name] @@ -127,6 +132,19 @@ poison .= Just targetName poisonUsed .= True +protectCommand :: Text -> Text -> Command +protectCommand callerName targetName = Command $ do + validatePlayer callerName callerName + unlessM (isPlayerDefender callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isDefendersTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + when (callerName == targetName) $ throwError [playerCannotProtectSelfMessage callerName] + validatePlayer callerName targetName + whenJustM (use priorProtect) $ \priorName -> + when (targetName == priorName) $ throwError [playerCannotProtectSamePlayerTwiceInARowMessage callerName] + + priorProtect .= Just targetName + protect .= Just targetName + quitCommand :: Text -> Command quitCommand callerName = Command $ do validatePlayer callerName callerName @@ -137,12 +155,15 @@ tell [playerQuitMessage caller] passes %= delete callerName - when (isWitch caller) $ do + when (isDefender caller) $ do + protect .= Nothing + priorProtect .= Nothing + when (isSeer caller) $ see .= Nothing + when (isWitch caller) $ do heal .= False healUsed .= False poison .= Nothing poisonUsed .= False - when (isSeer caller) $ see .= Nothing votes %= Map.delete callerName seeCommand :: Text -> Text -> Command @@ -157,6 +178,10 @@ statusCommand :: Text -> Command statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of GameOver -> get >>= tell . gameOverMessages + DefendersTurn -> do + game <- get + + tell $ standardStatusMessages stage' (game ^. players) SeersTurn -> do game <- get diff --git a/src/Game/Werewolf/Engine.hs b/src/Game/Werewolf/Engine.hs --- a/src/Game/Werewolf/Engine.hs +++ b/src/Game/Werewolf/Engine.hs @@ -23,8 +23,8 @@ startGame, killPlayer, -- ** Queries - isGameOver, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, getPlayerVote, - getPendingVoters, getVoteResult, + isGameOver, isDefendersTurn, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, + getPlayerVote, getPendingVoters, getVoteResult, -- ** Reading and writing defaultFilePath, writeGame, readGame, deleteGame, doesGameExist, @@ -40,7 +40,8 @@ createPlayers, -- ** Queries - doesPlayerExist, isPlayerSeer, isPlayerWerewolf, isPlayerWitch, isPlayerAlive, isPlayerDead, + doesPlayerExist, isPlayerDefender, isPlayerSeer, isPlayerWerewolf, isPlayerWitch, isPlayerAlive, + isPlayerDead, -- * Role randomiseRoles, @@ -59,14 +60,14 @@ import qualified Data.Text as T import Game.Werewolf.Game hiding (getDevourEvent, getPassers, getPendingVoters, - getPlayerVote, getVoteResult, isGameOver, isSeersTurn, - isVillagesTurn, isWerewolvesTurn, isWitchsTurn, killPlayer) + getPlayerVote, getVoteResult, isDefendersTurn, isGameOver, + isSeersTurn, isVillagesTurn, isWerewolvesTurn, + isWitchsTurn, killPlayer) import qualified Game.Werewolf.Game as Game import Game.Werewolf.Player hiding (doesPlayerExist) import qualified Game.Werewolf.Player as Player import Game.Werewolf.Response -import Game.Werewolf.Role (Role, scapegoatRole, seerRole, villagerRole, - villagerVillagerRole, werewolfRole, witchRole, _allegiance) +import Game.Werewolf.Role hiding (name, _name) import qualified Game.Werewolf.Role as Role import System.Directory @@ -85,6 +86,8 @@ checkStage' = use stage >>= \stage' -> case stage' of GameOver -> return () + DefendersTurn -> whenJustM (use protect) $ const advanceStage + SeersTurn -> whenJustM (use see) $ \targetName -> do seer <- uses players (head . filterSeers) target <- uses players (findByName_ targetName) @@ -120,9 +123,14 @@ whenM (uses votes $ (length aliveWerewolves ==) . Map.size) $ do getVoteResult >>= \votees -> case votees of - [target] -> events %= cons (DevourEvent $ target ^. name) + [target] -> + ifM (uses protect $ maybe False (== target ^. name)) + (events %= cons (ProtectEvent $ target ^. name)) + (events %= cons (DevourEvent $ target ^. name)) _ -> tell [noPlayerDevouredMessage] + protect .= Nothing + advanceStage WitchsTurn -> do @@ -163,6 +171,7 @@ eventAvailable :: MonadState Game m => Event -> m Bool eventAvailable (DevourEvent _) = gets isSunrise eventAvailable (PoisonEvent _) = gets isSunrise +eventAvailable (ProtectEvent _) = gets isSunrise applyEvent :: (MonadState Game m, MonadWriter [Message] m) => Event -> m () applyEvent (DevourEvent targetName) = do @@ -182,6 +191,7 @@ killPlayer player tell [playerPoisonedMessage player] +applyEvent (ProtectEvent name) = tell [playerProtectedMessage name] checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do @@ -204,11 +214,14 @@ return game where playerNames = map _name players - restrictedRoles = [scapegoatRole, seerRole, villagerVillagerRole, witchRole] + restrictedRoles = [defenderRole, scapegoatRole, seerRole, villagerVillagerRole, witchRole] killPlayer :: MonadState Game m => Player -> m () killPlayer player = players %= map (\player' -> if player' == player then player' & state .~ Dead else player') +isDefendersTurn :: MonadState Game m => m Bool +isDefendersTurn = gets Game.isDefendersTurn + isSeersTurn :: MonadState Game m => m Bool isSeersTurn = gets Game.isSeersTurn @@ -262,6 +275,9 @@ doesPlayerExist :: MonadState Game m => Text -> m Bool doesPlayerExist name = uses players $ Player.doesPlayerExist name + +isPlayerDefender :: MonadState Game m => Text -> m Bool +isPlayerDefender name = uses players $ isDefender . findByName_ name isPlayerSeer :: MonadState Game m => Text -> m Bool isPlayerSeer name = uses players $ isSeer . findByName_ name diff --git a/src/Game/Werewolf/Game.hs b/src/Game/Werewolf/Game.hs --- a/src/Game/Werewolf/Game.hs +++ b/src/Game/Werewolf/Game.hs @@ -13,15 +13,16 @@ module Game.Werewolf.Game ( -- * Game - Game(..), stage, players, events, passes, heal, healUsed, poison, poisonUsed, see, votes, + Game(..), stage, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect, + protect, see, votes, newGame, -- ** Manipulations killPlayer, -- ** Queries - isGameOver, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, - getPassers, getPlayerVote, getPendingVoters, getVoteResult, + isGameOver, isDefendersTurn, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn, + isWitchsTurn, getPassers, getPlayerVote, getPendingVoters, getVoteResult, -- * Stage Stage(..), @@ -45,22 +46,25 @@ import Game.Werewolf.Player data Game = Game - { _stage :: Stage - , _players :: [Player] - , _events :: [Event] - , _passes :: [Text] - , _heal :: Bool - , _healUsed :: Bool - , _poison :: Maybe Text - , _poisonUsed :: Bool - , _see :: Maybe Text - , _votes :: Map Text Text + { _stage :: Stage + , _players :: [Player] + , _events :: [Event] + , _passes :: [Text] + , _heal :: Bool + , _healUsed :: Bool + , _poison :: Maybe Text + , _poisonUsed :: Bool + , _priorProtect :: Maybe Text + , _protect :: Maybe Text + , _see :: Maybe Text + , _votes :: Map Text Text } deriving (Eq, Read, Show) -data Stage = GameOver | SeersTurn | Sunrise | Sunset | VillagesTurn | WerewolvesTurn | WitchsTurn +data Stage = GameOver | DefendersTurn | SeersTurn | Sunrise | Sunset | VillagesTurn + | WerewolvesTurn | WitchsTurn deriving (Eq, Read, Show) -data Event = DevourEvent Text | PoisonEvent Text +data Event = DevourEvent Text | PoisonEvent Text | ProtectEvent Text deriving (Eq, Read, Show) makeLenses ''Game @@ -79,6 +83,8 @@ , _healUsed = False , _poison = Nothing , _poisonUsed = False + , _priorProtect = Nothing + , _protect = Nothing , _see = Nothing , _votes = Map.empty } @@ -89,6 +95,9 @@ isGameOver :: Game -> Bool isGameOver game = game ^. stage == GameOver +isDefendersTurn :: Game -> Bool +isDefendersTurn game = game ^. stage == DefendersTurn + isSeersTurn :: Game -> Bool isSeersTurn game = game ^. stage == SeersTurn @@ -130,10 +139,12 @@ result = last $ groupSortOn (\votee -> length $ elemIndices votee votees) (nub votees) stageCycle :: [Stage] -stageCycle = cycle [Sunset, SeersTurn, WerewolvesTurn, WitchsTurn, Sunrise, VillagesTurn] +stageCycle = cycle + [Sunset, SeersTurn, DefendersTurn, WerewolvesTurn, WitchsTurn, Sunrise, VillagesTurn] stageAvailable :: Game -> Stage -> Bool stageAvailable _ GameOver = False +stageAvailable game DefendersTurn = any isDefender (filterAlive $ game ^. players) stageAvailable game SeersTurn = any isSeer (filterAlive $ game ^. players) stageAvailable _ Sunrise = True stageAvailable _ Sunset = True diff --git a/src/Game/Werewolf/Player.hs b/src/Game/Werewolf/Player.hs --- a/src/Game/Werewolf/Player.hs +++ b/src/Game/Werewolf/Player.hs @@ -20,11 +20,12 @@ findByName, findByName_, -- ** Filters - filterScapegoats, filterSeers, filterVillagers, filterVillagerVillagers, filterWerewolves, - filterWitches, + filterDefenders, filterScapegoats, filterSeers, filterVillagers, filterVillagerVillagers, + filterWerewolves, filterWitches, -- ** Queries - doesPlayerExist, isScapegoat, isSeer, isVillager, isWerewolf, isWitch, isAlive, isDead, + doesPlayerExist, isDefender, isScapegoat, isSeer, isVillager, isWerewolf, isWitch, isAlive, + isDead, -- * State State(..), @@ -61,6 +62,9 @@ findByName_ :: Text -> [Player] -> Player findByName_ name = fromJust . findByName name +filterDefenders :: [Player] -> [Player] +filterDefenders = filter isDefender + filterScapegoats :: [Player] -> [Player] filterScapegoats = filter isScapegoat @@ -81,6 +85,9 @@ doesPlayerExist :: Text -> [Player] -> Bool doesPlayerExist name = isJust . findByName name + +isDefender :: Player -> Bool +isDefender player = player ^. role == defenderRole isScapegoat :: Player -> Bool isScapegoat player = player ^. role == scapegoatRole diff --git a/src/Game/Werewolf/Response.hs b/src/Game/Werewolf/Response.hs --- a/src/Game/Werewolf/Response.hs +++ b/src/Game/Werewolf/Response.hs @@ -34,11 +34,15 @@ newGameMessages, stageMessages, gameOverMessages, playerQuitMessage, -- ** Ping messages - pingPlayerMessage, pingSeerMessage, pingWerewolvesMessage, pingWitchMessage, + pingPlayerMessage, pingDefenderMessage, pingSeerMessage, pingWerewolvesMessage, + pingWitchMessage, -- ** Status messages currentStageMessages, rolesInGameMessage, playersInGameMessage, waitingOnMessage, + -- ** Defender's turn messages + playerProtectedMessage, + -- ** Seer's turn messages playerSeenMessage, @@ -56,6 +60,9 @@ gameIsOverMessage, playerDoesNotExistMessage, playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, playerIsDeadMessage, roleDoesNotExistMessage, + -- ** Seer's turn error messages + playerCannotProtectSelfMessage, playerCannotProtectSamePlayerTwiceInARowMessage, + -- ** Voting turn error messages playerHasAlreadyVotedMessage, targetIsDeadMessage, @@ -179,6 +186,7 @@ stageMessages :: Game -> [Message] stageMessages game = case game ^. stage of GameOver -> [] + DefendersTurn -> defendersTurnMessages (_name . head . filterDefenders $ game ^. players) SeersTurn -> seersTurnMessages (_name . head . filterSeers $ game ^. players) Sunrise -> [sunriseMessage] Sunset -> [nightFallsMessage] @@ -186,6 +194,12 @@ WerewolvesTurn -> werewolvesTurnMessages (map _name . filterAlive . filterWerewolves $ game ^. players) WitchsTurn -> witchsTurnMessages game +defendersTurnMessages :: Text -> [Message] +defendersTurnMessages defenderName = [ + publicMessage "The Defender wakes up.", + privateMessage defenderName "Whom would you like to protect?" + ] + seersTurnMessages :: Text -> [Message] seersTurnMessages seerName = [ publicMessage "The Seer wakes up.", @@ -253,6 +267,9 @@ pingPlayerMessage :: Text -> Message pingPlayerMessage to = privateMessage to "Waiting on you..." +pingDefenderMessage :: Message +pingDefenderMessage = publicMessage "Waiting on the Defender..." + pingSeerMessage :: Message pingSeerMessage = publicMessage "Waiting on the Seer..." @@ -266,18 +283,10 @@ currentStageMessages to GameOver = [gameIsOverMessage to] currentStageMessages _ Sunrise = [] currentStageMessages _ Sunset = [] + -- TODO (hjw): pluralise this correctly for the Seer currentStageMessages to turn = [privateMessage to $ T.concat [ - "It's currently the ", showTurn turn, " turn." + "It's currently the ", T.pack $ show turn, "' turn." ]] - where - showTurn :: Stage -> Text - showTurn GameOver = undefined - showTurn SeersTurn = "Seer's" - showTurn Sunrise = undefined - showTurn Sunset = undefined - showTurn VillagesTurn = "Village's" - showTurn WerewolvesTurn = "Werewolves'" - showTurn WitchsTurn = "Witch's" rolesInGameMessage :: Maybe Text -> [Role] -> Message rolesInGameMessage mTo roles = Message mTo $ T.concat [ @@ -311,6 +320,12 @@ where playerNames = map _name players +playerProtectedMessage :: Text -> Message +playerProtectedMessage name = publicMessage $ T.unwords + [ "As you emerge from your home you see", name, "outside waving a wolf paw around." + , "Some poor Werewolf must have tried to attack them while the Defender was on watch." + ] + playerSeenMessage :: Text -> Player -> Message playerSeenMessage to target = privateMessage to $ T.concat [ target ^. name, " is aligned with the ", T.pack . show $ target ^. role . allegiance, "." @@ -401,6 +416,13 @@ roleDoesNotExistMessage :: Text -> Text -> Message roleDoesNotExistMessage to name = privateMessage to $ T.unwords ["Role", name, "does not exist."] + +playerCannotProtectSelfMessage :: Text -> Message +playerCannotProtectSelfMessage to = privateMessage to "You cannot protect yourself!" + +playerCannotProtectSamePlayerTwiceInARowMessage :: Text -> Message +playerCannotProtectSamePlayerTwiceInARowMessage to = + privateMessage to "You cannot protect the same player twice in a row!" playerHasAlreadyVotedMessage :: Text -> Message playerHasAlreadyVotedMessage to = privateMessage to "You've already voted!" diff --git a/src/Game/Werewolf/Role.hs b/src/Game/Werewolf/Role.hs --- a/src/Game/Werewolf/Role.hs +++ b/src/Game/Werewolf/Role.hs @@ -17,7 +17,8 @@ Role(..), name, allegiance, description, advice, -- ** Instances - allRoles, scapegoatRole, seerRole, villagerRole, villagerVillagerRole, werewolfRole, witchRole, + allRoles, defenderRole, scapegoatRole, seerRole, villagerRole, villagerVillagerRole, + werewolfRole, witchRole, -- * Allegiance Allegiance(..), @@ -38,8 +39,20 @@ } deriving (Eq, Read, Show) allRoles :: [Role] -allRoles = [scapegoatRole, seerRole, villagerRole, villagerVillagerRole, werewolfRole, witchRole] +allRoles = [defenderRole, scapegoatRole, seerRole, villagerRole, villagerVillagerRole, werewolfRole, witchRole] +defenderRole :: Role +defenderRole = Role + { _name = "Defender" + , _allegiance = Villagers + , _description = T.unwords + [ "A knight living in Miller's Hollow." + , "The Defender has the ability to protect one player each night." + ] + , _advice = + "Be careful when you choose to protect someone, you cannot protect them 2 nights in a row." + } + scapegoatRole :: Role scapegoatRole = Role { _name = "Scapegoat" @@ -98,11 +111,11 @@ [ "A conniving townsperson." , "She knows how to make up 2 extremely powerful potions;" , "one healing potion which can revive the Werewolves' victim," - , "one poison potion which when used at night can kill a player." + , "one poison potion which when used can kill a player." ] , _advice = T.unwords - [ "Each potion may be used once per game," - , "but there are no restrictions on how many you may use at night." + [ "Each potion may only be used once per game," + , "but there are no restrictions on using both on one night." ] } diff --git a/test/app/Main.hs b/test/app/Main.hs --- a/test/app/Main.hs +++ b/test/app/Main.hs @@ -24,148 +24,172 @@ main = defaultMain =<< tests tests :: IO TestTree -tests = return $ testGroup "Tests" (concat [allCommandTests, allEngineTests, allGameTests, allPlayerTests]) +tests = return $ testGroup "Tests" (concat + [allCommandTests, allEngineTests, allGameTests, allPlayerTests] + ) allCommandTests :: [TestTree] -allCommandTests = [ - testProperty "devour vote command errors when game is over" prop_devourVoteCommandErrorsWhenGameIsOver, - testProperty "devour vote command errors when caller does not exist" prop_devourVoteCommandErrorsWhenCallerDoesNotExist, - testProperty "devour vote command errors when target does not exist" prop_devourVoteCommandErrorsWhenTargetDoesNotExist, - testProperty "devour vote command errors when caller is dead" prop_devourVoteCommandErrorsWhenCallerIsDead, - testProperty "devour vote command errors when target is dead" prop_devourVoteCommandErrorsWhenTargetIsDead, - testProperty "devour vote command errors when not werewolves turn" prop_devourVoteCommandErrorsWhenNotWerewolvesTurn, - testProperty "devour vote command errors when caller not werewolf" prop_devourVoteCommandErrorsWhenCallerNotWerewolf, - testProperty "devour vote command errors when caller has voted" prop_devourVoteCommandErrorsWhenCallerHasVoted, - testProperty "devour vote command errors when target werewolf" prop_devourVoteCommandErrorsWhenTargetWerewolf, - testProperty "devour vote command updates votes" prop_devourVoteCommandUpdatesVotes, +allCommandTests = + [ testProperty "devour vote command errors when game is over" prop_devourVoteCommandErrorsWhenGameIsOver + , testProperty "devour vote command errors when caller does not exist" prop_devourVoteCommandErrorsWhenCallerDoesNotExist + , testProperty "devour vote command errors when target does not exist" prop_devourVoteCommandErrorsWhenTargetDoesNotExist + , testProperty "devour vote command errors when caller is dead" prop_devourVoteCommandErrorsWhenCallerIsDead + , testProperty "devour vote command errors when target is dead" prop_devourVoteCommandErrorsWhenTargetIsDead + , testProperty "devour vote command errors when not werewolves turn" prop_devourVoteCommandErrorsWhenNotWerewolvesTurn + , testProperty "devour vote command errors when caller not werewolf" prop_devourVoteCommandErrorsWhenCallerNotWerewolf + , testProperty "devour vote command errors when caller has voted" prop_devourVoteCommandErrorsWhenCallerHasVoted + , testProperty "devour vote command errors when target werewolf" prop_devourVoteCommandErrorsWhenTargetWerewolf + , testProperty "devour vote command updates votes" prop_devourVoteCommandUpdatesVotes - 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, - testProperty "heal command errors when no target is devoured" prop_healCommandErrorsWhenNoTargetIsDevoured, - testProperty "heal command errors when not witch's turn" prop_healCommandErrorsWhenNotWitchsTurn, - testProperty "heal command errors when caller has healed" prop_healCommandErrorsWhenCallerHasHealed, - testProperty "heal command errors when caller not witch" prop_healCommandErrorsWhenCallerNotWitch, - testProperty "heal command sets heal" prop_healCommandSetsHeal, - testProperty "heal command sets heal used" prop_healCommandSetsHealUsed, + , 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 + , testProperty "heal command errors when no target is devoured" prop_healCommandErrorsWhenNoTargetIsDevoured + , testProperty "heal command errors when not witch's turn" prop_healCommandErrorsWhenNotWitchsTurn + , testProperty "heal command errors when caller has healed" prop_healCommandErrorsWhenCallerHasHealed + , testProperty "heal command errors when caller not witch" prop_healCommandErrorsWhenCallerNotWitch + , testProperty "heal command sets heal" prop_healCommandSetsHeal + , testProperty "heal command sets heal used" prop_healCommandSetsHealUsed - testProperty "lynch vote command errors when game is over" prop_lynchVoteCommandErrorsWhenGameIsOver, - testProperty "lynch vote command errors when caller does not exist" prop_lynchVoteCommandErrorsWhenCallerDoesNotExist, - testProperty "lynch vote command errors when target does not exist" prop_lynchVoteCommandErrorsWhenTargetDoesNotExist, - testProperty "lynch vote command errors when caller is dead" prop_lynchVoteCommandErrorsWhenCallerIsDead, - testProperty "lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead, - testProperty "lynch vote command errors when not villages turn" prop_lynchVoteCommandErrorsWhenNotVillagesTurn, - testProperty "lynch vote command errors when caller has voted" prop_lynchVoteCommandErrorsWhenCallerHasVoted, - testProperty "lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes, + , testProperty "lynch vote command errors when game is over" prop_lynchVoteCommandErrorsWhenGameIsOver + , testProperty "lynch vote command errors when caller does not exist" prop_lynchVoteCommandErrorsWhenCallerDoesNotExist + , testProperty "lynch vote command errors when target does not exist" prop_lynchVoteCommandErrorsWhenTargetDoesNotExist + , testProperty "lynch vote command errors when caller is dead" prop_lynchVoteCommandErrorsWhenCallerIsDead + , testProperty "lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead + , testProperty "lynch vote command errors when not villages turn" prop_lynchVoteCommandErrorsWhenNotVillagesTurn + , testProperty "lynch vote command errors when caller has voted" prop_lynchVoteCommandErrorsWhenCallerHasVoted + , testProperty "lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes - testProperty "pass command errors when game is over" prop_passCommandErrorsWhenGameIsOver, - testProperty "pass command errors when caller does not exist" prop_passCommandErrorsWhenCallerDoesNotExist, - testProperty "pass command errors when caller is dead" prop_passCommandErrorsWhenCallerIsDead, - testProperty "pass command errors when not witch's turn" prop_passCommandErrorsWhenNotWitchsTurn, - testProperty "pass command updates passes" prop_passCommandUpdatesPasses, + , testProperty "pass command errors when game is over" prop_passCommandErrorsWhenGameIsOver + , testProperty "pass command errors when caller does not exist" prop_passCommandErrorsWhenCallerDoesNotExist + , testProperty "pass command errors when caller is dead" prop_passCommandErrorsWhenCallerIsDead + , testProperty "pass command errors when not witch's turn" prop_passCommandErrorsWhenNotWitchsTurn + , testProperty "pass command updates passes" prop_passCommandUpdatesPasses - testProperty "poison command errors when game is over" prop_poisonCommandErrorsWhenGameIsOver, - testProperty "poison command errors when caller does not exist" prop_poisonCommandErrorsWhenCallerDoesNotExist, - testProperty "poison command errors when target does not exist" prop_poisonCommandErrorsWhenTargetDoesNotExist, - testProperty "poison command errors when caller is dead" prop_poisonCommandErrorsWhenCallerIsDead, - testProperty "poison command errors when target is dead" prop_poisonCommandErrorsWhenTargetIsDead, - testProperty "poison command errors when target is devoured" prop_poisonCommandErrorsWhenTargetIsDevoured, - testProperty "poison command errors when not witch's turn" prop_poisonCommandErrorsWhenNotWitchsTurn, - testProperty "poison command errors when caller has poisoned" prop_poisonCommandErrorsWhenCallerHasPoisoned, - testProperty "poison command errors when caller not witch" prop_poisonCommandErrorsWhenCallerNotWitch, - testProperty "poison command sets poison" prop_poisonCommandSetsPoison, - testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed, + , testProperty "poison command errors when game is over" prop_poisonCommandErrorsWhenGameIsOver + , testProperty "poison command errors when caller does not exist" prop_poisonCommandErrorsWhenCallerDoesNotExist + , testProperty "poison command errors when target does not exist" prop_poisonCommandErrorsWhenTargetDoesNotExist + , testProperty "poison command errors when caller is dead" prop_poisonCommandErrorsWhenCallerIsDead + , testProperty "poison command errors when target is dead" prop_poisonCommandErrorsWhenTargetIsDead + , testProperty "poison command errors when target is devoured" prop_poisonCommandErrorsWhenTargetIsDevoured + , testProperty "poison command errors when not witch's turn" prop_poisonCommandErrorsWhenNotWitchsTurn + , testProperty "poison command errors when caller has poisoned" prop_poisonCommandErrorsWhenCallerHasPoisoned + , testProperty "poison command errors when caller not witch" prop_poisonCommandErrorsWhenCallerNotWitch + , testProperty "poison command sets poison" prop_poisonCommandSetsPoison + , testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed - testProperty "quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver, - testProperty "quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist, - testProperty "quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead, - testProperty "quit command kills player" prop_quitCommandKillsPlayer, - testProperty "quit command clears heal when caller is witch" prop_quitCommandClearsHealWhenCallerIsWitch, - testProperty "quit command clears heal used when caller is witch" prop_quitCommandClearsHealUsedWhenCallerIsWitch, - testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonWhenCallerIsWitch, - testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonUsedWhenCallerIsWitch, - testProperty "quit command clears player's devour vote" prop_quitCommandClearsPlayersDevourVote, - testProperty "quit command clears player's lynch vote" prop_quitCommandClearsPlayersLynchVote, + , testProperty "protect command errors when game is over" prop_protectCommandErrorsWhenGameIsOver + , testProperty "protect command errors when caller does not exist" prop_protectCommandErrorsWhenCallerDoesNotExist + , testProperty "protect command errors when target does not exist" prop_protectCommandErrorsWhenTargetDoesNotExist + , testProperty "protect command errors when caller is dead" prop_protectCommandErrorsWhenCallerIsDead + , testProperty "protect command errors when target is dead" prop_protectCommandErrorsWhenTargetIsDead + , testProperty "protect command errors when not defender's turn" prop_protectCommandErrorsWhenNotDefendersTurn + , testProperty "protect command errors when caller not defender" prop_protectCommandErrorsWhenCallerNotDefender + , testProperty "protect command errors when target is caller" prop_protectCommandErrorsWhenTargetIsCaller + , testProperty "protect command errors when target is prior protect" prop_protectCommandErrorsWhenTargetIsPriorProtect + , testProperty "protect command sets prior protect" prop_protectCommandSetsPriorProtect + , testProperty "protect command sets protect" prop_protectCommandSetsProtect - testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver, - testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist, - testProperty "see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist, - testProperty "see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead, - testProperty "see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead, - testProperty "see command errors when not seer's turn" prop_seeCommandErrorsWhenNotSeersTurn, - testProperty "see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer, - testProperty "see command sets see" prop_seeCommandSetsSee + , testProperty "quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver + , testProperty "quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist + , testProperty "quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead + , testProperty "quit command kills player" prop_quitCommandKillsPlayer + , testProperty "quit command clears heal when caller is witch" prop_quitCommandClearsHealWhenCallerIsWitch + , testProperty "quit command clears heal used when caller is witch" prop_quitCommandClearsHealUsedWhenCallerIsWitch + , testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonWhenCallerIsWitch + , testProperty "quit command clears poison used when caller is witch" prop_quitCommandClearsPoisonUsedWhenCallerIsWitch + , testProperty "quit command clears prior protect when caller is defender" prop_quitCommandClearsPriorProtectWhenCallerIsDefender + , testProperty "quit command clears protect when caller is defender" prop_quitCommandClearsProtectWhenCallerIsDefender + , testProperty "quit command clears player's devour vote" prop_quitCommandClearsPlayersDevourVote + , testProperty "quit command clears player's lynch vote" prop_quitCommandClearsPlayersLynchVote + + , testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver + , testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist + , testProperty "see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist + , testProperty "see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead + , testProperty "see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead + , testProperty "see command errors when not seer's turn" prop_seeCommandErrorsWhenNotSeersTurn + , testProperty "see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer + , testProperty "see command sets see" prop_seeCommandSetsSee ] allEngineTests :: [TestTree] -allEngineTests = [ - testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer, - testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch, - testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver, +allEngineTests = + [ testProperty "check stage skips defender's turn when no defender" prop_checkStageSkipsDefendersTurnWhenNoDefender + , testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer + , testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch + , testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver - testProperty "check seer's turn advances to werewolves' turn" prop_checkSeersTurnAdvancesToWerewolvesTurn, - testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee, - testProperty "check seer's turn does nothing unless seen" prop_checkSeersTurnDoesNothingUnlessSeen, + , testProperty "check defender's turn advances to werewolves' turn" prop_checkDefendersTurnAdvancesToWerewolvesTurn - testProperty "check villages' turn advances to seer's turn" prop_checkVillagesTurnAdvancesToSeersTurn, - testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus, - 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 does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted, + , testProperty "check seer's turn advances to defender's turn" prop_checkSeersTurnAdvancesToDefendersTurn + , testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee + , testProperty "check seer's turn does nothing unless seen" prop_checkSeersTurnDoesNothingUnlessSeen - testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn, - testProperty "check werewolves' turn doesn't skip witch's turn when witch devoured" prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured, - testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned, - testProperty "check werewolves' turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus, - testProperty "check werewolves' turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted, - testProperty "check werewolves' turn resets votes" prop_checkWerewolvesTurnResetsVotes, - testProperty "check werewolves' turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, + , testProperty "check villages' turn advances to seer's turn" prop_checkVillagesTurnAdvancesToSeersTurn + , testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus + , 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 does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted - testProperty "check witch's turn advances to villages' turn" prop_checkWitchsTurnAdvancesToVillagesTurn, - testProperty "check witch's turn heals devouree when healed" prop_checkWitchsTurnHealsDevoureeWhenHealed, - testProperty "check witch's turn kills one player when poisoned" prop_checkWitchsTurnKillsOnePlayerWhenPoisoned, - testProperty "check witch's turn does nothing when passed" prop_checkWitchsTurnDoesNothingWhenPassed, - testProperty "check witch's turn resets heal" prop_checkWitchsTurnResetsHeal, - testProperty "check witch's turn resets poison" prop_checkWitchsTurnResetsPoison, + , testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn + , testProperty "check werewolves' turn doesn't skip witch's turn when witch devoured" prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured + , testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned + , testProperty "check werewolves' turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus + , testProperty "check werewolves' turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted + , testProperty "check werewolves' turn kills no one when target defended" prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended + , testProperty "check werewolves' turn resets protect" prop_checkWerewolvesTurnResetsProtect + , testProperty "check werewolves' turn resets votes" prop_checkWerewolvesTurnResetsVotes + , testProperty "check werewolves' turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted - testProperty "check game over advances stage" prop_checkGameOverAdvancesStage, - testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive, + , testProperty "check witch's turn advances to villages' turn" prop_checkWitchsTurnAdvancesToVillagesTurn + , testProperty "check witch's turn heals devouree when healed" prop_checkWitchsTurnHealsDevoureeWhenHealed + , testProperty "check witch's turn kills one player when poisoned" prop_checkWitchsTurnKillsOnePlayerWhenPoisoned + , testProperty "check witch's turn does nothing when passed" prop_checkWitchsTurnDoesNothingWhenPassed + , testProperty "check witch's turn resets heal" prop_checkWitchsTurnResetsHeal + , testProperty "check witch's turn resets poison" prop_checkWitchsTurnResetsPoison - testProperty "start game starts with sunset stage" prop_startGameStartsWithSunsetStage, - testProperty "start game uses given players" prop_startGameUsesGivenPlayers, - testProperty "start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames, - testProperty "start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players, - testProperty "start game errors when more than 24 players" prop_startGameErrorsWhenMoreThan24Players, - testProperty "start game errors when more than 1 scapegoat" prop_startGameErrorsWhenMoreThan1Scapegoat, - testProperty "start game errors when more than 1 seer" prop_startGameErrorsWhenMoreThan1Seer, - testProperty "start game errors when more than 1 villager-villager" prop_startGameErrorsWhenMoreThan1VillagerVillager, - testProperty "start game errors when more than 1 witch" prop_startGameErrorsWhenMoreThan1Witch, + , testProperty "check game over advances stage" prop_checkGameOverAdvancesStage + , testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive - testProperty "create players uses given player names" prop_createPlayersUsesGivenPlayerNames, - testProperty "create players uses given roles" prop_createPlayersUsesGivenRoles, - testProperty "create players creates alive players" prop_createPlayersCreatesAlivePlayers, + , testProperty "start game starts with sunset stage" prop_startGameStartsWithSunsetStage + , testProperty "start game uses given players" prop_startGameUsesGivenPlayers + , testProperty "start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames + , testProperty "start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players + , testProperty "start game errors when more than 24 players" prop_startGameErrorsWhenMoreThan24Players + , testProperty "start game errors when more than 1 defender" prop_startGameErrorsWhenMoreThan1Defender + , testProperty "start game errors when more than 1 scapegoat" prop_startGameErrorsWhenMoreThan1Scapegoat + , testProperty "start game errors when more than 1 seer" prop_startGameErrorsWhenMoreThan1Seer + , testProperty "start game errors when more than 1 villager-villager" prop_startGameErrorsWhenMoreThan1VillagerVillager + , testProperty "start game errors when more than 1 witch" prop_startGameErrorsWhenMoreThan1Witch - testProperty "randomise roles returns n roles" prop_randomiseRolesReturnsNRoles, - testProperty "randomise roles uses given roles" prop_randomiseRolesUsesGivenRoles, - testProperty "randomise roles proportions allegiances" prop_randomiseRolesProportionsAllegiances + , testProperty "create players uses given player names" prop_createPlayersUsesGivenPlayerNames + , testProperty "create players uses given roles" prop_createPlayersUsesGivenRoles + , testProperty "create players creates alive players" prop_createPlayersCreatesAlivePlayers + + , testProperty "randomise roles returns n roles" prop_randomiseRolesReturnsNRoles + , testProperty "randomise roles uses given roles" prop_randomiseRolesUsesGivenRoles + , testProperty "randomise roles proportions allegiances" prop_randomiseRolesProportionsAllegiances ] allGameTests :: [TestTree] -allGameTests = [ - testProperty "new game starts with sunset stage" prop_newGameStartsWithSunsetStage, - 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 no poison" prop_newGameStartsWithNoPoison, - testProperty "new game starts with no poison used" prop_newGameStartsWithNoPoisonUsed, - testProperty "new game starts with no see" prop_newGameStartsWithNoSee, - testProperty "new game starts with votes empty" prop_newGameStartsWithVotesEmpty, - testProperty "new game uses given players" prop_newGameUsesGivenPlayers +allGameTests = + [ testProperty "new game starts with sunset stage" prop_newGameStartsWithSunsetStage + , 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 no poison" prop_newGameStartsWithNoPoison + , testProperty "new game starts with no poison used" prop_newGameStartsWithNoPoisonUsed + , testProperty "new game starts with no prior protect" prop_newGameStartsWithNoPriorProtect + , testProperty "new game starts with no protect" prop_newGameStartsWithNoProtect + , testProperty "new game starts with no see" prop_newGameStartsWithNoSee + , testProperty "new game starts with votes empty" prop_newGameStartsWithVotesEmpty + , testProperty "new game uses given players" prop_newGameUsesGivenPlayers ] allPlayerTests :: [TestTree] -allPlayerTests = [ - testProperty "new player is alive" prop_newPlayerIsAlive +allPlayerTests = + [ testProperty "new player is alive" prop_newPlayerIsAlive ] diff --git a/test/src/Game/Werewolf/Test/Arbitrary.hs b/test/src/Game/Werewolf/Test/Arbitrary.hs --- a/test/src/Game/Werewolf/Test/Arbitrary.hs +++ b/test/src/Game/Werewolf/Test/Arbitrary.hs @@ -9,41 +9,115 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Game.Werewolf.Test.Arbitrary ( + -- * Initial arbitraries + + -- ** Game + arbitraryNewGame, arbitraryGameWithDevourVotes, arbitraryGameWithDevourEventForVillager, + arbitraryGameWithProtect, arbitraryGameWithProtectAndDevourVotes, + + -- ** Player + arbitraryPlayerSet, + -- * Contextual arbitraries + + -- ** Command arbitraryCommand, arbitraryDevourVoteCommand, arbitraryHealCommand, arbitraryLynchVoteCommand, - arbitraryPassCommand, arbitraryPoisonCommand, arbitraryQuitCommand, arbitrarySeeCommand, - arbitraryNewGame, arbitraryPlayer, arbitraryPlayerSet, arbitraryScapegoat, arbitrarySeer, - arbitraryVillager, arbitraryWerewolf, arbitraryWitch, + arbitraryPassCommand, arbitraryPoisonCommand, arbitraryProtectCommand, arbitraryQuitCommand, + arbitrarySeeCommand, runArbitraryCommands, - -- * Utility functions - run, run_, runArbitraryCommands, + -- ** Player + arbitraryPlayer, arbitraryDefender, arbitrarySeer, arbitraryWerewolf, arbitraryWitch, ) where -import Control.Lens hiding (elements) -import Control.Monad.Except -import Control.Monad.State hiding (State) -import Control.Monad.Writer +import Control.Lens hiding (elements) -import Data.Either.Extra import Data.List.Extra import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T +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.Response -import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Test.Util import Test.QuickCheck instance Show Command where show _ = "command" +instance Arbitrary Game where + arbitrary = do + game <- arbitraryNewGame + stage <- arbitrary + + return $ game { _stage = stage } + +instance Arbitrary Stage where + arbitrary = elements + [GameOver, DefendersTurn, SeersTurn, VillagesTurn, WerewolvesTurn, WitchsTurn] + +instance Arbitrary Player where + arbitrary = newPlayer <$> arbitrary <*> arbitrary + +instance Arbitrary State where + arbitrary = elements [Alive, Dead] + +instance Arbitrary Role where + arbitrary = elements allRoles + +instance Arbitrary Text where + arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) + +arbitraryNewGame :: Gen Game +arbitraryNewGame = newGame <$> arbitraryPlayerSet + +arbitraryGameWithDevourVotes :: Gen Game +arbitraryGameWithDevourVotes = arbitrary >>= runArbitraryDevourVoteCommands + +arbitraryGameWithDevourEvent :: Gen Game +arbitraryGameWithDevourEvent = do + game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) == 1 + + return $ run_ checkStage game + +arbitraryGameWithDevourEventForVillager :: Gen Game +arbitraryGameWithDevourEventForVillager = + suchThat arbitraryGameWithDevourEvent $ \game -> all isVillager (filterDead $ game ^. players) + +arbitraryGameWithProtect :: Gen Game +arbitraryGameWithProtect = do + game <- arbitrary + let game' = game { _stage = DefendersTurn } + command <- arbitraryProtectCommand game' + + return $ run_ (apply command) game' + +arbitraryGameWithProtectAndDevourVotes :: Gen Game +arbitraryGameWithProtectAndDevourVotes = arbitraryGameWithProtect >>= runArbitraryDevourVoteCommands + +arbitraryPlayerSet :: Gen [Player] +arbitraryPlayerSet = do + n <- choose (10, 24) + players <- nubOn _name <$> infiniteList + + let defender = head $ filterDefenders players + let scapegoat = head $ filterScapegoats players + let seer = head $ filterSeers players + let villagerVillager = head $ filterVillagerVillagers players + let witch = head $ filterWitches players + + let werewolves = take (n `quot` 6 + 1) $ filterWerewolves players + let villagers = take (n - 5 - (length werewolves)) $ filterVillagers players + + return $ defender:scapegoat:seer:villagerVillager:witch:werewolves ++ villagers + arbitraryCommand :: Game -> Gen Command arbitraryCommand game = case game ^. stage of GameOver -> return noopCommand + DefendersTurn -> arbitraryProtectCommand game Sunrise -> return noopCommand Sunset -> return noopCommand SeersTurn -> arbitrarySeeCommand game @@ -62,7 +136,8 @@ if null applicableCallers then return noopCommand - else elements applicableCallers >>= \caller -> return $ devourVoteCommand (caller ^. name) (target ^. name) + else elements applicableCallers >>= \caller -> + return $ devourVoteCommand (caller ^. name) (target ^. name) arbitraryLynchVoteCommand :: Game -> Gen Command arbitraryLynchVoteCommand game = do @@ -71,15 +146,16 @@ if null applicableCallers then return noopCommand - else elements applicableCallers >>= \caller -> return $ lynchVoteCommand (caller ^. name) (target ^. name) + else elements applicableCallers >>= \caller -> + return $ lynchVoteCommand (caller ^. name) (target ^. name) arbitraryHealCommand :: Game -> Gen Command arbitraryHealCommand game = do - let witchName = (head . filterWitches $ game ^. players) ^. name + let witch = head . filterWitches $ game ^. players return $ if game ^. healUsed then noopCommand - else seq (fromJust (getDevourEvent game)) $ healCommand witchName + else seq (fromJust (getDevourEvent game)) $ healCommand (witch ^. name) arbitraryPassCommand :: Game -> Gen Command arbitraryPassCommand game = do @@ -96,6 +172,15 @@ then noopCommand else poisonCommand (witch ^. name) (target ^. name) +arbitraryProtectCommand :: Game -> Gen Command +arbitraryProtectCommand game = do + let defender = head . filterDefenders $ game ^. players + target <- suchThat (arbitraryPlayer game) (defender /=) + + return $ if isJust (game ^. protect) + then noopCommand + else protectCommand (defender ^. name) (target ^. name) + arbitraryQuitCommand :: Game -> Gen Command arbitraryQuitCommand game = do let applicableCallers = filterAlive $ game ^. players @@ -113,76 +198,34 @@ then noopCommand else seeCommand (seer ^. name) (target ^. name) -instance Arbitrary Game where - arbitrary = do - game <- arbitraryNewGame - stage <- arbitrary +runArbitraryCommands :: Int -> Game -> Gen Game +runArbitraryCommands n = iterateM n $ \game -> do + command <- arbitraryCommand game - return $ game { _stage = stage } + return $ run_ (apply command) game -arbitraryNewGame :: Gen Game -arbitraryNewGame = newGame <$> arbitraryPlayerSet +runArbitraryDevourVoteCommands :: Game -> Gen Game +runArbitraryDevourVoteCommands game = do + let game' = game { _stage = WerewolvesTurn } + let n = length . filterWerewolves $ game' ^. players -instance Arbitrary Stage where - arbitrary = elements [GameOver, SeersTurn, VillagesTurn, WerewolvesTurn, WitchsTurn] + runArbitraryCommands n game' -instance Arbitrary Player where - arbitrary = newPlayer <$> arbitrary <*> arbitrary +iterateM :: Monad m => Int -> (a -> m a) -> a -> m a +iterateM 0 _ a = return a +iterateM n f a = f a >>= iterateM (n - 1) f arbitraryPlayer :: Game -> Gen Player arbitraryPlayer = elements . filterAlive . _players -arbitraryPlayerSet :: Gen [Player] -arbitraryPlayerSet = do - n <- choose (7, 24) - players <- nubOn _name <$> infiniteList - - let scapegoat = head $ filterScapegoats players - let seer = head $ filterSeers players - let villagerVillager = head $ filterVillagerVillagers players - let witch = head $ filterWitches players - - let werewolves = take (n `quot` 6 + 1) $ filterWerewolves players - let villagers = take (n - 4 - (length werewolves)) $ filterVillagers players - - return $ scapegoat:seer:villagerVillager:witch:werewolves ++ villagers - -arbitraryScapegoat :: Game -> Gen Player -arbitraryScapegoat = elements . filterAlive . filterScapegoats . _players +arbitraryDefender :: Game -> Gen Player +arbitraryDefender = elements . filterAlive . filterDefenders . _players arbitrarySeer :: Game -> Gen Player arbitrarySeer = elements . filterAlive . filterSeers . _players -arbitraryVillager :: Game -> Gen Player -arbitraryVillager = elements . filterAlive . filterVillagers . _players - arbitraryWerewolf :: Game -> Gen Player arbitraryWerewolf = elements . filterAlive . filterWerewolves . _players arbitraryWitch :: Game -> Gen Player arbitraryWitch = elements . filterAlive . filterWitches . _players - -instance Arbitrary State where - arbitrary = elements [Alive, Dead] - -instance Arbitrary Role where - arbitrary = elements allRoles - -instance Arbitrary Text where - arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) - -run :: StateT Game (WriterT [Message] (Except [Message])) a -> Game -> Either [Message] (Game, [Message]) -run action game = runExcept . runWriterT $ execStateT action game - -run_ :: StateT Game (WriterT [Message] (Except [Message])) a -> Game -> Game -run_ action = fst . fromRight . run action - -runArbitraryCommands :: Int -> Game -> Gen Game -runArbitraryCommands n = iterateM n $ \game -> do - command <- arbitraryCommand game - - return $ run_ (apply command) game - -iterateM :: Monad m => Int -> (a -> m a) -> a -> m a -iterateM 0 _ a = return a -iterateM n f a = f a >>= iterateM (n - 1) f diff --git a/test/src/Game/Werewolf/Test/Command.hs b/test/src/Game/Werewolf/Test/Command.hs --- a/test/src/Game/Werewolf/Test/Command.hs +++ b/test/src/Game/Werewolf/Test/Command.hs @@ -43,12 +43,22 @@ prop_poisonCommandErrorsWhenCallerNotWitch, prop_poisonCommandSetsPoison, prop_poisonCommandSetsPoisonUsed, + -- * protectCommand + prop_protectCommandErrorsWhenGameIsOver, prop_protectCommandErrorsWhenCallerDoesNotExist, + prop_protectCommandErrorsWhenTargetDoesNotExist, prop_protectCommandErrorsWhenCallerIsDead, + prop_protectCommandErrorsWhenTargetIsDead, prop_protectCommandErrorsWhenNotDefendersTurn, + prop_protectCommandErrorsWhenCallerNotDefender, prop_protectCommandErrorsWhenTargetIsCaller, + prop_protectCommandErrorsWhenTargetIsPriorProtect, prop_protectCommandSetsPriorProtect, + prop_protectCommandSetsProtect, + -- * quitCommand prop_quitCommandErrorsWhenGameIsOver, prop_quitCommandErrorsWhenCallerDoesNotExist, prop_quitCommandErrorsWhenCallerIsDead, prop_quitCommandKillsPlayer, prop_quitCommandClearsHealWhenCallerIsWitch, prop_quitCommandClearsHealUsedWhenCallerIsWitch, prop_quitCommandClearsPoisonWhenCallerIsWitch, - prop_quitCommandClearsPoisonUsedWhenCallerIsWitch, prop_quitCommandClearsPlayersDevourVote, + prop_quitCommandClearsPoisonUsedWhenCallerIsWitch, + prop_quitCommandClearsPriorProtectWhenCallerIsDefender, + prop_quitCommandClearsProtectWhenCallerIsDefender, prop_quitCommandClearsPlayersDevourVote, prop_quitCommandClearsPlayersLynchVote, -- * seeCommand @@ -69,6 +79,7 @@ import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Test.Arbitrary +import Game.Werewolf.Test.Util import Test.QuickCheck @@ -93,15 +104,21 @@ prop_devourVoteCommandErrorsWhenCallerIsDead :: Game -> Property prop_devourVoteCommandErrorsWhenCallerIsDead game = forAll (arbitraryWerewolf game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game caller) (devourVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game caller + let command = devourVoteCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_devourVoteCommandErrorsWhenTargetIsDead :: Game -> Property prop_devourVoteCommandErrorsWhenTargetIsDead game = forAll (arbitraryWerewolf game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game target) (devourVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game target + let command = devourVoteCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_devourVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property prop_devourVoteCommandErrorsWhenNotWerewolvesTurn game = not (isWerewolvesTurn game) @@ -116,9 +133,11 @@ prop_devourVoteCommandErrorsWhenCallerHasVoted :: Game -> Property prop_devourVoteCommandErrorsWhenCallerHasVoted game = forAll (arbitraryWerewolf game') $ \caller -> - forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target -> - let command = devourVoteCommand (caller ^. name) (target ^. name) - in verbose_runCommandErrors (run_ (apply command) game') command + forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target -> do + let command = devourVoteCommand (caller ^. name) (target ^. name) + let game'' = run_ (apply command) game' + + verbose_runCommandErrors game'' command where game' = game { _stage = WerewolvesTurn } @@ -130,8 +149,10 @@ prop_devourVoteCommandUpdatesVotes :: Game -> Property prop_devourVoteCommandUpdatesVotes game = - forAll (arbitraryDevourVoteCommand game') $ \command -> - Map.size (run_ (apply command) game' ^. votes) == 1 + forAll (arbitraryDevourVoteCommand game') $ \command -> do + let game'' = run_ (apply command) game' + + Map.size (game'' ^. votes) == 1 where game' = game { _stage = WerewolvesTurn } @@ -149,9 +170,12 @@ prop_healCommandErrorsWhenCallerIsDead :: Game -> Property prop_healCommandErrorsWhenCallerIsDead game = - forAll (arbitraryPlayer game) $ \caller -> - verbose_runCommandErrors (killPlayer game caller) (healCommand (caller ^. name)) + forAll (arbitraryPlayer game) $ \caller -> do + let game' = killPlayer game caller + let command = healCommand (caller ^. name) + verbose_runCommandErrors game' command + prop_healCommandErrorsWhenNoTargetIsDevoured :: Game -> Property prop_healCommandErrorsWhenNoTargetIsDevoured game = forAll (arbitraryWitch game) $ \witch -> @@ -163,50 +187,34 @@ ==> forAll (arbitraryWitch game) $ \witch -> verbose_runCommandErrors game (healCommand $ witch ^. name) -prop_healCommandErrorsWhenCallerHasHealed :: Game -> Property -prop_healCommandErrorsWhenCallerHasHealed game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> let game''' = run_ checkStage game'' - in forAll (arbitraryHealCommand game''') $ \command -> - run_ (apply command) game''' ^. heal - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_healCommandErrorsWhenCallerHasHealed :: Gen Property +prop_healCommandErrorsWhenCallerHasHealed = do + game <- arbitraryGameWithDevourEventForVillager + return $ forAll (arbitraryHealCommand game) $ \command -> do + let game' = run_ (apply command) game + + verbose_runCommandErrors game' command + prop_healCommandErrorsWhenCallerNotWitch :: Game -> Property prop_healCommandErrorsWhenCallerNotWitch game = forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller -> verbose_runCommandErrors game (healCommand (caller ^. name)) -prop_healCommandSetsHeal :: Game -> Property -prop_healCommandSetsHeal game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> let game''' = run_ checkStage game'' - in forAll (arbitraryHealCommand game''') $ \command -> - run_ (apply command) game''' ^. heal - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_healCommandSetsHeal :: Gen Property +prop_healCommandSetsHeal = do + game <- arbitraryGameWithDevourEventForVillager -prop_healCommandSetsHealUsed :: Game -> Property -prop_healCommandSetsHealUsed game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> let game''' = run_ checkStage game'' - in forAll (arbitraryHealCommand game''') $ \command -> - run_ (apply command) game''' ^. heal - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players + return $ forAll (arbitraryHealCommand game) $ \command -> + (run_ (apply command) game) ^. heal +prop_healCommandSetsHealUsed :: Gen Property +prop_healCommandSetsHealUsed = do + game <- arbitraryGameWithDevourEventForVillager + + return $ forAll (arbitraryHealCommand game) $ \command -> + (run_ (apply command) game) ^. healUsed + prop_lynchVoteCommandErrorsWhenGameIsOver :: Game -> Property prop_lynchVoteCommandErrorsWhenGameIsOver game = forAll (arbitraryLynchVoteCommand game') $ verbose_runCommandErrors game' @@ -228,15 +236,21 @@ prop_lynchVoteCommandErrorsWhenCallerIsDead :: Game -> Property prop_lynchVoteCommandErrorsWhenCallerIsDead game = forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game caller) (lynchVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game caller + let command = lynchVoteCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_lynchVoteCommandErrorsWhenTargetIsDead :: Game -> Property prop_lynchVoteCommandErrorsWhenTargetIsDead game = forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game target) (lynchVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game target + let command = lynchVoteCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_lynchVoteCommandErrorsWhenNotVillagesTurn :: Game -> Property prop_lynchVoteCommandErrorsWhenNotVillagesTurn game = not (isVillagesTurn game) @@ -245,16 +259,20 @@ prop_lynchVoteCommandErrorsWhenCallerHasVoted :: Game -> Property prop_lynchVoteCommandErrorsWhenCallerHasVoted game = forAll (arbitraryPlayer game') $ \caller -> - forAll (arbitraryPlayer game') $ \target -> - let command = lynchVoteCommand (caller ^. name) (target ^. name) - in verbose_runCommandErrors (run_ (apply command) game') command + forAll (arbitraryPlayer game') $ \target -> do + let command = lynchVoteCommand (caller ^. name) (target ^. name) + let game'' = run_ (apply command) game' + + verbose_runCommandErrors game'' command where game' = game { _stage = VillagesTurn } prop_lynchVoteCommandUpdatesVotes :: Game -> Property prop_lynchVoteCommandUpdatesVotes game = - forAll (arbitraryLynchVoteCommand game') $ \command -> - Map.size (run_ (apply command) game' ^. votes) == 1 + forAll (arbitraryLynchVoteCommand game') $ \command -> do + let game'' = run_ (apply command) game' + + Map.size (game'' ^. votes) == 1 where game' = game { _stage = VillagesTurn } @@ -271,9 +289,12 @@ prop_passCommandErrorsWhenCallerIsDead :: Game -> Property prop_passCommandErrorsWhenCallerIsDead game = - forAll (arbitraryPlayer game) $ \caller -> - verbose_runCommandErrors (killPlayer game caller) (passCommand (caller ^. name)) + forAll (arbitraryPlayer game) $ \caller -> do + let game' = killPlayer game caller + let command = passCommand (caller ^. name) + verbose_runCommandErrors game' command + prop_passCommandErrorsWhenNotWitchsTurn :: Game -> Property prop_passCommandErrorsWhenNotWitchsTurn game = not (isWitchsTurn game) @@ -281,8 +302,10 @@ prop_passCommandUpdatesPasses :: Game -> Property prop_passCommandUpdatesPasses game = - forAll (arbitraryPassCommand game') $ \command -> - length (run_ (apply command) game' ^. passes) == 1 + forAll (arbitraryPassCommand game') $ \command -> do + let game'' = run_ (apply command) game' + + length (game'' ^. passes) == 1 where game' = game { _stage = WitchsTurn } @@ -307,15 +330,21 @@ prop_poisonCommandErrorsWhenCallerIsDead :: Game -> Property prop_poisonCommandErrorsWhenCallerIsDead game = forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game caller) (poisonCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game caller + let command = poisonCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_poisonCommandErrorsWhenTargetIsDead :: Game -> Property prop_poisonCommandErrorsWhenTargetIsDead game = forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game target) (poisonCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game target + let command = poisonCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_poisonCommandErrorsWhenTargetIsDevoured :: Game -> Property prop_poisonCommandErrorsWhenTargetIsDevoured game = forAll (runArbitraryCommands n game') $ \game'' -> @@ -362,6 +391,90 @@ where game' = game { _stage = WitchsTurn } +prop_protectCommandErrorsWhenGameIsOver :: Game -> Property +prop_protectCommandErrorsWhenGameIsOver game = + forAll (arbitraryProtectCommand game') $ verbose_runCommandErrors game' + where + game' = game { _stage = GameOver } + +prop_protectCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property +prop_protectCommandErrorsWhenCallerDoesNotExist game caller = + not (doesPlayerExist (caller ^. name) (game ^. players)) + ==> forAll (arbitraryPlayer game) $ \target -> do + let command = protectCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game command + +prop_protectCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property +prop_protectCommandErrorsWhenTargetDoesNotExist game target = + not (doesPlayerExist (target ^. name) (game ^. players)) + ==> forAll (arbitraryDefender game) $ \caller -> do + let command = protectCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game command + +prop_protectCommandErrorsWhenCallerIsDead :: Game -> Property +prop_protectCommandErrorsWhenCallerIsDead game = + forAll (arbitraryDefender game) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game caller + let command = protectCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game' command + +prop_protectCommandErrorsWhenTargetIsDead :: Game -> Property +prop_protectCommandErrorsWhenTargetIsDead game = + forAll (arbitraryDefender game) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game target + let command = protectCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game' command + +prop_protectCommandErrorsWhenNotDefendersTurn :: Game -> Property +prop_protectCommandErrorsWhenNotDefendersTurn game = + not (isDefendersTurn game) + ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game + +prop_protectCommandErrorsWhenCallerNotDefender :: Game -> Property +prop_protectCommandErrorsWhenCallerNotDefender game = + forAll (suchThat (arbitraryPlayer game) (not . isDefender)) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> do + let command = protectCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game command + +prop_protectCommandErrorsWhenTargetIsCaller :: Game -> Property +prop_protectCommandErrorsWhenTargetIsCaller game = + forAll (arbitraryDefender game) $ \caller -> do + let command = protectCommand (caller ^. name) (caller ^. name) + + verbose_runCommandErrors game command + +prop_protectCommandErrorsWhenTargetIsPriorProtect :: Gen Property +prop_protectCommandErrorsWhenTargetIsPriorProtect = do + game <- arbitraryGameWithProtect + let game' = game { _protect = Nothing } + + return $ forAll (arbitraryDefender game') $ \caller -> do + let command = protectCommand (caller ^. name) (fromJust $ game' ^. priorProtect) + + verbose_runCommandErrors game' command + +prop_protectCommandSetsPriorProtect :: Game -> Property +prop_protectCommandSetsPriorProtect game = + forAll (arbitraryProtectCommand game') $ \command -> + isJust $ run_ (apply command) game' ^. priorProtect + where + game' = game { _stage = DefendersTurn } + +prop_protectCommandSetsProtect :: Game -> Property +prop_protectCommandSetsProtect game = + forAll (arbitraryProtectCommand game') $ \command -> + isJust $ run_ (apply command) game' ^. protect + where + game' = game { _stage = DefendersTurn } + prop_quitCommandErrorsWhenGameIsOver :: Game -> Property prop_quitCommandErrorsWhenGameIsOver game = forAll (arbitraryQuitCommand game') $ verbose_runCommandErrors game' @@ -421,6 +534,28 @@ where game' = game { _stage = WitchsTurn } +prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: Game -> Property +prop_quitCommandClearsPriorProtectWhenCallerIsDefender game = + forAll (arbitraryDefender game') $ \caller -> + forAll (suchThat (arbitraryPlayer game') (not . isDefender)) $ \target -> do + let command = protectCommand (caller ^. name) (target ^. name) + let game'' = run_ (apply command) game' + + isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. priorProtect + where + game' = game { _stage = DefendersTurn } + +prop_quitCommandClearsProtectWhenCallerIsDefender :: Game -> Property +prop_quitCommandClearsProtectWhenCallerIsDefender game = + forAll (arbitraryDefender game') $ \caller -> + forAll (suchThat (arbitraryPlayer game') (not . isDefender)) $ \target -> do + let command = protectCommand (caller ^. name) (target ^. name) + let game'' = run_ (apply command) game' + + isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. protect + where + game' = game { _stage = DefendersTurn } + prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: Game -> Property prop_quitCommandClearsPoisonUsedWhenCallerIsWitch game = forAll (arbitraryWitch game') $ \caller -> @@ -457,27 +592,37 @@ prop_seeCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_seeCommandErrorsWhenCallerDoesNotExist game caller = not (doesPlayerExist (caller ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitraryPlayer game) $ \target -> do + let command = seeCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game command + prop_seeCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property prop_seeCommandErrorsWhenTargetDoesNotExist game target = not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitrarySeer game) $ \caller -> - verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitrarySeer game) $ \caller -> do + let command = seeCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game command + prop_seeCommandErrorsWhenCallerIsDead :: Game -> Property prop_seeCommandErrorsWhenCallerIsDead game = forAll (arbitrarySeer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game caller) (seeCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game caller + let command = seeCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_seeCommandErrorsWhenTargetIsDead :: Game -> Property prop_seeCommandErrorsWhenTargetIsDead game = forAll (arbitrarySeer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors (killPlayer game target) (seeCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let game' = killPlayer game target + let command = seeCommand (caller ^. name) (target ^. name) + verbose_runCommandErrors game' command + prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property prop_seeCommandErrorsWhenNotSeersTurn game = not (isSeersTurn game) @@ -486,8 +631,10 @@ prop_seeCommandErrorsWhenCallerNotSeer :: Game -> Property prop_seeCommandErrorsWhenCallerNotSeer game = forAll (suchThat (arbitraryPlayer game) (not . isSeer)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let command = seeCommand (caller ^. name) (target ^. name) + + verbose_runCommandErrors game command prop_seeCommandSetsSee :: Game -> Property prop_seeCommandSetsSee game = diff --git a/test/src/Game/Werewolf/Test/Engine.hs b/test/src/Game/Werewolf/Test/Engine.hs --- a/test/src/Game/Werewolf/Test/Engine.hs +++ b/test/src/Game/Werewolf/Test/Engine.hs @@ -10,10 +10,12 @@ module Game.Werewolf.Test.Engine ( -- * checkStage - prop_checkStageSkipsSeersTurnWhenNoSeer, prop_checkStageSkipsWitchsTurnWhenNoWitch, - prop_checkStageDoesNothingWhenGameOver, + prop_checkStageSkipsDefendersTurnWhenNoDefender, prop_checkStageSkipsSeersTurnWhenNoSeer, + prop_checkStageSkipsWitchsTurnWhenNoWitch, prop_checkStageDoesNothingWhenGameOver, - prop_checkSeersTurnAdvancesToWerewolvesTurn, prop_checkSeersTurnResetsSee, + prop_checkDefendersTurnAdvancesToWerewolvesTurn, + + prop_checkSeersTurnAdvancesToDefendersTurn, prop_checkSeersTurnResetsSee, prop_checkSeersTurnDoesNothingUnlessSeen, prop_checkVillagesTurnAdvancesToSeersTurn, prop_checkVillagesTurnLynchesOnePlayerWhenConsensus, @@ -25,8 +27,9 @@ prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured, prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned, prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus, - prop_checkWerewolvesTurnKillsNoOneWhenConflicted, prop_checkWerewolvesTurnResetsVotes, - prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, + prop_checkWerewolvesTurnKillsNoOneWhenConflicted, + prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended, prop_checkWerewolvesTurnResetsProtect, + prop_checkWerewolvesTurnResetsVotes, prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, prop_checkWitchsTurnAdvancesToVillagesTurn, prop_checkWitchsTurnHealsDevoureeWhenHealed, prop_checkWitchsTurnKillsOnePlayerWhenPoisoned, prop_checkWitchsTurnDoesNothingWhenPassed, @@ -38,9 +41,9 @@ -- * startGame prop_startGameStartsWithSunsetStage, prop_startGameUsesGivenPlayers, prop_startGameErrorsUnlessUniquePlayerNames, prop_startGameErrorsWhenLessThan7Players, - prop_startGameErrorsWhenMoreThan24Players, prop_startGameErrorsWhenMoreThan1Scapegoat, - prop_startGameErrorsWhenMoreThan1Seer, prop_startGameErrorsWhenMoreThan1VillagerVillager, - prop_startGameErrorsWhenMoreThan1Witch, + prop_startGameErrorsWhenMoreThan24Players, prop_startGameErrorsWhenMoreThan1Defender, + prop_startGameErrorsWhenMoreThan1Scapegoat, prop_startGameErrorsWhenMoreThan1Seer, + prop_startGameErrorsWhenMoreThan1VillagerVillager, prop_startGameErrorsWhenMoreThan1Witch, -- * createPlayers prop_createPlayersUsesGivenPlayerNames, prop_createPlayersUsesGivenRoles, @@ -63,22 +66,30 @@ import Game.Werewolf.Command import Game.Werewolf.Engine hiding (doesPlayerExist, getDevourEvent, - getVoteResult, isGameOver, isSeersTurn, - isVillagesTurn, isWerewolvesTurn, isWitchsTurn, - killPlayer) + getVoteResult, isDefendersTurn, isGameOver, + isSeersTurn, isVillagesTurn, isWerewolvesTurn, + isWitchsTurn, killPlayer) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Role hiding (name, _name) import qualified Game.Werewolf.Role as Role import Game.Werewolf.Test.Arbitrary +import Game.Werewolf.Test.Util import Test.QuickCheck import Test.QuickCheck.Monadic +prop_checkStageSkipsDefendersTurnWhenNoDefender :: Game -> Property +prop_checkStageSkipsDefendersTurnWhenNoDefender game = + forAll (arbitrarySeeCommand game') $ \command -> + not . isDefendersTurn $ run_ (apply command >> checkStage) game' + where + game' = (foldl killPlayer game (filterDefenders $ game ^. players)) { _stage = SeersTurn } + prop_checkStageSkipsSeersTurnWhenNoSeer :: Game -> Property prop_checkStageSkipsSeersTurnWhenNoSeer game = forAll (runArbitraryCommands n game') $ \game'' -> - isWerewolvesTurn $ run_ checkStage game'' + not . isSeersTurn $ run_ checkStage game'' where game' = (foldl killPlayer game (filterSeers $ game ^. players)) { _stage = VillagesTurn } n = length $ game' ^. players @@ -86,7 +97,7 @@ prop_checkStageSkipsWitchsTurnWhenNoWitch :: Game -> Property prop_checkStageSkipsWitchsTurnWhenNoWitch game = forAll (runArbitraryCommands n game') $ \game'' -> - isVillagesTurn $ run_ checkStage game'' + not . isWitchsTurn $ run_ checkStage game'' where game' = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn } n = length . filterWerewolves $ game' ^. players @@ -96,17 +107,24 @@ where game' = game { _stage = GameOver } -prop_checkSeersTurnAdvancesToWerewolvesTurn :: Game -> Property -prop_checkSeersTurnAdvancesToWerewolvesTurn game = +prop_checkDefendersTurnAdvancesToWerewolvesTurn :: Game -> Property +prop_checkDefendersTurnAdvancesToWerewolvesTurn game = + forAll (arbitraryProtectCommand game') $ \command -> + isWerewolvesTurn $ run_ (apply command >> checkStage) game' + where + game' = game { _stage = DefendersTurn } + +prop_checkSeersTurnAdvancesToDefendersTurn :: Game -> Property +prop_checkSeersTurnAdvancesToDefendersTurn game = forAll (arbitraryCommand game') $ \command -> - isWerewolvesTurn $ run_ checkStage (run_ (apply command) game') + isDefendersTurn $ run_ (apply command >> checkStage) game' where game' = game { _stage = SeersTurn } prop_checkSeersTurnResetsSee :: Game -> Property prop_checkSeersTurnResetsSee game = forAll (arbitraryCommand game') $ \command -> - isNothing $ run_ checkStage (run_ (apply command) game') ^. see + isNothing $ run_ (apply command >> checkStage) game' ^. see where game' = game { _stage = SeersTurn } @@ -203,15 +221,25 @@ game' = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn } n = length . filterWerewolves $ game' ^. players -prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: Game -> Property -prop_checkWerewolvesTurnKillsNoOneWhenConflicted game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') > 1 - ==> length (filterDead $ run_ checkStage game'' ^. players) == 0 - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: Gen Bool +prop_checkWerewolvesTurnKillsNoOneWhenConflicted = do + game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) > 1 + return . isNothing . getDevourEvent $ run_ checkStage game + +prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended :: Gen Bool +prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended = do + game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) == 1 + let game' = game { _protect = Just $ head (getVoteResult game) ^. name } + + return . isNothing . getDevourEvent $ run_ checkStage game' + +prop_checkWerewolvesTurnResetsProtect :: Gen Bool +prop_checkWerewolvesTurnResetsProtect = do + game <- arbitraryGameWithProtectAndDevourVotes + + return . isNothing $ run_ checkStage game ^. protect + prop_checkWerewolvesTurnResetsVotes :: Game -> Property prop_checkWerewolvesTurnResetsVotes game = forAll (runArbitraryCommands n game') $ \game'' -> @@ -231,7 +259,7 @@ prop_checkWitchsTurnAdvancesToVillagesTurn :: Game -> Property prop_checkWitchsTurnAdvancesToVillagesTurn game = forAll (arbitraryPassCommand game') $ \command -> - isVillagesTurn $ run_ checkStage (run_ (apply command) game') + isVillagesTurn $ run_ (apply command >> checkStage) game' where game' = game { _stage = WitchsTurn } @@ -256,14 +284,14 @@ prop_checkWitchsTurnKillsOnePlayerWhenPoisoned game = forAll (arbitraryPoisonCommand game') $ \command -> forAll (arbitraryPassCommand game') $ \passCommand -> - length (filterDead $ run_ checkStage (run_ (apply passCommand) $ run_ (apply command) game') ^. players) == 1 + length (filterDead $ run_ (apply command >> apply passCommand >> checkStage) game' ^. players) == 1 where game' = game { _stage = WitchsTurn } prop_checkWitchsTurnDoesNothingWhenPassed :: Game -> Property prop_checkWitchsTurnDoesNothingWhenPassed game = forAll (arbitraryPassCommand game') $ \command -> - null . filterDead $ run_ checkStage (run_ (apply command) game') ^. players + null . filterDead $ run_ (apply command >> checkStage) game' ^. players where game' = game { _stage = WitchsTurn } @@ -288,7 +316,7 @@ prop_checkWitchsTurnResetsPoison :: Game -> Property prop_checkWitchsTurnResetsPoison game = forAll (arbitraryPoisonCommand game') $ \command -> - isNothing $ run_ checkStage (run_ (apply command) game') ^. poison + isNothing $ run_ (apply command >> checkStage) game' ^. poison where game' = game { _stage = WitchsTurn } @@ -333,6 +361,11 @@ forAll (resize 30 $ listOf arbitrary) $ \players -> length players > 24 ==> isLeft (runExcept . runWriterT $ startGame "" players) + +prop_startGameErrorsWhenMoreThan1Defender :: [Player] -> Property +prop_startGameErrorsWhenMoreThan1Defender players = + length (filterDefenders players) > 1 + ==> isLeft (runExcept . runWriterT $ startGame "" players) prop_startGameErrorsWhenMoreThan1Scapegoat :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Scapegoat players = diff --git a/test/src/Game/Werewolf/Test/Game.hs b/test/src/Game/Werewolf/Test/Game.hs --- a/test/src/Game/Werewolf/Test/Game.hs +++ b/test/src/Game/Werewolf/Test/Game.hs @@ -11,7 +11,8 @@ prop_newGameStartsWithSunsetStage, prop_newGameStartsWithEventsEmpty, prop_newGameStartsWithPassesEmpty, prop_newGameStartsWithNoHeal, prop_newGameStartsWithNoHealUsed, prop_newGameStartsWithNoPoison, - prop_newGameStartsWithNoPoisonUsed, prop_newGameStartsWithNoSee, + prop_newGameStartsWithNoPoisonUsed, prop_newGameStartsWithNoPriorProtect, + prop_newGameStartsWithNoProtect, prop_newGameStartsWithNoSee, prop_newGameStartsWithVotesEmpty, prop_newGameUsesGivenPlayers, ) where @@ -43,6 +44,12 @@ prop_newGameStartsWithNoPoisonUsed :: [Player] -> Bool prop_newGameStartsWithNoPoisonUsed players = not $ newGame players ^. poisonUsed + +prop_newGameStartsWithNoPriorProtect :: [Player] -> Bool +prop_newGameStartsWithNoPriorProtect players = isNothing $ newGame players ^. priorProtect + +prop_newGameStartsWithNoProtect :: [Player] -> Bool +prop_newGameStartsWithNoProtect players = isNothing $ newGame players ^. protect prop_newGameStartsWithNoSee :: [Player] -> Bool prop_newGameStartsWithNoSee players = isNothing $ newGame players ^. see diff --git a/test/src/Game/Werewolf/Test/Util.hs b/test/src/Game/Werewolf/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/src/Game/Werewolf/Test/Util.hs @@ -0,0 +1,29 @@ +{-| +Module : Game.Werewolf.Test.Util +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com +-} + +{-# OPTIONS_HADDOCK hide, prune #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Game.Werewolf.Test.Util ( + -- * Utility functions + run, run_, +) where + +import Control.Monad.Except +import Control.Monad.State hiding (State) +import Control.Monad.Writer + +import Data.Either.Extra + +import Game.Werewolf.Game +import Game.Werewolf.Response + +run :: StateT Game (WriterT [Message] (Except [Message])) a -> Game -> Either [Message] (Game, [Message]) +run action game = runExcept . runWriterT $ execStateT action game + +run_ :: StateT Game (WriterT [Message] (Except [Message])) a -> Game -> Game +run_ action = fst . fromRight . run action diff --git a/werewolf.cabal b/werewolf.cabal --- a/werewolf.cabal +++ b/werewolf.cabal @@ -1,5 +1,5 @@ name: werewolf -version: 0.4.2.3 +version: 0.4.3.0 author: Henry J. Wylde maintainer: public@hjwylde.com @@ -29,12 +29,12 @@ ghc-options: -threaded -with-rtsopts=-N other-modules: Werewolf.Commands.End, - Werewolf.Commands.Heal, Werewolf.Commands.Help, Werewolf.Commands.Interpret, Werewolf.Commands.Pass, Werewolf.Commands.Ping, Werewolf.Commands.Poison, + Werewolf.Commands.Protect, Werewolf.Commands.Quit, Werewolf.Commands.See, Werewolf.Commands.Start, @@ -104,6 +104,7 @@ Game.Werewolf.Test.Engine Game.Werewolf.Test.Game Game.Werewolf.Test.Player + Game.Werewolf.Test.Util default-language: Haskell2010 other-extensions: