werewolf 0.4.2.3 → 0.4.3.0
raw patch · 29 files changed
+933/−588 lines, 29 files
Files
- CHANGELOG.md +4/−31
- README.md +1/−0
- app/Main.hs +2/−0
- app/Werewolf/Commands/End.hs +4/−4
- app/Werewolf/Commands/Heal.hs +0/−43
- app/Werewolf/Commands/Help.hs +80/−106
- app/Werewolf/Commands/Pass.hs +2/−2
- app/Werewolf/Commands/Ping.hs +2/−2
- app/Werewolf/Commands/Poison.hs +2/−2
- app/Werewolf/Commands/Protect.hs +49/−0
- app/Werewolf/Commands/Quit.hs +2/−2
- app/Werewolf/Commands/See.hs +2/−2
- app/Werewolf/Commands/Start.hs +2/−2
- app/Werewolf/Commands/Status.hs +2/−2
- app/Werewolf/Commands/Vote.hs +2/−2
- app/Werewolf/Options.hs +47/−36
- src/Game/Werewolf/Command.hs +33/−8
- src/Game/Werewolf/Engine.hs +25/−9
- src/Game/Werewolf/Game.hs +27/−16
- src/Game/Werewolf/Player.hs +10/−3
- src/Game/Werewolf/Response.hs +33/−11
- src/Game/Werewolf/Role.hs +18/−5
- test/app/Main.hs +143/−119
- test/src/Game/Werewolf/Test/Arbitrary.hs +117/−74
- test/src/Game/Werewolf/Test/Command.hs +222/−75
- test/src/Game/Werewolf/Test/Engine.hs +62/−29
- test/src/Game/Werewolf/Test/Game.hs +8/−1
- test/src/Game/Werewolf/Test/Util.hs +29/−0
- werewolf.cabal +3/−2
CHANGELOG.md view
@@ -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
README.md view
@@ -20,6 +20,7 @@ #### Roles The current implemented roles are:+* Defender. * Scapegoat. * Seer. * Villager.
app/Main.hs view
@@ -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
app/Werewolf/Commands/End.hs view
@@ -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
− app/Werewolf/Commands/Heal.hs
@@ -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 }
app/Werewolf/Commands/Help.hs view
@@ -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."+ ]
app/Werewolf/Commands/Pass.hs view
@@ -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
app/Werewolf/Commands/Ping.hs view
@@ -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
app/Werewolf/Commands/Poison.hs view
@@ -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
+ app/Werewolf/Commands/Protect.hs view
@@ -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 }
app/Werewolf/Commands/Quit.hs view
@@ -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
app/Werewolf/Commands/See.hs view
@@ -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
app/Werewolf/Commands/Start.hs view
@@ -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
app/Werewolf/Commands/Status.hs view
@@ -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
app/Werewolf/Commands/Vote.hs view
@@ -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
app/Werewolf/Options.hs view
@@ -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")
src/Game/Werewolf/Command.hs view
@@ -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
src/Game/Werewolf/Engine.hs view
@@ -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
src/Game/Werewolf/Game.hs view
@@ -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
src/Game/Werewolf/Player.hs view
@@ -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
src/Game/Werewolf/Response.hs view
@@ -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!"
src/Game/Werewolf/Role.hs view
@@ -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." ] }
test/app/Main.hs view
@@ -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 ]
test/src/Game/Werewolf/Test/Arbitrary.hs view
@@ -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
test/src/Game/Werewolf/Test/Command.hs view
@@ -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 =
test/src/Game/Werewolf/Test/Engine.hs view
@@ -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 =
test/src/Game/Werewolf/Test/Game.hs view
@@ -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
+ test/src/Game/Werewolf/Test/Util.hs view
@@ -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
werewolf.cabal view
@@ -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: