werewolf 0.4.8.0 → 0.4.9.0
raw patch · 58 files changed
+2858/−2015 lines, 58 files
Files
- CHANGELOG.md +11/−0
- README.md +33/−17
- app/Main.hs +20/−18
- app/Werewolf/Command/Choose.hs +56/−0
- app/Werewolf/Command/Circle.hs +48/−0
- app/Werewolf/Command/End.hs +51/−0
- app/Werewolf/Command/Heal.hs +43/−0
- app/Werewolf/Command/Help.hs +220/−0
- app/Werewolf/Command/Interpret.hs +21/−0
- app/Werewolf/Command/Pass.hs +46/−0
- app/Werewolf/Command/Ping.hs +41/−0
- app/Werewolf/Command/Poison.hs +48/−0
- app/Werewolf/Command/Protect.hs +48/−0
- app/Werewolf/Command/Quit.hs +41/−0
- app/Werewolf/Command/Reveal.hs +43/−0
- app/Werewolf/Command/See.hs +48/−0
- app/Werewolf/Command/Start.hs +83/−0
- app/Werewolf/Command/Status.hs +41/−0
- app/Werewolf/Command/Version.hs +27/−0
- app/Werewolf/Command/Vote.hs +53/−0
- app/Werewolf/Commands/Choose.hs +0/−57
- app/Werewolf/Commands/Circle.hs +0/−48
- app/Werewolf/Commands/End.hs +0/−43
- app/Werewolf/Commands/Heal.hs +0/−43
- app/Werewolf/Commands/Help.hs +0/−168
- app/Werewolf/Commands/Interpret.hs +0/−21
- app/Werewolf/Commands/Pass.hs +0/−41
- app/Werewolf/Commands/Ping.hs +0/−41
- app/Werewolf/Commands/Poison.hs +0/−48
- app/Werewolf/Commands/Protect.hs +0/−48
- app/Werewolf/Commands/Quit.hs +0/−41
- app/Werewolf/Commands/See.hs +0/−48
- app/Werewolf/Commands/Start.hs +0/−83
- app/Werewolf/Commands/Status.hs +0/−41
- app/Werewolf/Commands/Version.hs +0/−27
- app/Werewolf/Commands/Vote.hs +0/−53
- app/Werewolf/Options.hs +31/−20
- src/Game/Werewolf/Command.hs +66/−17
- src/Game/Werewolf/Engine.hs +22/−12
- src/Game/Werewolf/Game.hs +30/−20
- src/Game/Werewolf/Messages.hs +85/−44
- src/Game/Werewolf/Player.hs +20/−4
- src/Game/Werewolf/Role.hs +42/−5
- src/Game/Werewolf/Util.hs +16/−5
- test/src/Game/Werewolf/Test/Arbitrary.hs +102/−43
- test/src/Game/Werewolf/Test/Command.hs +19/−865
- test/src/Game/Werewolf/Test/Command/Choose.hs +237/−0
- test/src/Game/Werewolf/Test/Command/Heal.hs +96/−0
- test/src/Game/Werewolf/Test/Command/Pass.hs +97/−0
- test/src/Game/Werewolf/Test/Command/Poison.hs +121/−0
- test/src/Game/Werewolf/Test/Command/Protect.hs +112/−0
- test/src/Game/Werewolf/Test/Command/Quit.hs +148/−0
- test/src/Game/Werewolf/Test/Command/Reveal.hs +137/−0
- test/src/Game/Werewolf/Test/Command/See.hs +96/−0
- test/src/Game/Werewolf/Test/Command/Vote.hs +201/−0
- test/src/Game/Werewolf/Test/Engine.hs +121/−76
- test/src/Game/Werewolf/Test/Util.hs +10/−1
- werewolf.cabal +27/−17
CHANGELOG.md view
@@ -2,6 +2,17 @@ #### Upcoming +#### v0.4.9.0++*Minor*++* Added player contributed messages upon game over. ([#86](https://github.com/hjwylde/werewolf/issues/86))+* Changed `choose` command for Scapegoat to take a space separated list rather than comma separated. ([#98](https://github.com/hjwylde/werewolf/issues/98))+* Filtered `help` commands based on the current game. ([#94](https://github.com/hjwylde/werewolf/issues/94))+* Added `--all` option to `help` commands. ([#94](https://github.com/hjwylde/werewolf/issues/94))+* Added the Devoted Servant role. ([#47](https://github.com/hjwylde/werewolf/issues/47))+* Added `--force` flag to `end`. ([#77](https://github.com/hjwylde/werewolf/issues/77))+ #### v0.4.8.0 *Minor*
README.md view
@@ -9,9 +9,12 @@ ### Game description -Deep in the American countryside, the little town of Millers Hollow has recently been infiltrated by Werewolves.-Each night, murders are committed by the Villagers, who due to some mysterious phenomenon (possibly the greenhouse effect) have become Werewolves.-It is now time to take control and eliminate this ancient evil, before the town loses its last few inhabitants.+Deep in the American countryside, the little town of Millers Hollow has recently been infiltrated by+ Werewolves.+Each night, murders are committed by the Villagers, who due to some mysterious phenomenon (possibly+ the greenhouse effect) have become Werewolves.+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 Angel: die in the first round. @@ -24,35 +27,48 @@ **The Ambiguous:** -The Ambiguous may change allegiance during the game.+They could very well be allies of the village or become its enemies.+During the game, they can change sides or characters. -* Wild-child.-* Wolf-hound.+The Ambiguous must aid their side to achieve victory. +* Devoted Servant+* Wild-child+* Wolf-hound+ **The Loners:** -The Loners have their own win condition.+Their past could no doubt reveal to us why they hate the inhabitants of Miller's Hollow.+One thing is known for sure: they really scare everyone! -* Angel.+The Loners have their own objectives, no matter which side they're on. +* Angel+ **The Villagers:** +Attached to the village's survival, the following characters defend its harmony with determination.+Faced with various menaces, they will be brought to eliminate those they suspect of being too+ dangerous, even if that might be painful to them.+ The Villagers must lynch all of the Werewolves. -* Bear Tamer.-* Defender.-* Scapegoat.-* Seer.-* Simple Villager.-* Village Idiot.-* Villager-Villager.-* Witch.+* Bear Tamer+* Defender+* Scapegoat+* Seer+* Simple Villager+* Village Idiot+* Villager-Villager+* Witch **The Werewolves:** +They can be lethally dangerous and put in doubt the village's survival.+ The Werewolves must devour all of the Villagers. -* Simple Werewolf.+* Simple Werewolf ### Installing
app/Main.hs view
@@ -20,22 +20,23 @@ import System.Environment -import qualified Werewolf.Commands.Choose as Choose-import qualified Werewolf.Commands.Circle as Circle-import qualified Werewolf.Commands.End as End-import qualified Werewolf.Commands.Heal as Heal-import qualified Werewolf.Commands.Help as Help-import qualified Werewolf.Commands.Interpret as Interpret-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-import qualified Werewolf.Commands.Status as Status-import qualified Werewolf.Commands.Version as Version-import qualified Werewolf.Commands.Vote as Vote+import qualified Werewolf.Command.Choose as Choose+import qualified Werewolf.Command.Circle as Circle+import qualified Werewolf.Command.End as End+import qualified Werewolf.Command.Heal as Heal+import qualified Werewolf.Command.Help as Help+import qualified Werewolf.Command.Interpret as Interpret+import qualified Werewolf.Command.Pass as Pass+import qualified Werewolf.Command.Ping as Ping+import qualified Werewolf.Command.Poison as Poison+import qualified Werewolf.Command.Protect as Protect+import qualified Werewolf.Command.Quit as Quit+import qualified Werewolf.Command.Reveal as Reveal+import qualified Werewolf.Command.See as See+import qualified Werewolf.Command.Start as Start+import qualified Werewolf.Command.Status as Status+import qualified Werewolf.Command.Version as Version+import qualified Werewolf.Command.Vote as Vote import Werewolf.Options main :: IO ()@@ -50,13 +51,13 @@ case result of Success options -> handle options- _ -> handle (Options callerName . Help . Help.Options $ Just Help.Commands)+ _ -> handle (Options callerName . Help . Help.Options . Just $ Help.Commands False) handle :: Options -> IO () handle (Options callerName command) = case command of Choose options -> Choose.handle callerName options Circle options -> Circle.handle callerName options- End -> End.handle callerName+ End options -> End.handle callerName options Heal -> Heal.handle callerName Help options -> Help.handle callerName options Interpret (Interpret.Options args) -> interpret callerName args@@ -65,6 +66,7 @@ Poison options -> Poison.handle callerName options Protect options -> Protect.handle callerName options Quit -> Quit.handle callerName+ Reveal -> Reveal.handle callerName See options -> See.handle callerName options Start options -> Start.handle callerName options Status -> Status.handle callerName
+ app/Werewolf/Command/Choose.hs view
@@ -0,0 +1,56 @@+{-|+Module : Werewolf.Command.Choose+Description : Options and handler for the choose subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the choose subcommand.+-}++{-# LANGUAGE OverloadedStrings #-}++module Werewolf.Command.Choose (+ -- * Options+ Options(..),++ -- * Handle+ handle,+) where++import Control.Lens+import Control.Monad.Except+import Control.Monad.Extra+import Control.Monad.State+import Control.Monad.Writer++import Data.Text (Text)++import Game.Werewolf++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { args :: [Text]+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options args) = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = case game ^. stage of+ ScapegoatsTurn -> choosePlayersCommand callerName args+ WildChildsTurn -> choosePlayerCommand callerName (head args)+ WolfHoundsTurn -> chooseAllegianceCommand callerName (head args)+ -- TODO (hjw): throw an error+ _ -> undefined++ 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/Command/Circle.hs view
@@ -0,0 +1,48 @@+{-|+Module : Werewolf.Command.Circle+Description : Options and handler for the circle subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the circle subcommand.+-}++module Werewolf.Command.Circle (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { optIncludeDead :: Bool+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options includeDead) = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = circleCommand callerName includeDead++ case runExcept (execWriterT $ execStateT (apply command) game) of+ Left errorMessages -> exitWith failure { messages = errorMessages }+ Right messages -> exitWith success { messages = messages }
+ app/Werewolf/Command/End.hs view
@@ -0,0 +1,51 @@+{-|+Module : Werewolf.Command.End+Description : Options and handler for the end subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the end subcommand.+-}++{-# LANGUAGE OverloadedStrings #-}++module Werewolf.Command.End (+ -- * Options+ Options(..),++ -- * Handle+ handle,+) where++import Control.Monad.Extra+import Control.Monad.IO.Class++import Data.Text (Text)+import qualified Data.Text as T++import Game.Werewolf++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { optForce :: Bool+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options force) = do+ unlessM doesGameExist $ exitWith failure { messages = [noGameRunningMessage callerName] }++ unless force $ do+ game <- readGame++ unless (doesPlayerExist callerName game) $+ exitWith failure { messages = [playerCannotDoThatMessage callerName] }++ deleteGame++ exitWith success { messages = [gameEndedMessage] }+ where+ gameEndedMessage = publicMessage $ T.concat ["Game ended by ", callerName, "."]
+ app/Werewolf/Command/Heal.hs view
@@ -0,0 +1,43 @@+{-|+Module : Werewolf.Command.Heal+Description : Handler for the heal subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the heal subcommand.+-}++{-# LANGUAGE OverloadedStrings #-}++module Werewolf.Command.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++import Werewolf.Game+import Werewolf.Messages++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/Command/Help.hs view
@@ -0,0 +1,220 @@+{-|+Module : Werewolf.Command.Help+Description : Options and handler for the help subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the help subcommand.+-}++{-# LANGUAGE OverloadedStrings #-}++module Werewolf.Command.Help (+ -- * Options+ Options(..), Command(..),++ -- * Handle+ handle,+) where++import Control.Lens+import Control.Monad.Extra+import Control.Monad.IO.Class++import Data.Function+import Data.List+import Data.Text (Text)+import qualified Data.Text as T++import Game.Werewolf hiding (Command)+import qualified Game.Werewolf.Role as Role++import Werewolf.Game++data Options = Options+ { argCommand :: Maybe Command+ } deriving (Eq, Show)++data Command = Commands+ { optAll :: Bool+ } | Rules+ { optAll :: Bool+ } | Roles+ { optAll :: Bool+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options (Just (Commands optAll))) = do+ mGame <- ifM (doesGameExist &&^ return (not optAll)) (Just <$> readGame) (return Nothing)++ exitWith success+ { messages = map (privateMessage callerName) (commandsMessages callerName mGame)+ }+handle callerName (Options (Just (Roles optAll))) = do+ roles <- (sortBy (compare `on` view Role.name) . nub) <$> ifM (doesGameExist &&^ return (not optAll))+ (toListOf (players . roles) <$> readGame)+ (return allRoles)++ exitWith success+ { messages = map (privateMessage callerName . roleMessage) roles+ }+handle callerName (Options (Just (Rules optAll))) = do+ mGame <- ifM (doesGameExist &&^ return (not optAll)) (Just <$> readGame) (return Nothing)++ exitWith success+ { messages = map (privateMessage callerName) (rulesMessages mGame)+ }+handle callerName (Options Nothing) = exitWith success+ { messages = map (privateMessage callerName) helpMessages+ }++commandsMessages :: Text -> Maybe Game -> [Text]+commandsMessages callerName mGame = map (T.intercalate "\n") $ filter (/= [])+ [ [ "Global commands:"+ , "- `start ([-e | --extra-roles ROLE,...] | [-r | --random-extra-roles]) PLAYER...`"+ , "- `end`"+ , "- `quit`"+ , "- `version`"+ ]+ , [ "Status commands:"+ , "- `ping` ping the status of the current game publicly"+ , "- `status` get the status of the current game"+ , "- `circle [-a | --include-dead]` get the game circle"+ ]+ , [ "Standard commands:"+ , "- `vote PLAYER`"+ ]+ , whenPlayerHasRole callerName mGame defenderRole+ [ "Defender commands:"+ , "- `protect PLAYER`"+ ]+ , whenPlayerHasRole callerName mGame devotedServantRole+ [ "Devoted Servant commands:"+ , "- `reveal`"+ ]+ , whenPlayerHasRole callerName mGame scapegoatRole+ [ "Scapegoat commands:"+ , "- `choose PLAYER...`"+ ]+ , whenPlayerHasRole callerName mGame seerRole+ [ "Seer commands:"+ , "- `see PLAYER`"+ ]+ , whenPlayerHasRole callerName mGame wildChildRole+ [ "Wild-child commands:"+ , "- `choose PLAYER`"+ ]+ , whenPlayerHasRole callerName mGame witchRole+ [ "Witch commands:"+ , "- `heal`"+ , "- `poison PLAYER`"+ , "- `pass`"+ ]+ , whenPlayerHasRole callerName mGame wolfHoundRole+ [ "Wolf-hound commands:"+ , "- `choose (villagers | werewolves)`"+ ]+ ]++roleMessage :: Role -> Text+roleMessage role = T.intercalate "\n"+ [ T.concat [role ^. Role.name, " (", T.pack . show $ role ^. balance, "):"]+ , role ^. description+ , role ^. advice+ ]++rulesMessages :: Maybe Game -> [Text]+rulesMessages mGame = 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."+ ]+ ]+ , filter (/= "") [ T.concat+ [ "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."+ , whenRoleInPlay mGame angelRole+ " (N.B., when the Angel is in play the game begins with the village vote.)"+ ]+ , whenRoleInPlay mGame angelRole+ "- (When the Angel is in play) the village votes to lynch a suspect."+ , "- The village falls asleep."+ , whenRoleInPlay mGame wildChildRole+ "- (First round only) the Wild-child wakes up and chooses a role model."+ , whenRoleInPlay mGame defenderRole+ "- The Defender wakes up and protects someone."+ , whenRoleInPlay mGame seerRole+ "- The Seer wakes up and sees someone's allegiance."+ , whenRoleInPlay mGame wolfHoundRole+ "- (First round only) the Wolf-hound wakes up and chooses an allegiance."+ , "- The Werewolves wake up and select a victim."+ , whenRoleInPlay mGame witchRole+ "- The Witch wakes up and may heal the victim and/or poison someone."+ , "- The village wakes up and find the victim."+ , "- The village votes to lynch a suspect."+ , whenRoleInPlay mGame devotedServantRole+ "- The Devoted Servant may choose whether to reveal themselves and take on the role of their master."+ , whenRoleInPlay mGame scapegoatRole+ "- (When the Scapegoat is blamed) the Scapegoat chooses whom may vote on the next day."+ , T.concat+ [ "The game is over when only Villagers or Werewolves are left alive"+ , ifRoleInPlay mGame angelRole+ ", or when one of the Loners completes their own objective."+ "."+ ]+ ]+ ]++helpMessages :: [Text]+helpMessages = 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."+ ]+ ]+ , [ "Help commands:"+ , "- `help commands [-a | --all]`"+ , "- `help roles [-a | --all]`"+ , "- `help rules [-a | --all]`"+ ]+ ]++whenPlayerHasRole :: Monoid m => Text -> Maybe Game -> Role -> m -> m+whenPlayerHasRole _ Nothing _ m = m+whenPlayerHasRole callerName (Just game) role' m+ | has (players . names . only callerName) game+ && has (role . only role') player = m+ | otherwise = mempty+ where+ player = game ^?! players . traverse . filteredBy name callerName++ifRoleInPlay :: Maybe Game -> Role -> a -> a -> a+ifRoleInPlay Nothing _ true _ = true+ifRoleInPlay (Just game) role' true false+ | has (players . roles . only role') game = true+ | otherwise = false++whenRoleInPlay :: Monoid m => Maybe Game -> Role -> m -> m+whenRoleInPlay mGame role m = ifRoleInPlay mGame role m mempty
+ app/Werewolf/Command/Interpret.hs view
@@ -0,0 +1,21 @@+{-|+Module : Werewolf.Command.Interpret+Description : Options for the interpret subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options for the interpret subcommand.+-}++module Werewolf.Command.Interpret (+ -- * Options+ Options(..),+) where++import Data.Text (Text)++data Options = Options+ { args :: [Text]+ } deriving (Eq, Show)
+ app/Werewolf/Command/Pass.hs view
@@ -0,0 +1,46 @@+{-|+Module : Werewolf.Command.Pass+Description : Handler for the pass subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the pass subcommand.+-}++module Werewolf.Command.Pass (+ -- * Handle+ handle,+) where++import Control.Lens+import Control.Monad.Except+import Control.Monad.Extra+import Control.Monad.State+import Control.Monad.Writer++import Data.Text (Text)++import Game.Werewolf++import Werewolf.Game+import Werewolf.Messages++handle :: MonadIO m => Text -> m ()+handle callerName = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = case game ^. stage of+ DevotedServantsTurn -> passDevotedServantsTurnCommand callerName+ WitchsTurn -> passWitchsTurnCommand callerName+ -- TODO (hjw): throw an error+ _ -> undefined++ 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/Command/Ping.hs view
@@ -0,0 +1,41 @@+{-|+Module : Werewolf.Command.Ping+Description : Handler for the ping subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the ping subcommand.+-}++module Werewolf.Command.Ping (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++handle :: MonadIO m => Text -> m ()+handle callerName = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = pingCommand callerName++ case runExcept (execWriterT $ execStateT (apply command) game) of+ Left errorMessages -> exitWith failure { messages = errorMessages }+ Right messages -> exitWith success { messages = messages }
+ app/Werewolf/Command/Poison.hs view
@@ -0,0 +1,48 @@+{-|+Module : Werewolf.Command.Poison+Description : Options and handler for the poison subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the poison subcommand.+-}++module Werewolf.Command.Poison (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { argTarget :: Text+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options targetName) = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = poisonCommand 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/Command/Protect.hs view
@@ -0,0 +1,48 @@+{-|+Module : Werewolf.Command.Protect+Description : Options and handler for the protect subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the protect subcommand.+-}++module Werewolf.Command.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++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { argTarget :: Text+ } deriving (Eq, Show)++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/Command/Quit.hs view
@@ -0,0 +1,41 @@+{-|+Module : Werewolf.Command.Quit+Description : Handler for the quit subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the quit subcommand.+-}++module Werewolf.Command.Quit (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++handle :: MonadIO m => Text -> m ()+handle callerName = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = quitCommand 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/Command/Reveal.hs view
@@ -0,0 +1,43 @@+{-|+Module : Werewolf.Command.Reveal+Description : Handler for the reveal subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the reveal subcommand.+-}++{-# LANGUAGE OverloadedStrings #-}++module Werewolf.Command.Reveal (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++handle :: MonadIO m => Text -> m ()+handle callerName = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = revealCommand 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/Command/See.hs view
@@ -0,0 +1,48 @@+{-|+Module : Werewolf.Command.See+Description : Options and handler for the see subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the see subcommand.+-}++module Werewolf.Command.See (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { argTarget :: Text+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options targetName) = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = seeCommand 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/Command/Start.hs view
@@ -0,0 +1,83 @@+{-|+Module : Werewolf.Command.Start+Description : Options and handler for the start subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the start subcommand.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Werewolf.Command.Start (+ -- * Options+ Options(..), ExtraRoles(..),++ -- * Handle+ handle,+) where++import Control.Lens+import Control.Monad.Except+import Control.Monad.Extra+import Control.Monad.Random+import Control.Monad.State+import Control.Monad.Writer++import Data.Text (Text)+import qualified Data.Text as T++import Game.Werewolf hiding (name)+import Game.Werewolf.Role++import System.Random.Shuffle++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { optExtraRoles :: ExtraRoles+ , argPlayers :: [Text]+ } deriving (Eq, Show)++data ExtraRoles = None | Random | Use [Text]+ deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options extraRoles playerNames) = do+ whenM (doesGameExist &&^ (hasn't (stage . _GameOver) <$> readGame)) $ exitWith failure+ { messages = [gameAlreadyRunningMessage callerName]+ }++ result <- runExceptT $ do+ extraRoles' <- case extraRoles of+ None -> return []+ Random -> randomExtraRoles $ length playerNames+ Use roleNames -> useExtraRoles callerName roleNames++ players <- createPlayers (callerName:playerNames) (padRoles extraRoles' (length playerNames + 1))++ runWriterT $ startGame callerName players >>= execStateT checkStage++ case result of+ Left errorMessages -> exitWith failure { messages = errorMessages }+ Right (game, messages) -> writeGame game >> exitWith success { messages = messages }++randomExtraRoles :: MonadIO m => Int -> m [Role]+randomExtraRoles n = liftIO . evalRandIO $ do+ let minimum = n `div` 3++ count <- getRandomR (minimum, minimum + 2)++ take count <$> shuffleM restrictedRoles++useExtraRoles :: MonadError [Message] m => Text -> [Text] -> m [Role]+useExtraRoles callerName roleNames = forM roleNames $ \roleName -> case findByName roleName of+ Just role -> return role+ Nothing -> throwError [roleDoesNotExistMessage callerName roleName]++findByName :: Text -> Maybe Role+findByName name' = restrictedRoles ^? traverse . filtered ((name' ==) . T.toLower . view name)
+ app/Werewolf/Command/Status.hs view
@@ -0,0 +1,41 @@+{-|+Module : Werewolf.Command.Status+Description : Handler for the status subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the status subcommand.+-}++module Werewolf.Command.Status (+ -- * 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++import Werewolf.Game+import Werewolf.Messages++handle :: MonadIO m => Text -> m ()+handle callerName = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = statusCommand callerName++ case runExcept (execWriterT $ execStateT (apply command) game) of+ Left errorMessages -> exitWith failure { messages = errorMessages }+ Right messages -> exitWith success { messages = messages }
+ app/Werewolf/Command/Version.hs view
@@ -0,0 +1,27 @@+{-|+Module : Werewolf.Command.Version+Description : Handler for the version subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Handler for the start subcommand.+-}++module Werewolf.Command.Version (+ -- * Handle+ handle,+) where++import Control.Monad.Except++import Data.Text (Text)++import Game.Werewolf++import Werewolf.Messages+import Werewolf.Version++handle :: MonadIO m => Text -> m ()+handle callerName = exitWith success { messages = [engineVersionMessage callerName version] }
+ app/Werewolf/Command/Vote.hs view
@@ -0,0 +1,53 @@+{-|+Module : Werewolf.Command.Vote+Description : Options and handler for the vote subcommand.++Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the vote subcommand.+-}++module Werewolf.Command.Vote (+ -- * Options+ Options(..),++ -- * Handle+ handle,+) where++import Control.Lens+import Control.Monad.Except+import Control.Monad.Extra+import Control.Monad.State+import Control.Monad.Writer++import Data.Text (Text)++import Game.Werewolf++import Werewolf.Game+import Werewolf.Messages++data Options = Options+ { argTarget :: Text+ } deriving (Eq, Show)++handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options targetName) = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = case game ^. stage of+ VillagesTurn -> voteLynchCommand callerName targetName+ WerewolvesTurn -> voteDevourCommand callerName targetName+ -- TODO (hjw): throw an error+ _ -> undefined++ 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/Choose.hs
@@ -1,57 +0,0 @@-{-|-Module : Werewolf.Commands.Choose-Description : Options and handler for the choose subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the choose subcommand.--}--{-# LANGUAGE OverloadedStrings #-}--module Werewolf.Commands.Choose (- -- * Options- Options(..),-- -- * Handle- handle,-) where--import Control.Lens-import Control.Monad.Except-import Control.Monad.Extra-import Control.Monad.State-import Control.Monad.Writer--import Data.Text (Text)-import qualified Data.Text as T--import Game.Werewolf--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { arg :: Text- } deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-handle callerName (Options arg) = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = case game ^. stage of- ScapegoatsTurn -> choosePlayersCommand callerName (filter (/= T.empty) (T.splitOn "," arg))- WildChildsTurn -> choosePlayerCommand callerName arg- WolfHoundsTurn -> chooseAllegianceCommand callerName arg- -- TODO (hjw): throw an error- _ -> undefined-- case runExcept (runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game) of- Left errorMessages -> exitWith failure { messages = errorMessages }- Right (game, messages) -> writeGame game >> exitWith success { messages = messages }
− app/Werewolf/Commands/Circle.hs
@@ -1,48 +0,0 @@-{-|-Module : Werewolf.Commands.Circle-Description : Options and handler for the circle subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the circle subcommand.--}--module Werewolf.Commands.Circle (- -- * 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--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { optIncludeDead :: Bool- } deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-handle callerName (Options includeDead) = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = circleCommand callerName includeDead-- case runExcept (execWriterT $ execStateT (apply command) game) of- Left errorMessages -> exitWith failure { messages = errorMessages }- Right messages -> exitWith success { messages = messages }
− app/Werewolf/Commands/End.hs
@@ -1,43 +0,0 @@-{-|-Module : Werewolf.Commands.End-Description : Handler for the end subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Handler for the end subcommand.--}--{-# LANGUAGE OverloadedStrings #-}--module Werewolf.Commands.End (- -- * Handle- handle,-) where--import Control.Monad.Extra-import Control.Monad.IO.Class--import Data.Text (Text)-import qualified Data.Text as T--import Game.Werewolf--import Werewolf.Game-import Werewolf.Messages--handle :: MonadIO m => Text -> m ()-handle callerName = do- unlessM doesGameExist $ exitWith failure { messages = [noGameRunningMessage callerName] }-- game <- readGame-- unless (doesPlayerExist callerName game) $- exitWith failure { messages = [playerCannotDoThatMessage callerName] }-- deleteGame-- exitWith success { messages = [gameEndedMessage] }- where- gameEndedMessage = publicMessage $ T.concat ["Game ended by ", callerName, "."]
− app/Werewolf/Commands/Heal.hs
@@ -1,43 +0,0 @@-{-|-Module : Werewolf.Commands.Heal-Description : Handler for the heal subcommand.--Copyright : (c) Henry J. Wylde, 2016-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--import Werewolf.Game-import Werewolf.Messages--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
@@ -1,168 +0,0 @@-{-|-Module : Werewolf.Commands.Help-Description : Options and handler for the help subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the help subcommand.--}--{-# LANGUAGE OverloadedStrings #-}--module Werewolf.Commands.Help (- -- * Options- Options(..), Command(..),-- -- * Handle- handle,-) where--import Control.Lens-import Control.Monad.IO.Class--import Data.Text (Text)-import qualified Data.Text as T--import Game.Werewolf hiding (Command)-import Game.Werewolf.Role as Role--data Options = Options- { argCommand :: Maybe Command- } deriving (Eq, Show)--data Command = Commands | Description | Rules | Roles- deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-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 Roles)) = exitWith success- { messages = map (\role -> privateMessage callerName $ T.intercalate "\n"- [ T.concat [role ^. Role.name, " (", T.pack . show $ role ^. balance, "):"]- , role ^. description- , role ^. advice- ]) allRoles- }-handle callerName (Options (Just Rules)) = exitWith success- { messages = map (privateMessage callerName) rulesMessages- }-handle callerName (Options Nothing) = exitWith success- { messages = map (privateMessage callerName) helpMessages- }--commandsMessages :: [Text]-commandsMessages = map (T.intercalate "\n")- [ [ "Global commands:"- , "start ([--extra-roles ROLE,...] | [--random-extra-roles]) PLAYER..."- , "end"- , "quit"- , "version"- ]- , [ "Status commands:"- , "ping - ping the status of the current game publicly."- , "status - get the status of the current game."- , "circle [--include-dead] - get the game circle."- ]- , [ "Standard commands:"- , "vote PLAYER"- ]- , [ "Defender commands:"- , "protect PLAYER"- ]- , [ "Scapegoat commands:"- , "choose PLAYER,..."- ]- , [ "Seer commands:"- , "see PLAYER"- ]- , [ "Wild-child commands:"- , "choose PLAYER"- ]- , [ "Witch commands:"- , "heal"- , "poison PLAYER"- , "pass"- ]- , [ "Wolf-hound commands:"- , "choose (villagers | werewolves)"- ]- ]--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."- ]- ]- , [ "Objective of the Game:"- , "For the Angel: die in the first round."- , "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."- ]- ]- , [ 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."- , "(N.B., when the Angel is in play the game begins with the village vote.)"- ]- , "1. (When the Angel is in play) the village votes to lynch a suspect."- , "2. The village falls asleep."- , "3. (First round only) the Wild-child wakes up and chooses a role model."- , "4. The Defender wakes up and protects someone."- , "5. The Seer wakes up and sees someone's allegiance."- , "6. (First round only) the Wolf-hound wakes up and chooses an allegiance."- , "7. The Werewolves wake up and select a victim."- , "8. The Witch wakes up and may heal the victim and/or poison someone."- , "9. The village wakes up and find the victim."- , "10. The village votes to lynch a suspect."- , "11. (When the Scapegoat is blamed) the Scapegot chooses whom may vote on the next day."- , T.unwords- [ "The game is over when only Villagers or Werewolves are left alive,"- , "or when one of the Loners completes their own objective."- ]- ]- ]--helpMessages :: [Text]-helpMessages =- [ 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."- ]- ]
− app/Werewolf/Commands/Interpret.hs
@@ -1,21 +0,0 @@-{-|-Module : Werewolf.Commands.Interpret-Description : Options for the interpret subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options for the interpret subcommand.--}--module Werewolf.Commands.Interpret (- -- * Options- Options(..),-) where--import Data.Text (Text)--data Options = Options- { args :: [Text]- } deriving (Eq, Show)
− app/Werewolf/Commands/Pass.hs
@@ -1,41 +0,0 @@-{-|-Module : Werewolf.Commands.Pass-Description : Handler for the pass subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Handler for the pass subcommand.--}--module Werewolf.Commands.Pass (- -- * 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--import Werewolf.Game-import Werewolf.Messages--handle :: MonadIO m => Text -> m ()-handle callerName = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = passCommand 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/Ping.hs
@@ -1,41 +0,0 @@-{-|-Module : Werewolf.Commands.Ping-Description : Handler for the ping subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Handler for the ping subcommand.--}--module Werewolf.Commands.Ping (- -- * 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--import Werewolf.Game-import Werewolf.Messages--handle :: MonadIO m => Text -> m ()-handle callerName = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = pingCommand callerName-- case runExcept (execWriterT $ execStateT (apply command) game) of- Left errorMessages -> exitWith failure { messages = errorMessages }- Right messages -> exitWith success { messages = messages }
− app/Werewolf/Commands/Poison.hs
@@ -1,48 +0,0 @@-{-|-Module : Werewolf.Commands.Poison-Description : Options and handler for the poison subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the poison subcommand.--}--module Werewolf.Commands.Poison (- -- * 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--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { argTarget :: Text- } deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-handle callerName (Options targetName) = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = poisonCommand 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/Protect.hs
@@ -1,48 +0,0 @@-{-|-Module : Werewolf.Commands.Protect-Description : Options and handler for the protect subcommand.--Copyright : (c) Henry J. Wylde, 2016-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--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { argTarget :: Text- } deriving (Eq, Show)--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
@@ -1,41 +0,0 @@-{-|-Module : Werewolf.Commands.Quit-Description : Handler for the quit subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Handler for the quit subcommand.--}--module Werewolf.Commands.Quit (- -- * 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--import Werewolf.Game-import Werewolf.Messages--handle :: MonadIO m => Text -> m ()-handle callerName = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = quitCommand 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/See.hs
@@ -1,48 +0,0 @@-{-|-Module : Werewolf.Commands.See-Description : Options and handler for the see subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the see subcommand.--}--module Werewolf.Commands.See (- -- * 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--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { argTarget :: Text- } deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-handle callerName (Options targetName) = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = seeCommand 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/Start.hs
@@ -1,83 +0,0 @@-{-|-Module : Werewolf.Commands.Start-Description : Options and handler for the start subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the start subcommand.--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Werewolf.Commands.Start (- -- * Options- Options(..), ExtraRoles(..),-- -- * Handle- handle,-) where--import Control.Lens-import Control.Monad.Except-import Control.Monad.Extra-import Control.Monad.Random-import Control.Monad.State-import Control.Monad.Writer--import Data.Text (Text)-import qualified Data.Text as T--import Game.Werewolf hiding (name)-import Game.Werewolf.Role--import System.Random.Shuffle--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { optExtraRoles :: ExtraRoles- , argPlayers :: [Text]- } deriving (Eq, Show)--data ExtraRoles = None | Random | Use [Text]- deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-handle callerName (Options extraRoles playerNames) = do- whenM (doesGameExist &&^ (hasn't (stage . _GameOver) <$> readGame)) $ exitWith failure- { messages = [gameAlreadyRunningMessage callerName]- }-- result <- runExceptT $ do- extraRoles' <- case extraRoles of- None -> return []- Random -> randomExtraRoles $ length playerNames- Use roleNames -> useExtraRoles callerName roleNames-- players <- createPlayers (callerName:playerNames) (padRoles extraRoles' (length playerNames + 1))-- runWriterT $ startGame callerName players >>= execStateT checkStage-- case result of- Left errorMessages -> exitWith failure { messages = errorMessages }- Right (game, messages) -> writeGame game >> exitWith success { messages = messages }--randomExtraRoles :: MonadIO m => Int -> m [Role]-randomExtraRoles n = liftIO . evalRandIO $ do- let minimum = n `div` 3-- count <- getRandomR (minimum, minimum + 2)-- take count <$> shuffleM restrictedRoles--useExtraRoles :: MonadError [Message] m => Text -> [Text] -> m [Role]-useExtraRoles callerName roleNames = forM roleNames $ \roleName -> case findByName roleName of- Just role -> return role- Nothing -> throwError [roleDoesNotExistMessage callerName roleName]--findByName :: Text -> Maybe Role-findByName name' = restrictedRoles ^? traverse . filtered ((name' ==) . T.toLower . view name)
− app/Werewolf/Commands/Status.hs
@@ -1,41 +0,0 @@-{-|-Module : Werewolf.Commands.Status-Description : Handler for the status subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Handler for the status subcommand.--}--module Werewolf.Commands.Status (- -- * 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--import Werewolf.Game-import Werewolf.Messages--handle :: MonadIO m => Text -> m ()-handle callerName = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = statusCommand callerName-- case runExcept (execWriterT $ execStateT (apply command) game) of- Left errorMessages -> exitWith failure { messages = errorMessages }- Right messages -> exitWith success { messages = messages }
− app/Werewolf/Commands/Version.hs
@@ -1,27 +0,0 @@-{-|-Module : Werewolf.Commands.Version-Description : Handler for the version subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Handler for the start subcommand.--}--module Werewolf.Commands.Version (- -- * Handle- handle,-) where--import Control.Monad.Except--import Data.Text (Text)--import Game.Werewolf--import Werewolf.Messages-import Werewolf.Version--handle :: MonadIO m => Text -> m ()-handle callerName = exitWith success { messages = [engineVersionMessage callerName version] }
− app/Werewolf/Commands/Vote.hs
@@ -1,53 +0,0 @@-{-|-Module : Werewolf.Commands.Vote-Description : Options and handler for the vote subcommand.--Copyright : (c) Henry J. Wylde, 2016-License : BSD3-Maintainer : public@hjwylde.com--Options and handler for the vote subcommand.--}--module Werewolf.Commands.Vote (- -- * Options- Options(..),-- -- * Handle- handle,-) where--import Control.Lens-import Control.Monad.Except-import Control.Monad.Extra-import Control.Monad.State-import Control.Monad.Writer--import Data.Text (Text)--import Game.Werewolf--import Werewolf.Game-import Werewolf.Messages--data Options = Options- { argTarget :: Text- } deriving (Eq, Show)--handle :: MonadIO m => Text -> Options -> m ()-handle callerName (Options targetName) = do- unlessM doesGameExist $ exitWith failure- { messages = [noGameRunningMessage callerName]- }-- game <- readGame-- let command = case game ^. stage of- VillagesTurn -> voteLynchCommand callerName targetName- WerewolvesTurn -> voteDevourCommand callerName targetName- -- TODO (hjw): throw an error- _ -> undefined-- 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/Options.hs view
@@ -23,16 +23,17 @@ import qualified Data.Text as T import Data.Version (showVersion) -import qualified Werewolf.Commands.Choose as Choose-import qualified Werewolf.Commands.Circle as Circle-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-import qualified Werewolf.Version as This+import qualified Werewolf.Command.Choose as Choose+import qualified Werewolf.Command.Circle as Circle+import qualified Werewolf.Command.End as End+import qualified Werewolf.Command.Help as Help+import qualified Werewolf.Command.Interpret as Interpret+import qualified Werewolf.Command.Poison as Poison+import qualified Werewolf.Command.Protect as Protect+import qualified Werewolf.Command.See as See+import qualified Werewolf.Command.Start as Start+import qualified Werewolf.Command.Vote as Vote+import qualified Werewolf.Version as This import Options.Applicative @@ -44,7 +45,7 @@ data Command = Choose Choose.Options | Circle Circle.Options- | End+ | End End.Options | Heal | Help Help.Options | Interpret Interpret.Options@@ -53,6 +54,7 @@ | Poison Poison.Options | Protect Protect.Options | Quit+ | Reveal | See See.Options | Start Start.Options | Status@@ -95,12 +97,13 @@ , 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 "interpret" $ info (helper <*> interpret) (fullDesc <> noIntersperse <> progDesc "Interpret a command") , command "pass" $ info (helper <*> pass) (fullDesc <> progDesc "Pass") , command "ping" $ info (helper <*> ping) (fullDesc <> progDesc "Ping 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 "reveal" $ info (helper <*> reveal) (fullDesc <> progDesc "Reveal yourself") , 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")@@ -109,7 +112,7 @@ ]) choose :: Parser Command-choose = Choose . Choose.Options . T.pack <$> strArgument (metavar "ALLEGIANCE | PLAYER,...")+choose = Choose . Choose.Options . map T.pack <$> some (strArgument $ metavar "(ALLEGIANCE | PLAYER...)") circle :: Parser Command circle = Circle . Circle.Options@@ -119,7 +122,11 @@ ]) end :: Parser Command-end = pure End+end = End . End.Options+ <$> switch (mconcat+ [ long "force", short 'f'+ , help "Force the game to end"+ ]) heal :: Parser Command heal = pure Heal@@ -127,11 +134,12 @@ 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")+ [ command "commands" $ info (Help.Commands <$> allOption) (fullDesc <> progDesc "Print the in-game commands")+ , command "roles" $ info (Help.Roles <$> allOption) (fullDesc <> progDesc "Print the roles and their descriptions")+ , command "rules" $ info (Help.Rules <$> allOption) (fullDesc <> progDesc "Print the game rules") ])+ where+ allOption = switch $ long "all" <> short 'a' interpret :: Parser Command interpret = Interpret . Interpret.Options@@ -152,6 +160,9 @@ quit :: Parser Command quit = pure Quit +reveal :: Parser Command+reveal = pure Reveal+ see :: Parser Command see = See . See.Options <$> playerArgument @@ -161,13 +172,13 @@ <*> some (T.pack <$> strArgument (metavar "PLAYER...")) where extraRolesOption = fmap (Start.Use . filter (/= T.empty) . T.splitOn "," . T.pack) (strOption $ mconcat- [ long "extra-roles", metavar "ROLE,..."+ [ long "extra-roles", short 'e', metavar "ROLE,..." , value [] , help "Specify the extra roles to use" ]) randomExtraRolesOption = flag Start.None Start.Random $ mconcat- [ long "random-extra-roles"+ [ long "random-extra-roles", short 'r' , help "Use random extra roles" ]
src/Game/Werewolf/Command.hs view
@@ -20,8 +20,9 @@ -- ** Instances chooseAllegianceCommand, choosePlayerCommand, choosePlayersCommand, circleCommand, healCommand,- noopCommand, passCommand, pingCommand, poisonCommand, protectCommand, quitCommand, seeCommand,- statusCommand, voteDevourCommand, voteLynchCommand,+ noopCommand, passDevotedServantsTurnCommand, passWitchsTurnCommand, pingCommand, poisonCommand,+ protectCommand, quitCommand, revealCommand, seeCommand, statusCommand, voteDevourCommand,+ voteLynchCommand, ) where import Control.Lens@@ -36,7 +37,8 @@ import Data.Text (Text) import qualified Data.Text as T -import Game.Werewolf.Game hiding (doesPlayerExist, getPendingVoters, killPlayer)+import Game.Werewolf.Game hiding (doesPlayerExist, getPendingVoters, getVoteResult,+ killPlayer) import Game.Werewolf.Messages import Game.Werewolf.Player import Game.Werewolf.Response@@ -103,55 +105,67 @@ noopCommand :: Command noopCommand = Command $ return () -passCommand :: Text -> Command-passCommand callerName = Command $ do+passDevotedServantsTurnCommand :: Text -> Command+passDevotedServantsTurnCommand callerName = Command $ do+ validateDevotedServantsCommand callerName++ passes %= nub . cons callerName++passWitchsTurnCommand :: Text -> Command+passWitchsTurnCommand callerName = Command $ do validateWitchsCommand callerName passes %= nub . cons callerName pingCommand :: Text -> Command pingCommand callerName = Command $ use stage >>= \stage' -> case stage' of- GameOver -> tell [gameIsOverMessage callerName]- DefendersTurn -> do+ DefendersTurn -> do defender <- findPlayerBy_ role defenderRole tell [pingRoleMessage $ defenderRole ^. Role.name] tell [pingPlayerMessage $ defender ^. name]- ScapegoatsTurn -> do+ DevotedServantsTurn -> do+ devotedServant <- findPlayerBy_ role devotedServantRole++ tell [pingRoleMessage $ devotedServantRole ^. Role.name]+ tell [pingPlayerMessage $ devotedServant ^. name]+ GameOver -> tell [gameIsOverMessage callerName]+ Lynching -> return ()+ ScapegoatsTurn -> do scapegoat <- findPlayerBy_ role scapegoatRole tell [pingRoleMessage $ scapegoatRole ^. Role.name] tell [pingPlayerMessage $ scapegoat ^. name]- SeersTurn -> do+ SeersTurn -> do seer <- findPlayerBy_ role seerRole tell [pingRoleMessage $ seerRole ^. Role.name] tell [pingPlayerMessage $ seer ^. name]- Sunrise -> return ()- Sunset -> return ()- UrsussGrunt -> return ()- VillagesTurn -> do+ Sunrise -> return ()+ Sunset -> return ()+ UrsussGrunt -> return ()+ VillagesTurn -> do allowedVoterNames <- use allowedVoters pendingVoterNames <- toListOf names <$> getPendingVoters tell [waitingOnMessage Nothing $ allowedVoterNames `intersect` pendingVoterNames] tell $ map pingPlayerMessage (allowedVoterNames `intersect` pendingVoterNames)- WerewolvesTurn -> do+ WerewolvesTurn -> do pendingVoters <- getPendingVoters tell [pingRoleMessage "Werewolves"] tell $ map pingPlayerMessage (pendingVoters ^.. werewolves . name)- WildChildsTurn -> do+ WildChildsTurn -> do wildChild <- findPlayerBy_ role wildChildRole tell [pingRoleMessage $ wildChildRole ^. Role.name] tell [pingPlayerMessage $ wildChild ^. name]- WitchsTurn -> do+ WitchsTurn -> do witch <- findPlayerBy_ role witchRole tell [pingRoleMessage $ witchRole ^. Role.name] tell [pingPlayerMessage $ witch ^. name]- WolfHoundsTurn -> do+ WolfHoundsTurn -> do wolfHound <- findPlayerBy_ role wolfHoundRole tell [pingRoleMessage $ wolfHoundRole ^. Role.name]@@ -203,6 +217,33 @@ poisonUsed .= False when (is wolfHound caller) $ allegianceChosen .= Nothing +revealCommand :: Text -> Command+revealCommand callerName = Command $ do+ validateDevotedServantsCommand callerName++ target <- head <$> getVoteResult++ let targetRole = target ^. role+ let targetName = target ^. name++ setPlayerRole callerName targetRole+ setPlayerRole targetName devotedServantRole++ tell [devotedServantRevealedMessage callerName]++ resetRole targetRole+ where+ resetRole role+ | role == simpleWerewolfRole = do+ aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get++ tell $ devotedServantJoinedPackMessages callerName aliveWerewolfNames+ | role == villageIdiotRole = villageIdiotRevealed .= False+ | role == wildChildRole = roleModel .= Nothing+ | role == witchRole = healUsed .= False >> poisonUsed .= False+ | role == wolfHoundRole = allegianceChosen .= Nothing+ | otherwise = return ()+ seeCommand :: Text -> Text -> Command seeCommand callerName targetName = Command $ do validatePlayer callerName callerName@@ -215,8 +256,10 @@ statusCommand :: Text -> Command statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of GameOver -> tell [gameIsOverMessage callerName]+ Lynching -> return () Sunrise -> return () Sunset -> return ()+ UrsussGrunt -> return () VillagesTurn -> do allowedVoterNames <- use allowedVoters pendingVoterNames <- toListOf names <$> getPendingVoters@@ -267,6 +310,12 @@ whenM isGameOver $ throwError [gameIsOverMessage callerName] unlessM (doesPlayerExist name) $ throwError [playerDoesNotExistMessage callerName name] whenM (isPlayerDead name) $ throwError [if callerName == name then playerIsDeadMessage callerName else targetIsDeadMessage callerName name]++validateDevotedServantsCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m ()+validateDevotedServantsCommand callerName = do+ validatePlayer callerName callerName+ unlessM (isPlayerDevotedServant callerName) $ throwError [playerCannotDoThatMessage callerName]+ unlessM isDevotedServantsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] validateWitchsCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m () validateWitchsCommand callerName = do
src/Game/Werewolf/Engine.hs view
@@ -55,13 +55,31 @@ checkStage' :: (MonadState Game m, MonadWriter [Message] m) => m () checkStage' = use stage >>= \stage' -> case stage' of- GameOver -> return ()- DefendersTurn -> do whenM (has (players . defenders . dead) <$> get) advanceStage whenM (isJust <$> use protect) advanceStage + DevotedServantsTurn -> do+ whenM (has (players . devotedServants . dead) <$> get) advanceStage++ whenM (has devotedServants <$> getVoteResult) advanceStage+ whenM (has devotedServants <$> getPassers) advanceStage++ GameOver -> return ()++ Lynching -> do+ getVoteResult >>= lynchVotees++ allVoters <- ifM (use villageIdiotRevealed)+ (uses players $ filter (isn't villageIdiot))+ (use players)+ allowedVoters .= allVoters ^.. traverse . alive . name++ votes .= Map.empty++ advanceStage+ ScapegoatsTurn -> unlessM (use scapegoatBlamed) $ do allowedVoters' <- use allowedVoters tell [scapegoatChoseAllowedVotersMessage allowedVoters']@@ -99,8 +117,7 @@ setPlayerAllegiance (wildChild ^. name) Werewolves - tell [playerJoinedPackMessage (wildChild ^. name) aliveWerewolfNames]- tell $ wildChildJoinedPackMessages aliveWerewolfNames (wildChild ^. name)+ tell $ wildChildJoinedPackMessages (wildChild ^. name) aliveWerewolfNames advanceStage @@ -115,19 +132,13 @@ VillagesTurn -> whenM (null <$> liftM2 intersect getAllowedVoters getPendingVoters) $ do tell . map (uncurry playerMadeLynchVoteMessage) =<< uses votes Map.toList - getVoteResult >>= lynchVotees-- allVoters <- ifM (use villageIdiotRevealed)- (uses players $ filter (isn't villageIdiot))- (use players)- allowedVoters .= allVoters ^.. traverse . alive . name- advanceStage WerewolvesTurn -> whenM (none (is werewolf) <$> getPendingVoters) $ do getVoteResult >>= devourVotees protect .= Nothing+ votes .= Map.empty advanceStage @@ -195,7 +206,6 @@ stage .= nextStage passes .= [] see .= Nothing- votes .= Map.empty tell . stageMessages =<< get
src/Game/Werewolf/Game.hs view
@@ -21,8 +21,9 @@ poisonUsed, priorProtect, protect, roleModel, scapegoatBlamed, see, villageIdiotRevealed, votes, Stage(..),- _DefendersTurn, _GameOver, _ScapegoatsTurn, _SeersTurn, _Sunrise, _Sunset, _UrsussGrunt,- _VillagesTurn, _WerewolvesTurn, _WildChildsTurn, _WitchsTurn, _WolfHoundsTurn,+ _DefendersTurn, _DevotedServantsTurn, _GameOver, _Lynching, _ScapegoatsTurn, _SeersTurn,+ _Sunrise, _Sunset, _UrsussGrunt, _VillagesTurn, _WerewolvesTurn, _WildChildsTurn, _WitchsTurn,+ _WolfHoundsTurn, allStages, stageCycle, stageAvailable,@@ -106,9 +107,9 @@ -- -- Once the game reaches a turn stage, it requires a 'Game.Werewolf.Command.Command' to help push -- it past. Often only certain roles and commands may be performed at any given stage.-data Stage = GameOver | DefendersTurn | ScapegoatsTurn | SeersTurn | Sunrise | Sunset- | UrsussGrunt | VillagesTurn | WerewolvesTurn | WildChildsTurn | WitchsTurn- | WolfHoundsTurn+data Stage = DefendersTurn | DevotedServantsTurn | GameOver | Lynching | ScapegoatsTurn+ | SeersTurn | Sunrise | Sunset | UrsussGrunt | VillagesTurn | WerewolvesTurn+ | WildChildsTurn | WitchsTurn | WolfHoundsTurn deriving (Eq, Read, Show) -- | Events occur /after/ a 'Stage' is advanced. This is automatically handled in@@ -133,6 +134,8 @@ allStages :: [Stage] allStages = [ VillagesTurn+ , DevotedServantsTurn+ , Lynching , ScapegoatsTurn , Sunset , WolfHoundsTurn@@ -153,29 +156,34 @@ -- | Checks whether the stage is available for the given 'Game'. Most often this just involves -- checking if there is an applicable role alive, but sometimes it is more complex. ----- One of the most complex checks here is for the 'VillagesTurn'. If the Angel is in play, then+-- One of the more complex checks here is for the 'VillagesTurn'. If the Angel is in play, then -- the 'VillagesTurn' is available on the first day rather than only after the first night. stageAvailable :: Game -> Stage -> Bool-stageAvailable game DefendersTurn = has (players . defenders . alive) game-stageAvailable _ GameOver = False-stageAvailable game ScapegoatsTurn = game ^. scapegoatBlamed-stageAvailable game SeersTurn = has (players . seers . alive) game-stageAvailable _ Sunrise = True-stageAvailable _ Sunset = True-stageAvailable game UrsussGrunt = has (players . bearTamers . alive) game-stageAvailable game VillagesTurn =+stageAvailable game DefendersTurn = has (players . defenders . alive) game+stageAvailable game DevotedServantsTurn =+ has (players . devotedServants . alive) game+ && length (getVoteResult game) == 1+ && isn't devotedServant (head $ getVoteResult game)+stageAvailable _ GameOver = False+stageAvailable game Lynching = Map.size (game ^. votes) > 0+stageAvailable game ScapegoatsTurn = game ^. scapegoatBlamed+stageAvailable game SeersTurn = has (players . seers . alive) game+stageAvailable _ Sunrise = True+stageAvailable _ Sunset = True+stageAvailable game UrsussGrunt = has (players . bearTamers . alive) game+stageAvailable game VillagesTurn = (has (players . angels . alive) game || not (isFirstRound game)) && any (is alive) (getAllowedVoters game)-stageAvailable game WerewolvesTurn = has (players . werewolves . alive) game-stageAvailable game WildChildsTurn =+stageAvailable game WerewolvesTurn = has (players . werewolves . alive) game+stageAvailable game WildChildsTurn = has (players . wildChildren . alive) game && isNothing (game ^. roleModel)-stageAvailable game WitchsTurn =+stageAvailable game WitchsTurn = has (players . witches . alive) game && (not (game ^. healUsed) || not (game ^. poisonUsed))-stageAvailable game WolfHoundsTurn =+stageAvailable game WolfHoundsTurn = has (players . wolfHounds . alive) game- && (isNothing $ game ^. allegianceChosen)+ && isNothing (game ^. allegianceChosen) -- | Creates a new 'Game' with the given players. No validations are performed here, those are left -- to 'Game.Werewolf.Engine.startGame'.@@ -224,7 +232,9 @@ -- | Gets all players that had /the/ highest vote count. This could be 1 or more players depending -- on whether the votes were in conflict. getVoteResult :: Game -> [Player]-getVoteResult game = map (\name' -> game ^?! players . traverse . filteredBy name name') result+getVoteResult game+ | Map.null (game ^. votes) = []+ | otherwise = map (\name' -> game ^?! players . traverse . filteredBy name name') result where votees = Map.elems $ game ^. votes result = last $ groupSortOn (length . (`elemIndices` votees)) (nub votees)
src/Game/Werewolf/Messages.hs view
@@ -45,6 +45,9 @@ -- ** Error messages playerCannotProtectSamePlayerTwiceInARowMessage, + -- * Devoted Servant's turn messages+ devotedServantRevealedMessage, devotedServantJoinedPackMessages,+ -- * Scapegoat's turn messages scapegoatChoseAllowedVotersMessage, @@ -68,7 +71,7 @@ playerCannotDevourAnotherWerewolfMessage, -- * Wild-child's turn messages- playerJoinedPackMessage, wildChildJoinedPackMessages,+ wildChildJoinedPackMessages, -- ** Error messages playerCannotChooseSelfMessage,@@ -136,25 +139,29 @@ stageMessages :: Game -> [Message] stageMessages game = case game ^. stage of- GameOver -> []- DefendersTurn -> defendersTurnMessages defendersName- ScapegoatsTurn -> scapegoatsTurnMessages scapegoatsName- SeersTurn -> seersTurnMessages seersName- Sunrise -> [sunriseMessage]- Sunset -> [nightFallsMessage]- UrsussGrunt -> []- VillagesTurn -> if isFirstRound game+ DefendersTurn -> defendersTurnMessages defendersName+ DevotedServantsTurn -> devotedServantsTurnMessages devotedServantsName victimsName+ GameOver -> []+ Lynching -> []+ ScapegoatsTurn -> scapegoatsTurnMessages scapegoatsName+ SeersTurn -> seersTurnMessages seersName+ Sunrise -> [sunriseMessage]+ Sunset -> [nightFallsMessage]+ UrsussGrunt -> []+ VillagesTurn -> if isFirstRound game then firstVillagesTurnMessages else villagesTurnMessages- WerewolvesTurn -> if isFirstRound game+ WerewolvesTurn -> if isFirstRound game then firstWerewolvesTurnMessages aliveWerewolfNames else werewolvesTurnMessages aliveWerewolfNames- WildChildsTurn -> wildChildsTurnMessages wildChildsName- WitchsTurn -> witchsTurnMessages game- WolfHoundsTurn -> wolfHoundsTurnMessages wolfHoundsName+ WildChildsTurn -> wildChildsTurnMessages wildChildsName+ WitchsTurn -> witchsTurnMessages game+ WolfHoundsTurn -> wolfHoundsTurnMessages wolfHoundsName where players' = game ^. players defendersName = players' ^?! defenders . name+ devotedServantsName = players' ^?! devotedServants . name+ victimsName = head (getVoteResult game) ^. name scapegoatsName = players' ^?! scapegoats . name seersName = players' ^?! seers . name aliveWerewolfNames = players' ^.. werewolves . alive . name@@ -167,6 +174,13 @@ , privateMessage to "Whom would you like to `protect`?" ] +devotedServantsTurnMessages :: Text -> Text -> [Message]+devotedServantsTurnMessages to victimsName =+ [ publicMessage "The Devoted Servant ponders."+ , privateMessage to $ T.concat+ ["Would you like to `reveal` yourself and take on ", victimsName, "'s role?"]+ ]+ scapegoatsTurnMessages :: Text -> [Message] scapegoatsTurnMessages scapegoatsName = [ publicMessage "Just before he burns to a complete crisp, he cries out a dying wish."@@ -271,12 +285,14 @@ [ [publicMessage "The game is over! The Villagers have won."] , [playerRolesMessage] , playerWonMessages+ , playerContributedMessages , playerLostMessages ] | hasWerewolvesWon game = concat [ [publicMessage "The game is over! The Werewolves have won."] , [playerRolesMessage] , playerWonMessages+ , playerContributedMessages , playerLostMessages ] | otherwise = undefined@@ -297,17 +313,21 @@ | hasWerewolvesWon game = Werewolves | otherwise = undefined - winningPlayerNames = game ^.. players . traverse . filteredBy (role . allegiance) winningAllegiance . name- losingPlayerNames = game ^.. players . names \\ winningPlayerNames+ winningPlayers = game ^.. players . traverse . filteredBy (role . allegiance) winningAllegiance+ losingPlayers = game ^. players \\ winningPlayers - playerWonMessages = map playerWonMessage winningPlayerNames- playerLostMessages = map playerLostMessage losingPlayerNames+ playerWonMessages = map playerWonMessage (winningPlayers ^.. traverse . alive . name)+ playerContributedMessages = map playerContributedMessage (winningPlayers ^.. traverse . dead . name)+ playerLostMessages = map playerLostMessage (losingPlayers ^.. names) playerWonMessage :: Text -> Message playerWonMessage to = privateMessage to "Victory! You won!" +playerContributedMessage :: Text -> Message+playerContributedMessage to = privateMessage to "Your team won, but you died. Congratulations?"+ playerLostMessage :: Text -> Message-playerLostMessage to = privateMessage to "Feck, you lost this time round..."+playerLostMessage to = privateMessage to "Feck, you lost this time round." playerQuitMessage :: Player -> Message playerQuitMessage player = publicMessage $ T.unwords [playerName, "the", playerRole, "has quit!"]@@ -349,6 +369,7 @@ currentStageMessages :: Text -> Stage -> [Message] currentStageMessages to GameOver = [gameIsOverMessage to]+currentStageMessages _ Lynching = [] currentStageMessages _ Sunrise = [] currentStageMessages _ Sunset = [] currentStageMessages _ UrsussGrunt = []@@ -357,18 +378,20 @@ ]] where showTurn :: Stage -> Text- showTurn DefendersTurn = "Defender's"- showTurn GameOver = undefined- showTurn ScapegoatsTurn = "Scapegoat's"- showTurn SeersTurn = "Seer's"- showTurn Sunrise = undefined- showTurn Sunset = undefined- showTurn UrsussGrunt = undefined- showTurn VillagesTurn = "Village's"- showTurn WerewolvesTurn = "Werewolves'"- showTurn WildChildsTurn = "Wild-child's"- showTurn WitchsTurn = "Witch's"- showTurn WolfHoundsTurn = "Wolf-hound's"+ showTurn DefendersTurn = "Defender's"+ showTurn DevotedServantsTurn = "Devoted Servant's"+ showTurn GameOver = undefined+ showTurn Lynching = undefined+ showTurn ScapegoatsTurn = "Scapegoat's"+ showTurn SeersTurn = "Seer's"+ showTurn Sunrise = undefined+ showTurn Sunset = undefined+ showTurn UrsussGrunt = undefined+ showTurn VillagesTurn = "village's"+ showTurn WerewolvesTurn = "Werewolves'"+ showTurn WildChildsTurn = "Wild-child's"+ showTurn WitchsTurn = "Witch's"+ showTurn WolfHoundsTurn = "Wolf-hound's" rolesInGameMessage :: Maybe Text -> [Role] -> Message rolesInGameMessage mTo roles = Message mTo $ T.concat@@ -419,6 +442,25 @@ playerCannotProtectSamePlayerTwiceInARowMessage to = privateMessage to "You cannot protect the same player twice in a row!" +devotedServantRevealedMessage :: Text -> Message+devotedServantRevealedMessage devotedServantsName = publicMessage $ T.unwords+ [ devotedServantsName, " the stands up in horror."+ , "Determined to not let their master's abilities be lost forever,"+ , "she selflessly takes on their role."+ ]++devotedServantJoinedPackMessages :: Text -> [Text] -> [Message]+devotedServantJoinedPackMessages devotedServantsName werewolfNames =+ -- TODO (hjw): what if the pack's empty?+ privateMessage devotedServantsName (T.unwords+ [ "Upon learning your master was a Werewolf, you head towards the woods to learn more about his home and family."+ , "As you enter you see his pack", T.intercalate ", " werewolfNames+ , "waiting for you."+ ])+ : groupMessages werewolfNames (T.unwords+ [ devotedServantsName, "heads towards the woods in search of his master's home and family."+ ])+ scapegoatChoseAllowedVotersMessage :: [Text] -> Message scapegoatChoseAllowedVotersMessage allowedVoters = publicMessage $ T.unwords [ "On the next day only", T.intercalate ", " allowedVoters, "shall be allowed to vote."@@ -512,20 +554,19 @@ playerCannotDevourAnotherWerewolfMessage :: Text -> Message playerCannotDevourAnotherWerewolfMessage to = privateMessage to "You cannot devour another Werewolf!" -playerJoinedPackMessage :: Text -> [Text] -> Message-playerJoinedPackMessage to werewolfNames = privateMessage to $ T.unwords- [ "The death of your role model is distressing."- , "Without second thought you abandon the Villagers and run off into the woods,"- , "towards your old home."- , "As you arrive you see the familiar faces of", T.intercalate ", " werewolfNames- , "waiting and happy to have you back."- ]--wildChildJoinedPackMessages :: [Text] -> Text -> [Message]-wildChildJoinedPackMessages tos wildChildsName = groupMessages tos $ T.unwords- [ wildChildsName, "the Wild-child scampers off into the woods."- , "Without his role model nothing is holding back his true, wolfish, nature."- ]+wildChildJoinedPackMessages :: Text -> [Text] -> [Message]+wildChildJoinedPackMessages wildChildsName werewolfNames =+ privateMessage wildChildsName (T.unwords+ [ "The death of your role model is distressing."+ , "Without second thought you abandon the Villagers and run off into the woods,"+ , "towards your old home."+ , "As you arrive you see the familiar faces of", T.intercalate ", " werewolfNames+ , "waiting and happy to have you back."+ ])+ : groupMessages werewolfNames (T.unwords+ [ wildChildsName, "the Wild-child scampers off into the woods."+ , "Without his role model nothing is holding back his true, wolfish, nature."+ ]) playerCannotChooseSelfMessage :: Text -> Message playerCannotChooseSelfMessage to = privateMessage to "You cannot choose yourself!"
src/Game/Werewolf/Player.hs view
@@ -26,16 +26,16 @@ newPlayer, -- ** Traversals- angel, bearTamer, defender, scapegoat, seer, simpleVillager, simpleWerewolf, villageIdiot,- villagerVillager, wildChild, witch, wolfHound,+ angel, bearTamer, defender, devotedServant, scapegoat, seer, simpleVillager, simpleWerewolf,+ villageIdiot, villagerVillager, wildChild, witch, wolfHound, villager, werewolf, -- | These are provided just as a bit of sugar to avoid continually writing @'traverse' .@. names, roles, states, -- | N.B., these are not legal traversals for the same reason 'filtered' isn't!- angels, bearTamers, defenders, scapegoats, seers, simpleVillagers, simpleWerewolves,- villageIdiots, villagerVillagers, wildChildren, witches, wolfHounds,+ angels, bearTamers, defenders, devotedServants, scapegoats, seers, simpleVillagers,+ simpleWerewolves, villageIdiots, villagerVillagers, wildChildren, witches, wolfHounds, villagers, werewolves, alive, dead, @@ -99,6 +99,14 @@ defender :: Traversal' Player () defender = role . only defenderRole +-- | The traversal of 'Player's with a 'devotedServantRole'.+--+-- @+-- 'devotedServant' = 'role' . 'only' 'devotedServantRole'+-- @+devotedServant :: Traversal' Player ()+devotedServant = role . only devotedServantRole+ -- | The traversal of 'Player's with a 'scapegoatRole'. -- -- @@@ -234,6 +242,14 @@ -- @ defenders :: Traversable t => Traversal' (t Player) Player defenders = traverse . filtered (is defender)++-- | This 'Traversal' provides the traversal of 'devotedServant' 'Player's.+--+-- @+-- 'devotedServants' = 'traverse' . 'filtered' ('is' 'devotedServant')+-- @+devotedServants :: Traversable t => Traversal' (t Player) Player+devotedServants = traverse . filtered (is devotedServant) -- | This 'Traversal' provides the traversal of 'scapegoat' 'Player's. --
src/Game/Werewolf/Role.hs view
@@ -31,20 +31,32 @@ allAllegiances, -- *** The Ambiguous- -- | The Ambiguous may change allegiance during the game.- wildChildRole, wolfHoundRole,+ -- | They could very well be allies of the village or become its enemies. During the game, they+ -- can change sides or characters.+ --+ -- The Ambiguous must aid their side to achieve victory.+ devotedServantRole, wildChildRole, wolfHoundRole, -- *** The Loners- -- | The Loners have their own win condition.+ -- | Their past could no doubt reveal to us why they hate the inhabitants of Miller's Hollow.+ -- One thing is known for sure: they really scare everyone!+ --+ -- The Loners have their own objectives, no matter which side they're on. angelRole, -- *** The Villagers- -- | The Villagers must lynch all of the Werewolves.+ -- | Attached to the village's survival, the following characters defend its harmony with+ -- determination. Faced with various menaces, they will be brought to eliminate those they+ -- suspect of being too dangerous, even if that might be painful to them.+ --+ -- The Villagers must lynch all of the Werewolves. bearTamerRole, defenderRole, scapegoatRole, seerRole, simpleVillagerRole, villageIdiotRole, villagerVillagerRole, witchRole, -- *** The Werewolves- -- | The Werewolves must devour all of the Villagers.+ -- | They can be lethally dangerous and put in doubt the village's survival.+ --+ -- The Werewolves must devour all of the Villagers. simpleWerewolfRole, -- * Utility functions@@ -94,6 +106,7 @@ [ angelRole , bearTamerRole , defenderRole+ , devotedServantRole , scapegoatRole , seerRole , simpleVillagerRole@@ -118,6 +131,30 @@ -- TODO (hjw): use reflection to get this list allAllegiances :: [Allegiance] allAllegiances = [Angel, Villagers, Werewolves]++-- | /Who could dream of a better servant than one willing to give up her life for that of her/+-- /masters? Don't rejoice too fast, as the devouring ambition within her could spell the end of/+-- /the village!/+--+-- Before the revelation of the card of the player eliminated by the village's vote, she can+-- reveal herself by showing her card and taking on the role of the eliminated player.+devotedServantRole :: Role+devotedServantRole = Role+ { _name = "Devoted Servant"+ , _allegiance = Villagers+ , _balance = 1+ , _description = T.unwords+ [ "Who could dream of a better servant than one willing to give up her life for that of her"+ , "masters?"+ , "Don't rejoice too fast,"+ , "as the devouring ambition within her could spell the end of the village!"+ ]+ , _advice = T.unwords+ [ "Think twice before trying to take on the role of a Werewolf."+ , "If people strongly believed your master as such,"+ , "then they will be quick to point fingers at you too!"+ ]+ } -- | /Abandoned in the woods by his parents at a young age, he was raised by wolves. As soon as he/ -- /learned how to walk on all fours, the Wild-child began to wander around Miller's Hollow. One/
src/Game/Werewolf/Util.hs view
@@ -17,23 +17,23 @@ -- * Game -- ** Manipulations- killPlayer, setPlayerAllegiance,+ killPlayer, setPlayerAllegiance, setPlayerRole, -- ** Searches findPlayerBy_, getAdjacentAlivePlayers, getPassers, getPlayerVote, getAllowedVoters, getPendingVoters, getVoteResult, -- ** Queries- isDefendersTurn, isGameOver, isScapegoatsTurn, isSeersTurn, isSunrise, isVillagesTurn,- isWerewolvesTurn, isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn,+ isDefendersTurn, isDevotedServantsTurn, isGameOver, isScapegoatsTurn, isSeersTurn, isSunrise,+ isVillagesTurn, isWerewolvesTurn, isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn, hasAnyoneWon, hasAngelWon, hasVillagersWon, hasWerewolvesWon, -- * Player -- ** Queries doesPlayerExist,- isPlayerDefender, isPlayerScapegoat, isPlayerSeer, isPlayerVillageIdiot, isPlayerWildChild,- isPlayerWitch, isPlayerWolfHound,+ isPlayerDefender, isPlayerDevotedServant, isPlayerScapegoat, isPlayerSeer, isPlayerVillageIdiot,+ isPlayerWildChild, isPlayerWitch, isPlayerWolfHound, isPlayerWerewolf, isPlayerAlive, isPlayerDead, ) where@@ -63,6 +63,11 @@ setPlayerAllegiance :: MonadState Game m => Text -> Allegiance -> m () setPlayerAllegiance name' allegiance' = modify $ players . traverse . filteredBy name name' . role . allegiance .~ allegiance' +-- | Fudges the player's role. This function is useful for roles such as the Devoted Servant where+-- they take on a different role.+setPlayerRole :: MonadState Game m => Text -> Role -> m ()+setPlayerRole name' role' = modify $ players . traverse . filteredBy name name' . role .~ role'+ findPlayerBy_ :: (Eq a, MonadState Game m) => Lens' Player a -> a -> m Player findPlayerBy_ lens value = fromJust <$> preuse (players . traverse . filteredBy lens value) @@ -94,6 +99,9 @@ isDefendersTurn :: MonadState Game m => m Bool isDefendersTurn = has (stage . _DefendersTurn) <$> get +isDevotedServantsTurn :: MonadState Game m => m Bool+isDevotedServantsTurn = has (stage . _DevotedServantsTurn) <$> get+ isGameOver :: MonadState Game m => m Bool isGameOver = has (stage . _GameOver) <$> get @@ -138,6 +146,9 @@ isPlayerDefender :: MonadState Game m => Text -> m Bool isPlayerDefender name' = is defender <$> findPlayerBy_ name name'++isPlayerDevotedServant :: MonadState Game m => Text -> m Bool+isPlayerDevotedServant name' = is devotedServant <$> findPlayerBy_ name name' isPlayerScapegoat :: MonadState Game m => Text -> m Bool isPlayerScapegoat name' = is scapegoat <$> findPlayerBy_ name name'
test/src/Game/Werewolf/Test/Arbitrary.hs view
@@ -12,15 +12,17 @@ -- ** Game NewGame(..),- GameAtDefendersTurn(..), GameAtGameOver(..), GameAtScapegoatsTurn(..), GameAtSeersTurn(..),- GameAtSunrise(..), GameAtVillagesTurn(..), GameAtWerewolvesTurn(..), GameAtWildChildsTurn(..),- GameAtWitchsTurn(..), GameAtWolfHoundsTurn(..),+ GameAtDefendersTurn(..), GameAtDevotedServantsTurn(..), GameAtGameOver(..),+ GameAtScapegoatsTurn(..), GameAtSeersTurn(..), GameAtSunrise(..), GameAtVillagesTurn(..),+ GameAtWerewolvesTurn(..), GameAtWildChildsTurn(..), GameAtWitchsTurn(..),+ GameAtWolfHoundsTurn(..), GameOnSecondRound(..),- GameWithAllegianceChosen(..), GameWithAllowedVoters(..), GameWithDeadPlayers(..),- GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..), GameWithLynchVotes(..),- GameWithOneAllegianceAlive(..), GameWithPoison(..), GameWithProtect(..),+ GameWithAllegianceChosen(..), GameWithAllowedVoters(..), GameWithConflictingVote(..),+ GameWithDeadPlayers(..), GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..),+ GameWithLynchVotes(..), GameWithMajorityVote(..), GameWithOneAllegianceAlive(..),+ GameWithPassAtDevotedServantsTurn(..), GameWithPoison(..), GameWithProtect(..), GameWithProtectAndDevourVotes(..), GameWithRoleModel(..), GameWithRoleModelAtVillagesTurn(..),- GameWithScapegoatBlamed(..), GameWithSee(..), GameWithVillageIdiotRevealedAtVillagesTurn(..),+ GameWithSee(..), GameWithVillageIdiotRevealedAtVillagesTurn(..), -- ** Player arbitraryPlayerSet,@@ -29,9 +31,10 @@ -- ** Command arbitraryCommand, arbitraryChooseAllegianceCommand, arbitraryChoosePlayerCommand,- arbitraryChoosePlayersCommand, arbitraryHealCommand, arbitraryPassCommand,- arbitraryPoisonCommand, arbitraryProtectCommand, arbitraryQuitCommand, arbitrarySeeCommand,- arbitraryVoteDevourCommand, arbitraryVoteLynchCommand,+ arbitraryChoosePlayersCommand, arbitraryHealCommand, arbitraryPassDevotedServantsTurnCommand,+ arbitraryPassWitchsTurnCommand, arbitraryPoisonCommand, arbitraryProtectCommand,+ arbitraryQuitCommand, arbitraryRevealCommand, arbitrarySeeCommand, arbitraryVoteDevourCommand,+ arbitraryVoteLynchCommand, runArbitraryCommands, -- ** Player@@ -96,6 +99,16 @@ return $ GameAtDefendersTurn (game & stage .~ DefendersTurn) +newtype GameAtDevotedServantsTurn = GameAtDevotedServantsTurn Game+ deriving (Eq, Show)++instance Arbitrary GameAtDevotedServantsTurn where+ arbitrary = do+ (GameWithMajorityVote game) <- suchThat arbitrary $ \(GameWithMajorityVote game) ->+ isn't devotedServant (head $ getVoteResult game)++ return $ GameAtDevotedServantsTurn (run_ checkStage game)+ newtype GameAtGameOver = GameAtGameOver Game deriving (Eq, Show) @@ -110,7 +123,7 @@ instance Arbitrary GameAtScapegoatsTurn where arbitrary = do- (GameWithScapegoatBlamed game) <- arbitrary+ (GameWithConflictingVote game) <- arbitrary return $ GameAtScapegoatsTurn (run_ checkStage game) @@ -206,6 +219,16 @@ return $ GameWithAllowedVoters (run_ (apply command) game) +newtype GameWithConflictingVote = GameWithConflictingVote Game+ deriving (Eq, Show)++instance Arbitrary GameWithConflictingVote where+ arbitrary = do+ (GameWithLynchVotes game) <- suchThat arbitrary $ \(GameWithLynchVotes game) ->+ length (getVoteResult game) > 1++ return $ GameWithConflictingVote game+ newtype GameWithDeadPlayers = GameWithDeadPlayers Game deriving (Eq, Show) @@ -255,6 +278,25 @@ GameWithLynchVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ VillagesTurn) +newtype GameWithMajorityVote = GameWithMajorityVote Game+ deriving (Eq, Show)++instance Arbitrary GameWithMajorityVote where+ arbitrary = do+ (GameWithLynchVotes game) <- suchThat arbitrary $ \(GameWithLynchVotes game) ->+ length (getVoteResult game) == 1++ return $ GameWithMajorityVote game++newtype GameWithMajorityVoteAtDevotedServantsTurn = GameWithMajorityVoteAtDevotedServantsTurn Game+ deriving (Eq, Show)++instance Arbitrary GameWithMajorityVoteAtDevotedServantsTurn where+ arbitrary = do+ (GameWithMajorityVote game) <- arbitrary++ return . GameWithMajorityVoteAtDevotedServantsTurn $ run_ checkStage game+ newtype GameWithOneAllegianceAlive = GameWithOneAllegianceAlive Game deriving (Eq, Show) @@ -267,16 +309,26 @@ return $ GameWithOneAllegianceAlive game' -newtype GameWithPass = GameWithPass Game+newtype GameWithPassAtDevotedServantsTurn = GameWithPassAtDevotedServantsTurn Game deriving (Eq, Show) -instance Arbitrary GameWithPass where+instance Arbitrary GameWithPassAtDevotedServantsTurn where arbitrary = do+ (GameAtDevotedServantsTurn game) <- arbitrary+ (Blind command) <- arbitraryPassDevotedServantsTurnCommand game++ return $ GameWithPassAtDevotedServantsTurn (run_ (apply command) game)++newtype GameWithPassAtWitchsTurn = GameWithPassAtWitchsTurn Game+ deriving (Eq, Show)++instance Arbitrary GameWithPassAtWitchsTurn where+ arbitrary = do game <- arbitrary let game' = game & stage .~ WitchsTurn- (Blind command) <- arbitraryPassCommand game'+ (Blind command) <- arbitraryPassWitchsTurnCommand game' - return $ GameWithPass (run_ (apply command) game')+ return $ GameWithPassAtWitchsTurn (run_ (apply command) game') newtype GameWithPoison = GameWithPoison Game deriving (Eq, Show)@@ -330,16 +382,6 @@ return $ GameWithRoleModelAtVillagesTurn (game & stage .~ VillagesTurn) -newtype GameWithScapegoatBlamed = GameWithScapegoatBlamed Game- deriving (Eq, Show)--instance Arbitrary GameWithScapegoatBlamed where- arbitrary = do- (GameWithLynchVotes game) <- suchThat arbitrary $ \(GameWithLynchVotes game) ->- length (getVoteResult game) > 1-- return $ GameWithScapegoatBlamed game- newtype GameWithSee = GameWithSee Game deriving (Eq, Show) @@ -385,22 +427,27 @@ arbitraryCommand :: Game -> Gen (Blind Command) arbitraryCommand game = case game ^. stage of- GameOver -> return $ Blind noopCommand- DefendersTurn -> arbitraryProtectCommand game- ScapegoatsTurn -> arbitraryChoosePlayersCommand game- SeersTurn -> arbitrarySeeCommand game- Sunrise -> return $ Blind noopCommand- Sunset -> return $ Blind noopCommand- UrsussGrunt -> return $ Blind noopCommand- VillagesTurn -> arbitraryVoteLynchCommand game- WerewolvesTurn -> arbitraryVoteDevourCommand game- WildChildsTurn -> arbitraryChoosePlayerCommand game- WitchsTurn -> oneof [- arbitraryHealCommand game,- arbitraryPassCommand game,- arbitraryPoisonCommand game+ DefendersTurn -> arbitraryProtectCommand game+ DevotedServantsTurn -> oneof+ [ arbitraryPassDevotedServantsTurnCommand game+ , arbitraryRevealCommand game ]- WolfHoundsTurn -> arbitraryChooseAllegianceCommand game+ GameOver -> return $ Blind noopCommand+ Lynching -> return $ Blind noopCommand+ ScapegoatsTurn -> arbitraryChoosePlayersCommand game+ SeersTurn -> arbitrarySeeCommand game+ Sunrise -> return $ Blind noopCommand+ Sunset -> return $ Blind noopCommand+ UrsussGrunt -> return $ Blind noopCommand+ VillagesTurn -> arbitraryVoteLynchCommand game+ WerewolvesTurn -> arbitraryVoteDevourCommand game+ WildChildsTurn -> arbitraryChoosePlayerCommand game+ WitchsTurn -> oneof+ [ arbitraryHealCommand game+ , arbitraryPassWitchsTurnCommand game+ , arbitraryPoisonCommand game+ ]+ WolfHoundsTurn -> arbitraryChooseAllegianceCommand game arbitraryChooseAllegianceCommand :: Game -> Gen (Blind Command) arbitraryChooseAllegianceCommand game = do@@ -431,11 +478,17 @@ then noopCommand else healCommand witchsName -arbitraryPassCommand :: Game -> Gen (Blind Command)-arbitraryPassCommand game = do+arbitraryPassDevotedServantsTurnCommand :: Game -> Gen (Blind Command)+arbitraryPassDevotedServantsTurnCommand game = do+ let devotedServantsName = game ^?! players . devotedServants . name++ return . Blind $ passDevotedServantsTurnCommand devotedServantsName++arbitraryPassWitchsTurnCommand :: Game -> Gen (Blind Command)+arbitraryPassWitchsTurnCommand game = do let witchsName = game ^?! players . witches . name - return . Blind $ passCommand witchsName+ return . Blind $ passWitchsTurnCommand witchsName arbitraryPoisonCommand :: Game -> Gen (Blind Command) arbitraryPoisonCommand game = do@@ -464,6 +517,12 @@ then return $ Blind noopCommand else elements applicableCallerNames >>= \callersName -> return . Blind $ quitCommand callersName++arbitraryRevealCommand :: Game -> Gen (Blind Command)+arbitraryRevealCommand game = do+ let devotedServantsName = game ^?! players . devotedServants . name++ return . Blind $ revealCommand devotedServantsName arbitrarySeeCommand :: Game -> Gen (Blind Command) arbitrarySeeCommand game = do
test/src/Game/Werewolf/Test/Command.hs view
@@ -12,873 +12,27 @@ allCommandTests, ) where -import Control.Lens hiding (elements, isn't)--import Data.Either.Extra-import qualified Data.Map as Map-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T--import Game.Werewolf.Command-import Game.Werewolf.Engine (checkStage)-import Game.Werewolf.Game-import Game.Werewolf.Player-import Game.Werewolf.Role hiding (name)-import Game.Werewolf.Test.Arbitrary-import Game.Werewolf.Test.Util+import Game.Werewolf.Test.Command.Choose+import Game.Werewolf.Test.Command.Heal+import Game.Werewolf.Test.Command.Pass+import Game.Werewolf.Test.Command.Poison+import Game.Werewolf.Test.Command.Protect+import Game.Werewolf.Test.Command.Quit+import Game.Werewolf.Test.Command.Reveal+import Game.Werewolf.Test.Command.See+import Game.Werewolf.Test.Command.Vote import Test.Tasty-import Test.Tasty.QuickCheck allCommandTests :: [TestTree]-allCommandTests =- [ testProperty "choose allegiance command errors when game is over" prop_chooseAllegianceCommandErrorsWhenGameIsOver- , testProperty "choose allegiance command errors when caller does not exist" prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist- , testProperty "choose allegiance command errors when caller is dead" prop_chooseAllegianceCommandErrorsWhenCallerIsDead- , testProperty "choose allegiance command errors when not wolf-hound's turn" prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn- , testProperty "choose allegiance command errors when caller not wolf-hound" prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound- , testProperty "choose allegiance command errors when allegiance does not exist" prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist- , testProperty "choose allegiance command sets allegiance chosen" prop_chooseAllegianceCommandSetsAllegianceChosen-- , testProperty "choose player command errors when game is over" prop_choosePlayerCommandErrorsWhenGameIsOver- , testProperty "choose player command errors when caller does not exist" prop_choosePlayerCommandErrorsWhenCallerDoesNotExist- , testProperty "choose player command errors when target does not exist" prop_choosePlayerCommandErrorsWhenTargetDoesNotExist- , testProperty "choose player command errors when caller is dead" prop_choosePlayerCommandErrorsWhenCallerIsDead- , testProperty "choose player command errors when target is dead" prop_choosePlayerCommandErrorsWhenTargetIsDead- , testProperty "choose player command errors when target is caller" prop_choosePlayerCommandErrorsWhenTargetIsCaller- , testProperty "choose player command errors when not wild-child's turn" prop_choosePlayerCommandErrorsWhenNotWildChildsTurn- , testProperty "choose player command errors when caller not wild-child" prop_choosePlayerCommandErrorsWhenCallerNotWildChild- , testProperty "choose player command sets role model" prop_choosePlayerCommandSetsRoleModel-- , testProperty "choose players command errors when game is over" prop_choosePlayersCommandErrorsWhenGameIsOver- , testProperty "choose players command errors when caller does not exist" prop_choosePlayersCommandErrorsWhenCallerDoesNotExist- , testProperty "choose players command errors when any target does not exist" prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist- , testProperty "choose players command errors when any target is dead" prop_choosePlayersCommandErrorsWhenAnyTargetIsDead- , testProperty "choose players command errors when not scapegoat's turn" prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn- , testProperty "choose players command errors when caller not scapegoat" prop_choosePlayersCommandErrorsWhenCallerNotScapegoat- , testProperty "choose players command sets allowed voters" prop_choosePlayersCommandSetsAllowedVoters- , testProperty "choose players command resets scapegoat blamed" prop_choosePlayersCommandResetsScapegoatBlamed-- , testProperty "heal command errors when game is over" prop_healCommandErrorsWhenGameIsOver- , testProperty "heal command errors when caller does not exist" prop_healCommandErrorsWhenCallerDoesNotExist- , testProperty "heal command errors when caller is dead" prop_healCommandErrorsWhenCallerIsDead- , 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 "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- -- TODO (hjw): implement this test case- --, testProperty "poison command errors when caller devoured and not healed" prop_poisonCommandErrorsWhenCallerDevouredAndNotHealed- , testProperty "poison command sets poison" prop_poisonCommandSetsPoison- , testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed-- , 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 prior protect" prop_protectCommandErrorsWhenTargetIsPriorProtect- , testProperty "protect command sets prior protect" prop_protectCommandSetsPriorProtect- , testProperty "protect command sets protect" prop_protectCommandSetsProtect-- , 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 allegiance chosen when caller is wolf-hound" prop_quitCommandClearsAllegianceChosenWhenCallerIsWolfHound- , 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 "quit command clears role model when caller is wild-child" prop_quitCommandClearsRoleModelWhenCallerIsWildChild- , testProperty "quit command sets angel's allegiance when caller is angel" prop_quitCommandSetsAngelsAllegianceWhenCallerIsAngel-- , 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 "vote devour command errors when game is over" prop_voteDevourCommandErrorsWhenGameIsOver- , testProperty "vote devour command errors when caller does not exist" prop_voteDevourCommandErrorsWhenCallerDoesNotExist- , testProperty "vote devour command errors when target does not exist" prop_voteDevourCommandErrorsWhenTargetDoesNotExist- , testProperty "vote devour command errors when caller is dead" prop_voteDevourCommandErrorsWhenCallerIsDead- , testProperty "vote devour command errors when target is dead" prop_voteDevourCommandErrorsWhenTargetIsDead- , testProperty "vote devour command errors when not werewolves turn" prop_voteDevourCommandErrorsWhenNotWerewolvesTurn- , testProperty "vote devour command errors when caller not werewolf" prop_voteDevourCommandErrorsWhenCallerNotWerewolf- , testProperty "vote devour command errors when caller has voted" prop_voteDevourCommandErrorsWhenCallerHasVoted- , testProperty "vote devour command errors when target werewolf" prop_voteDevourCommandErrorsWhenTargetWerewolf- , testProperty "vote devour command updates votes" prop_voteDevourCommandUpdatesVotes-- , testProperty "vote lynch command errors when game is over" prop_voteLynchCommandErrorsWhenGameIsOver- , testProperty "vote lynch command errors when caller does not exist" prop_voteLynchCommandErrorsWhenCallerDoesNotExist- , testProperty "vote lynch command errors when target does not exist" prop_voteLynchCommandErrorsWhenTargetDoesNotExist- , testProperty "vote lynch command errors when caller is dead" prop_voteLynchCommandErrorsWhenCallerIsDead- , testProperty "vote lynch command errors when target is dead" prop_voteLynchCommandErrorsWhenTargetIsDead- , testProperty "vote lynch command errors when not villages turn" prop_voteLynchCommandErrorsWhenNotVillagesTurn- , testProperty "vote lynch command errors when caller has voted" prop_voteLynchCommandErrorsWhenCallerHasVoted- , testProperty "vote lynch command errors when caller is not in allowed voters" prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters- , testProperty "vote lynch command errors when caller is known village idiot" prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot- , testProperty "vote lynch command updates votes" prop_voteLynchCommandUpdatesVotes+allCommandTests = concat+ [ allChooseCommandTests+ , allHealCommandTests+ , allPassCommandTests+ , allPoisonCommandTests+ , allProtectCommandTests+ , allQuitCommandTests+ , allRevealCommandTests+ , allSeeCommandTests+ , allVoteCommandTests ]--prop_chooseAllegianceCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_chooseAllegianceCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryChooseAllegianceCommand game) $ verbose_runCommandErrors game . getBlind--prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist :: GameAtWolfHoundsTurn -> Player -> Allegiance -> Property-prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist (GameAtWolfHoundsTurn game) caller allegiance = do- let command = chooseAllegianceCommand (caller ^. name) (T.pack $ show allegiance)-- not (doesPlayerExist (caller ^. name) game)- ==> verbose_runCommandErrors game command--prop_chooseAllegianceCommandErrorsWhenCallerIsDead :: GameAtWolfHoundsTurn -> Allegiance -> Property-prop_chooseAllegianceCommandErrorsWhenCallerIsDead (GameAtWolfHoundsTurn game) allegiance = do- let wolfHound = game ^?! players . wolfHounds- let game' = killPlayer (wolfHound ^. name) game- let command = chooseAllegianceCommand (wolfHound ^. name) (T.pack $ show allegiance)-- verbose_runCommandErrors game' command--prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn :: Game -> Property-prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn game =- hasn't (stage . _WolfHoundsTurn) game- ==> forAll (arbitraryChooseAllegianceCommand game) $ verbose_runCommandErrors game . getBlind--prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound :: GameAtWolfHoundsTurn -> Allegiance -> Property-prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound (GameAtWolfHoundsTurn game) allegiance =- forAll (suchThat (arbitraryPlayer game) (isn't wolfHound)) $ \caller -> do- let command = chooseAllegianceCommand (caller ^. name) (T.pack $ show allegiance)-- verbose_runCommandErrors game command--prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist :: GameAtWolfHoundsTurn -> Text -> Property-prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist (GameAtWolfHoundsTurn game) allegiance = do- let wolfHound = game ^?! players . wolfHounds- let command = chooseAllegianceCommand (wolfHound ^. name) allegiance-- allegiance `notElem` ["Villagers", "Werewolves"]- ==> verbose_runCommandErrors game command--prop_chooseAllegianceCommandSetsAllegianceChosen :: GameAtWolfHoundsTurn -> Property-prop_chooseAllegianceCommandSetsAllegianceChosen (GameAtWolfHoundsTurn game) = do- let wolfHoundsName = game ^?! players . wolfHounds . name-- forAll (elements [Villagers, Werewolves]) $ \allegiance' -> do- let command = chooseAllegianceCommand wolfHoundsName (T.pack $ show allegiance')- let game' = run_ (apply command) game-- fromJust (game' ^. allegianceChosen) === allegiance'--prop_choosePlayerCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_choosePlayerCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryChoosePlayerCommand game) $ verbose_runCommandErrors game . getBlind--prop_choosePlayerCommandErrorsWhenCallerDoesNotExist :: GameAtWildChildsTurn -> Player -> Property-prop_choosePlayerCommandErrorsWhenCallerDoesNotExist (GameAtWildChildsTurn game) caller =- forAll (arbitraryPlayer game) $ \target -> do- let command = choosePlayerCommand (caller ^. name) (target ^. name)-- not (doesPlayerExist (caller ^. name) game)- ==> verbose_runCommandErrors game command--prop_choosePlayerCommandErrorsWhenTargetDoesNotExist :: GameAtWildChildsTurn -> Player -> Property-prop_choosePlayerCommandErrorsWhenTargetDoesNotExist (GameAtWildChildsTurn game) target = do- let wildChild = game ^?! players . wildChildren- let command = choosePlayerCommand (wildChild ^. name) (target ^. name)-- not (doesPlayerExist (target ^. name) game)- ==> verbose_runCommandErrors game command--prop_choosePlayerCommandErrorsWhenCallerIsDead :: GameAtWildChildsTurn -> Property-prop_choosePlayerCommandErrorsWhenCallerIsDead (GameAtWildChildsTurn game) = do- let wildChild = game ^?! players . wildChildren- let game' = killPlayer (wildChild ^. name) game-- forAll (arbitraryPlayer game') $ \target -> do- let command = choosePlayerCommand (wildChild ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_choosePlayerCommandErrorsWhenTargetIsDead :: GameAtWildChildsTurn -> Property-prop_choosePlayerCommandErrorsWhenTargetIsDead (GameAtWildChildsTurn game) = do- let wildChild = game ^?! players . wildChildren-- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = choosePlayerCommand (wildChild ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_choosePlayerCommandErrorsWhenTargetIsCaller :: GameAtWildChildsTurn -> Property-prop_choosePlayerCommandErrorsWhenTargetIsCaller (GameAtWildChildsTurn game) = do- let wildChild = game ^?! players . wildChildren- let command = choosePlayerCommand (wildChild ^. name) (wildChild ^. name)-- verbose_runCommandErrors game command--prop_choosePlayerCommandErrorsWhenNotWildChildsTurn :: Game -> Property-prop_choosePlayerCommandErrorsWhenNotWildChildsTurn game =- hasn't (stage . _WildChildsTurn) game- ==> forAll (arbitraryChoosePlayerCommand game) $ verbose_runCommandErrors game . getBlind--prop_choosePlayerCommandErrorsWhenCallerNotWildChild :: GameAtWildChildsTurn -> Property-prop_choosePlayerCommandErrorsWhenCallerNotWildChild (GameAtWildChildsTurn game) =- forAll (suchThat (arbitraryPlayer game) (isn't wildChild)) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = choosePlayerCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_choosePlayerCommandSetsRoleModel :: GameAtWildChildsTurn -> Property-prop_choosePlayerCommandSetsRoleModel (GameAtWildChildsTurn game) = do- let wildChild = game ^?! players . wildChildren-- forAll (suchThat (arbitraryPlayer game) (wildChild /=)) $ \target -> do- let command = choosePlayerCommand (wildChild ^. name) (target ^. name)- let game' = run_ (apply command) game-- fromJust (game' ^. roleModel) === target ^. name--prop_choosePlayersCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_choosePlayersCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryChoosePlayersCommand game) $ verbose_runCommandErrors game . getBlind--prop_choosePlayersCommandErrorsWhenCallerDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property-prop_choosePlayersCommandErrorsWhenCallerDoesNotExist (GameAtScapegoatsTurn game) caller =- forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do- let command = choosePlayersCommand (caller ^. name) (targets ^.. names)-- not (doesPlayerExist (caller ^. name) game)- ==> verbose_runCommandErrors game command--prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property-prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist (GameAtScapegoatsTurn game) target = do- let scapegoat = game ^?! players . scapegoats- let command = choosePlayersCommand (scapegoat ^. name) [target ^. name]-- not (doesPlayerExist (target ^. name) game)- ==> verbose_runCommandErrors game command--prop_choosePlayersCommandErrorsWhenAnyTargetIsDead :: GameAtScapegoatsTurn -> Property-prop_choosePlayersCommandErrorsWhenAnyTargetIsDead (GameAtScapegoatsTurn game) = do- let scapegoat = game ^?! players . scapegoats-- forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) ->- forAll (elements targets) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = choosePlayersCommand (scapegoat ^. name) (targets ^.. names)-- verbose_runCommandErrors game' command--prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn :: Game -> Property-prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn game =- hasn't (stage . _ScapegoatsTurn) game- ==> forAll (arbitraryChoosePlayersCommand game) $ verbose_runCommandErrors game . getBlind--prop_choosePlayersCommandErrorsWhenCallerNotScapegoat :: GameAtScapegoatsTurn -> Property-prop_choosePlayersCommandErrorsWhenCallerNotScapegoat (GameAtScapegoatsTurn game) =- forAll (suchThat (arbitraryPlayer game) (isn't scapegoat)) $ \caller ->- forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do- let command = choosePlayersCommand (caller ^. name) (targets ^.. names)-- verbose_runCommandErrors game command--prop_choosePlayersCommandSetsAllowedVoters :: GameAtScapegoatsTurn -> Property-prop_choosePlayersCommandSetsAllowedVoters (GameAtScapegoatsTurn game) = do- let scapegoat = game ^?! players . scapegoats-- forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do- let command = choosePlayersCommand (scapegoat ^. name) (targets ^.. names)- let game' = run_ (apply command) game-- game' ^. allowedVoters === targets ^.. names--prop_choosePlayersCommandResetsScapegoatBlamed :: GameAtScapegoatsTurn -> Property-prop_choosePlayersCommandResetsScapegoatBlamed (GameAtScapegoatsTurn game) = do- forAll (arbitraryChoosePlayersCommand game) $ \(Blind command) ->- not $ run_ (apply command) game ^. scapegoatBlamed--prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = do- let witch = game ^?! players . witches- let command = healCommand $ witch ^. name-- verbose_runCommandErrors game command--prop_healCommandErrorsWhenCallerDoesNotExist :: GameWithDevourEvent -> Player -> Property-prop_healCommandErrorsWhenCallerDoesNotExist (GameWithDevourEvent game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> verbose_runCommandErrors game (healCommand (caller ^. name))--prop_healCommandErrorsWhenCallerIsDead :: GameWithDevourEvent -> Property-prop_healCommandErrorsWhenCallerIsDead (GameWithDevourEvent game) =- forAll (arbitraryPlayer game) $ \caller -> do- let game' = killPlayer (caller ^. name) game- let command = healCommand (caller ^. name)-- verbose_runCommandErrors game' command--prop_healCommandErrorsWhenNoTargetIsDevoured :: GameAtWitchsTurn -> Property-prop_healCommandErrorsWhenNoTargetIsDevoured (GameAtWitchsTurn game) = do- let witch = game ^?! players . witches- let command = healCommand $ witch ^. name-- verbose_runCommandErrors game command--prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property-prop_healCommandErrorsWhenNotWitchsTurn game = do- let witch = game ^?! players . witches- let command = healCommand $ witch ^. name-- hasn't (stage . _WitchsTurn) game- ==> verbose_runCommandErrors game command--prop_healCommandErrorsWhenCallerHasHealed :: GameWithHeal -> Property-prop_healCommandErrorsWhenCallerHasHealed (GameWithHeal game) = do- let witch = game ^?! players . witches- let command = healCommand $ witch ^. name-- verbose_runCommandErrors game command--prop_healCommandErrorsWhenCallerNotWitch :: GameWithDevourEvent -> Property-prop_healCommandErrorsWhenCallerNotWitch (GameWithDevourEvent game) =- forAll (suchThat (arbitraryPlayer game) (isn't witch)) $ \caller -> do- let command = healCommand (caller ^. name)-- verbose_runCommandErrors game command--prop_healCommandSetsHeal :: GameWithDevourEvent -> Property-prop_healCommandSetsHeal (GameWithDevourEvent game) =- forAll (arbitraryHealCommand game) $ \(Blind command) ->- (run_ (apply command) game) ^. heal--prop_healCommandSetsHealUsed :: GameWithDevourEvent -> Property-prop_healCommandSetsHealUsed (GameWithDevourEvent game) =- forAll (arbitraryHealCommand game) $ \(Blind command) ->- (run_ (apply command) game) ^. healUsed--prop_passCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_passCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind--prop_passCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property-prop_passCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> verbose_runCommandErrors game (passCommand (caller ^. name))--prop_passCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property-prop_passCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) =- forAll (arbitraryPlayer game) $ \caller -> do- let game' = killPlayer (caller ^. name) game- let command = passCommand (caller ^. name)-- verbose_runCommandErrors game' command--prop_passCommandErrorsWhenNotWitchsTurn :: Game -> Property-prop_passCommandErrorsWhenNotWitchsTurn game =- hasn't (stage . _WitchsTurn) game- ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind--prop_passCommandUpdatesPasses :: GameAtWitchsTurn -> Property-prop_passCommandUpdatesPasses (GameAtWitchsTurn game) =- forAll (arbitraryPassCommand game) $ \(Blind command) -> do- let game' = run_ (apply command) game-- length (game' ^. passes) == 1--prop_poisonCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_poisonCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind--prop_poisonCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property-prop_poisonCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = poisonCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_poisonCommandErrorsWhenTargetDoesNotExist :: GameAtWitchsTurn -> Player -> Property-prop_poisonCommandErrorsWhenTargetDoesNotExist (GameAtWitchsTurn game) target = do- let witch = game ^?! players . witches- let command = poisonCommand (witch ^. name) (target ^. name)-- not (doesPlayerExist (target ^. name) game)- ==> verbose_runCommandErrors game command--prop_poisonCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property-prop_poisonCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do- let witch = game ^?! players . witches-- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (witch ^. name) game- let command = poisonCommand (witch ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_poisonCommandErrorsWhenTargetIsDead :: GameAtWitchsTurn -> Property-prop_poisonCommandErrorsWhenTargetIsDead (GameAtWitchsTurn game) = do- let witch = game ^?! players . witches-- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = poisonCommand (witch ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_poisonCommandErrorsWhenTargetIsDevoured :: GameWithDevourEvent -> Property-prop_poisonCommandErrorsWhenTargetIsDevoured (GameWithDevourEvent game) = do- let witchsName = game ^?! players . witches . name- let targetName = game ^?! events . traverse . _DevourEvent- let command = poisonCommand witchsName targetName-- verbose_runCommandErrors game command--prop_poisonCommandErrorsWhenNotWitchsTurn :: Game -> Property-prop_poisonCommandErrorsWhenNotWitchsTurn game =- hasn't (stage . _WitchsTurn) game- ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind--prop_poisonCommandErrorsWhenCallerHasPoisoned :: GameWithPoison -> Property-prop_poisonCommandErrorsWhenCallerHasPoisoned (GameWithPoison game) = do- let witch = game ^?! players . witches-- forAll (arbitraryPlayer game) $ \target -> do- let command = poisonCommand (witch ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_poisonCommandErrorsWhenCallerNotWitch :: GameAtWitchsTurn -> Property-prop_poisonCommandErrorsWhenCallerNotWitch (GameAtWitchsTurn game) =- forAll (suchThat (arbitraryPlayer game) (isn't witch)) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = poisonCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_poisonCommandSetsPoison :: GameAtWitchsTurn -> Property-prop_poisonCommandSetsPoison (GameAtWitchsTurn game) =- forAll (arbitraryPoisonCommand game) $ \(Blind command) ->- isJust (run_ (apply command) game ^. poison)--prop_poisonCommandSetsPoisonUsed :: GameAtWitchsTurn -> Property-prop_poisonCommandSetsPoisonUsed (GameAtWitchsTurn game) =- forAll (arbitraryPoisonCommand game) $ \(Blind command) ->- run_ (apply command) game ^. poisonUsed--prop_protectCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_protectCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind--prop_protectCommandErrorsWhenCallerDoesNotExist :: GameAtDefendersTurn -> Player -> Property-prop_protectCommandErrorsWhenCallerDoesNotExist (GameAtDefendersTurn game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = protectCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_protectCommandErrorsWhenTargetDoesNotExist :: GameAtDefendersTurn -> Player -> Property-prop_protectCommandErrorsWhenTargetDoesNotExist (GameAtDefendersTurn game) target = do- let defender = game ^?! players . defenders- let command = protectCommand (defender ^. name) (target ^. name)-- not (doesPlayerExist (target ^. name) game)- ==> verbose_runCommandErrors game command--prop_protectCommandErrorsWhenCallerIsDead :: GameAtDefendersTurn -> Property-prop_protectCommandErrorsWhenCallerIsDead (GameAtDefendersTurn game) = do- let defender = game ^?! players . defenders- let game' = killPlayer (defender ^. name) game-- forAll (arbitraryPlayer game') $ \target -> do- let command = protectCommand (defender ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_protectCommandErrorsWhenTargetIsDead :: GameAtDefendersTurn -> Property-prop_protectCommandErrorsWhenTargetIsDead (GameAtDefendersTurn game) = do- let defender = game ^?! players . defenders-- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = protectCommand (defender ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_protectCommandErrorsWhenNotDefendersTurn :: Game -> Property-prop_protectCommandErrorsWhenNotDefendersTurn game =- hasn't (stage . _DefendersTurn) game- ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind--prop_protectCommandErrorsWhenCallerNotDefender :: GameAtDefendersTurn -> Property-prop_protectCommandErrorsWhenCallerNotDefender (GameAtDefendersTurn game) =- forAll (suchThat (arbitraryPlayer game) (isn't defender)) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = protectCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_protectCommandErrorsWhenTargetIsPriorProtect :: GameWithProtect -> Property-prop_protectCommandErrorsWhenTargetIsPriorProtect (GameWithProtect game) = do- let game' = game & protect .~ Nothing-- let defender = game ^?! players . defenders- let command = protectCommand (defender ^. name) (fromJust $ game' ^. priorProtect)-- verbose_runCommandErrors game' command--prop_protectCommandSetsPriorProtect :: GameAtDefendersTurn -> Property-prop_protectCommandSetsPriorProtect (GameAtDefendersTurn game) =- forAll (arbitraryProtectCommand game) $ \(Blind command) ->- isJust $ run_ (apply command) game ^. priorProtect--prop_protectCommandSetsProtect :: GameAtDefendersTurn -> Property-prop_protectCommandSetsProtect (GameAtDefendersTurn game) =- forAll (arbitraryProtectCommand game) $ \(Blind command) ->- isJust $ run_ (apply command) game ^. protect--prop_quitCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_quitCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game . getBlind--prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_quitCommandErrorsWhenCallerDoesNotExist game caller =- not (doesPlayerExist (caller ^. name) game)- ==> verbose_runCommandErrors game (quitCommand $ caller ^. name)--prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property-prop_quitCommandErrorsWhenCallerIsDead game =- forAll (arbitraryPlayer game) $ \caller -> do- let game' = killPlayer (caller ^. name) game- let command = quitCommand $ caller ^. name-- verbose_runCommandErrors game' command--prop_quitCommandKillsPlayer :: Game -> Property-prop_quitCommandKillsPlayer game =- hasn't (stage . _GameOver) game- ==> forAll (arbitraryQuitCommand game) $ \(Blind command) -> do- let game' = run_ (apply command) game-- length (game' ^.. players . traverse . dead) == 1--prop_quitCommandClearsAllegianceChosenWhenCallerIsWolfHound :: GameWithAllegianceChosen -> Bool-prop_quitCommandClearsAllegianceChosenWhenCallerIsWolfHound (GameWithAllegianceChosen game) = do- let wolfHoundsName = game ^?! players . wolfHounds . name- let command = quitCommand wolfHoundsName-- isNothing $ run_ (apply command) game ^. allegianceChosen--prop_quitCommandClearsHealWhenCallerIsWitch :: GameWithHeal -> Bool-prop_quitCommandClearsHealWhenCallerIsWitch (GameWithHeal game) = do- let witch = game ^?! players . witches- let command = quitCommand (witch ^. name)-- not $ run_ (apply command) game ^. heal--prop_quitCommandClearsHealUsedWhenCallerIsWitch :: GameWithHeal -> Bool-prop_quitCommandClearsHealUsedWhenCallerIsWitch (GameWithHeal game) = do- let witch = game ^?! players . witches- let command = quitCommand (witch ^. name)-- not $ run_ (apply command) game ^. healUsed--prop_quitCommandClearsPoisonWhenCallerIsWitch :: GameWithPoison -> Bool-prop_quitCommandClearsPoisonWhenCallerIsWitch (GameWithPoison game) = do- let witch = game ^?! players . witches- let command = quitCommand (witch ^. name)-- isNothing $ run_ (apply command) game ^. poison--prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: GameWithPoison -> Bool-prop_quitCommandClearsPoisonUsedWhenCallerIsWitch (GameWithPoison game) = do- let witch = game ^?! players . witches- let command = quitCommand (witch ^. name)-- not $ run_ (apply command) game ^. poisonUsed--prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: GameWithProtect -> Bool-prop_quitCommandClearsPriorProtectWhenCallerIsDefender (GameWithProtect game) = do- let defender = game ^?! players . defenders- let command = quitCommand (defender ^. name)-- isNothing $ run_ (apply command) game ^. priorProtect--prop_quitCommandClearsProtectWhenCallerIsDefender :: GameWithProtect -> Bool-prop_quitCommandClearsProtectWhenCallerIsDefender (GameWithProtect game) = do- let defender = game ^?! players . defenders- let command = quitCommand (defender ^. name)-- isNothing $ run_ (apply command) game ^. protect--prop_quitCommandClearsPlayersDevourVote :: GameWithDevourVotes -> Property-prop_quitCommandClearsPlayersDevourVote (GameWithDevourVotes game) =- forAll (arbitraryWerewolf game) $ \caller -> do- let command = quitCommand (caller ^. name)-- isNothing $ run_ (apply command) game ^. votes . at (caller ^. name)--prop_quitCommandClearsPlayersLynchVote :: GameWithLynchVotes -> Property-prop_quitCommandClearsPlayersLynchVote (GameWithLynchVotes game) =- forAll (arbitraryPlayer game) $ \caller -> do- let command = quitCommand (caller ^. name)-- isNothing $ run_ (apply command) game ^. votes . at (caller ^. name)--prop_quitCommandClearsRoleModelWhenCallerIsWildChild :: GameWithRoleModel -> Bool-prop_quitCommandClearsRoleModelWhenCallerIsWildChild (GameWithRoleModel game) = do- let wildChild = game ^?! players . wildChildren- let command = quitCommand (wildChild ^. name)-- isNothing $ run_ (apply command) game ^. roleModel--prop_quitCommandSetsAngelsAllegianceWhenCallerIsAngel :: Game -> Bool-prop_quitCommandSetsAngelsAllegianceWhenCallerIsAngel game = do- let angelsName = game ^?! players . angels . name- let command = quitCommand angelsName- let game' = run_ (apply command) game-- is villager $ game' ^?! players . angels--prop_seeCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_seeCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind--prop_seeCommandErrorsWhenCallerDoesNotExist :: GameAtSeersTurn -> Player -> Property-prop_seeCommandErrorsWhenCallerDoesNotExist (GameAtSeersTurn game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = seeCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_seeCommandErrorsWhenTargetDoesNotExist :: GameAtSeersTurn -> Player -> Property-prop_seeCommandErrorsWhenTargetDoesNotExist (GameAtSeersTurn game) target = do- let seer = game ^?! players . seers- let command = seeCommand (seer ^. name) (target ^. name)-- not (doesPlayerExist (target ^. name) game)- ==> verbose_runCommandErrors game command--prop_seeCommandErrorsWhenCallerIsDead :: GameAtSeersTurn -> Property-prop_seeCommandErrorsWhenCallerIsDead (GameAtSeersTurn game) = do- let seer = game ^?! players . seers- let game' = killPlayer (seer ^. name) game-- forAll (arbitraryPlayer game') $ \target -> do- let command = seeCommand (seer ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_seeCommandErrorsWhenTargetIsDead :: GameAtSeersTurn -> Property-prop_seeCommandErrorsWhenTargetIsDead (GameAtSeersTurn game) = do- let seer = game ^?! players . seers-- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = seeCommand (seer ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property-prop_seeCommandErrorsWhenNotSeersTurn game =- hasn't (stage . _SeersTurn) game- ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind--prop_seeCommandErrorsWhenCallerNotSeer :: GameAtSeersTurn -> Property-prop_seeCommandErrorsWhenCallerNotSeer (GameAtSeersTurn game) =- forAll (suchThat (arbitraryPlayer game) (isn't seer)) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = seeCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_seeCommandSetsSee :: GameAtSeersTurn -> Property-prop_seeCommandSetsSee (GameAtSeersTurn game) =- forAll (arbitrarySeeCommand game) $ \(Blind command) ->- isJust $ run_ (apply command) game ^. see--prop_voteDevourCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_voteDevourCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryVoteDevourCommand game) $ verbose_runCommandErrors game . getBlind--prop_voteDevourCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property-prop_voteDevourCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = voteDevourCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteDevourCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property-prop_voteDevourCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target =- not (doesPlayerExist (target ^. name) game)- ==> forAll (arbitraryWerewolf game) $ \caller -> do- let command = voteDevourCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteDevourCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property-prop_voteDevourCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) =- forAll (arbitraryWerewolf game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (caller ^. name) game- let command = voteDevourCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_voteDevourCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property-prop_voteDevourCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) =- forAll (arbitraryWerewolf game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = voteDevourCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_voteDevourCommandErrorsWhenNotWerewolvesTurn :: Game -> Property-prop_voteDevourCommandErrorsWhenNotWerewolvesTurn game =- hasn't (stage . _WerewolvesTurn) game- ==> forAll (arbitraryVoteDevourCommand game) $ verbose_runCommandErrors game . getBlind--prop_voteDevourCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property-prop_voteDevourCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) =- forAll (suchThat (arbitraryPlayer game) (isn't werewolf)) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = voteDevourCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteDevourCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property-prop_voteDevourCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) =- forAll (arbitraryWerewolf game) $ \caller ->- forAll (suchThat (arbitraryPlayer game) (isn't werewolf)) $ \target -> do- let command = voteDevourCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteDevourCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property-prop_voteDevourCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryWerewolf game) $ \target ->- verbose_runCommandErrors game (voteDevourCommand (caller ^. name) (target ^. name))--prop_voteDevourCommandUpdatesVotes :: GameAtWerewolvesTurn -> Property-prop_voteDevourCommandUpdatesVotes (GameAtWerewolvesTurn game) =- forAll (arbitraryVoteDevourCommand game) $ \(Blind command) -> do- let game' = run_ (apply command) game-- Map.size (game' ^. votes) == 1--prop_voteLynchCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_voteLynchCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryVoteLynchCommand game) $ verbose_runCommandErrors game . getBlind--prop_voteLynchCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property-prop_voteLynchCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller =- not (doesPlayerExist (caller ^. name) game)- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteLynchCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property-prop_voteLynchCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target =- not (doesPlayerExist (target ^. name) game)- ==> forAll (arbitraryPlayer game) $ \caller -> do- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteLynchCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property-prop_voteLynchCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (caller ^. name) game- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_voteLynchCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property-prop_voteLynchCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer (target ^. name) game- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_voteLynchCommandErrorsWhenNotVillagesTurn :: Game -> Property-prop_voteLynchCommandErrorsWhenNotVillagesTurn game =- hasn't (stage . _VillagesTurn) game- ==> forAll (arbitraryVoteLynchCommand game) $ verbose_runCommandErrors game . getBlind--prop_voteLynchCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property-prop_voteLynchCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters :: GameWithAllowedVoters -> Property-prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters (GameWithAllowedVoters game) =- forAll (suchThat (arbitraryPlayer game') (`notElem` getAllowedVoters game')) $ \caller ->- forAll (arbitraryPlayer game') $ \target -> do- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command- where- game' = run_ checkStage game--prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot :: GameWithVillageIdiotRevealedAtVillagesTurn -> Property-prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot (GameWithVillageIdiotRevealedAtVillagesTurn game) =- forAll (arbitraryPlayer game) $ \target -> do- let command = voteLynchCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command- where- caller = game ^?! players . villageIdiots--prop_voteLynchCommandUpdatesVotes :: GameAtVillagesTurn -> Property-prop_voteLynchCommandUpdatesVotes (GameAtVillagesTurn game) =- forAll (arbitraryVoteLynchCommand game) $ \(Blind command) -> do- let game' = run_ (apply command) game-- Map.size (game' ^. votes) == 1--verbose_runCommandErrors :: Game -> Command -> Property-verbose_runCommandErrors game command = whenFail (mapM_ putStrLn data_) (isLeft result)- where- result = run (apply command) game- data_ = [show game, show $ fromRight result]
+ test/src/Game/Werewolf/Test/Command/Choose.hs view
@@ -0,0 +1,237 @@+{-|+Module : Game.Werewolf.Test.Command.Choose+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Choose (+ -- * Tests+ allChooseCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Role hiding (name)+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allChooseCommandTests :: [TestTree]+allChooseCommandTests =+ [ testProperty "choose allegiance command errors when game is over" prop_chooseAllegianceCommandErrorsWhenGameIsOver+ , testProperty "choose allegiance command errors when caller does not exist" prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist+ , testProperty "choose allegiance command errors when caller is dead" prop_chooseAllegianceCommandErrorsWhenCallerIsDead+ , testProperty "choose allegiance command errors when not wolf-hound's turn" prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn+ , testProperty "choose allegiance command errors when caller not wolf-hound" prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound+ , testProperty "choose allegiance command errors when allegiance does not exist" prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist+ , testProperty "choose allegiance command sets allegiance chosen" prop_chooseAllegianceCommandSetsAllegianceChosen++ , testProperty "choose player command errors when game is over" prop_choosePlayerCommandErrorsWhenGameIsOver+ , testProperty "choose player command errors when caller does not exist" prop_choosePlayerCommandErrorsWhenCallerDoesNotExist+ , testProperty "choose player command errors when target does not exist" prop_choosePlayerCommandErrorsWhenTargetDoesNotExist+ , testProperty "choose player command errors when caller is dead" prop_choosePlayerCommandErrorsWhenCallerIsDead+ , testProperty "choose player command errors when target is dead" prop_choosePlayerCommandErrorsWhenTargetIsDead+ , testProperty "choose player command errors when target is caller" prop_choosePlayerCommandErrorsWhenTargetIsCaller+ , testProperty "choose player command errors when not wild-child's turn" prop_choosePlayerCommandErrorsWhenNotWildChildsTurn+ , testProperty "choose player command errors when caller not wild-child" prop_choosePlayerCommandErrorsWhenCallerNotWildChild+ , testProperty "choose player command sets role model" prop_choosePlayerCommandSetsRoleModel++ , testProperty "choose players command errors when game is over" prop_choosePlayersCommandErrorsWhenGameIsOver+ , testProperty "choose players command errors when caller does not exist" prop_choosePlayersCommandErrorsWhenCallerDoesNotExist+ , testProperty "choose players command errors when any target does not exist" prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist+ , testProperty "choose players command errors when any target is dead" prop_choosePlayersCommandErrorsWhenAnyTargetIsDead+ , testProperty "choose players command errors when not scapegoat's turn" prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn+ , testProperty "choose players command errors when caller not scapegoat" prop_choosePlayersCommandErrorsWhenCallerNotScapegoat+ , testProperty "choose players command sets allowed voters" prop_choosePlayersCommandSetsAllowedVoters+ , testProperty "choose players command resets scapegoat blamed" prop_choosePlayersCommandResetsScapegoatBlamed+ ]++prop_chooseAllegianceCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_chooseAllegianceCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryChooseAllegianceCommand game) $ verbose_runCommandErrors game . getBlind++prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist :: GameAtWolfHoundsTurn -> Player -> Allegiance -> Property+prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist (GameAtWolfHoundsTurn game) caller allegiance = do+ let command = chooseAllegianceCommand (caller ^. name) (T.pack $ show allegiance)++ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game command++prop_chooseAllegianceCommandErrorsWhenCallerIsDead :: GameAtWolfHoundsTurn -> Allegiance -> Property+prop_chooseAllegianceCommandErrorsWhenCallerIsDead (GameAtWolfHoundsTurn game) allegiance = do+ let wolfHound = game ^?! players . wolfHounds+ let game' = killPlayer (wolfHound ^. name) game+ let command = chooseAllegianceCommand (wolfHound ^. name) (T.pack $ show allegiance)++ verbose_runCommandErrors game' command++prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn :: Game -> Property+prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn game =+ hasn't (stage . _WolfHoundsTurn) game+ ==> forAll (arbitraryChooseAllegianceCommand game) $ verbose_runCommandErrors game . getBlind++prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound :: GameAtWolfHoundsTurn -> Allegiance -> Property+prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound (GameAtWolfHoundsTurn game) allegiance =+ forAll (suchThat (arbitraryPlayer game) (isn't wolfHound)) $ \caller -> do+ let command = chooseAllegianceCommand (caller ^. name) (T.pack $ show allegiance)++ verbose_runCommandErrors game command++prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist :: GameAtWolfHoundsTurn -> Text -> Property+prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist (GameAtWolfHoundsTurn game) allegiance = do+ let wolfHound = game ^?! players . wolfHounds+ let command = chooseAllegianceCommand (wolfHound ^. name) allegiance++ allegiance `notElem` ["Villagers", "Werewolves"]+ ==> verbose_runCommandErrors game command++prop_chooseAllegianceCommandSetsAllegianceChosen :: GameAtWolfHoundsTurn -> Property+prop_chooseAllegianceCommandSetsAllegianceChosen (GameAtWolfHoundsTurn game) = do+ let wolfHoundsName = game ^?! players . wolfHounds . name++ forAll (elements [Villagers, Werewolves]) $ \allegiance' -> do+ let command = chooseAllegianceCommand wolfHoundsName (T.pack $ show allegiance')+ let game' = run_ (apply command) game++ fromJust (game' ^. allegianceChosen) === allegiance'++prop_choosePlayerCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_choosePlayerCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryChoosePlayerCommand game) $ verbose_runCommandErrors game . getBlind++prop_choosePlayerCommandErrorsWhenCallerDoesNotExist :: GameAtWildChildsTurn -> Player -> Property+prop_choosePlayerCommandErrorsWhenCallerDoesNotExist (GameAtWildChildsTurn game) caller =+ forAll (arbitraryPlayer game) $ \target -> do+ let command = choosePlayerCommand (caller ^. name) (target ^. name)++ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game command++prop_choosePlayerCommandErrorsWhenTargetDoesNotExist :: GameAtWildChildsTurn -> Player -> Property+prop_choosePlayerCommandErrorsWhenTargetDoesNotExist (GameAtWildChildsTurn game) target = do+ let wildChild = game ^?! players . wildChildren+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)++ not (doesPlayerExist (target ^. name) game)+ ==> verbose_runCommandErrors game command++prop_choosePlayerCommandErrorsWhenCallerIsDead :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenCallerIsDead (GameAtWildChildsTurn game) = do+ let wildChild = game ^?! players . wildChildren+ let game' = killPlayer (wildChild ^. name) game++ forAll (arbitraryPlayer game') $ \target -> do+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_choosePlayerCommandErrorsWhenTargetIsDead :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenTargetIsDead (GameAtWildChildsTurn game) = do+ let wildChild = game ^?! players . wildChildren++ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_choosePlayerCommandErrorsWhenTargetIsCaller :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenTargetIsCaller (GameAtWildChildsTurn game) = do+ let wildChild = game ^?! players . wildChildren+ let command = choosePlayerCommand (wildChild ^. name) (wildChild ^. name)++ verbose_runCommandErrors game command++prop_choosePlayerCommandErrorsWhenNotWildChildsTurn :: Game -> Property+prop_choosePlayerCommandErrorsWhenNotWildChildsTurn game =+ hasn't (stage . _WildChildsTurn) game+ ==> forAll (arbitraryChoosePlayerCommand game) $ verbose_runCommandErrors game . getBlind++prop_choosePlayerCommandErrorsWhenCallerNotWildChild :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenCallerNotWildChild (GameAtWildChildsTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't wildChild)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = choosePlayerCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_choosePlayerCommandSetsRoleModel :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandSetsRoleModel (GameAtWildChildsTurn game) = do+ let wildChild = game ^?! players . wildChildren++ forAll (suchThat (arbitraryPlayer game) (wildChild /=)) $ \target -> do+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)+ let game' = run_ (apply command) game++ fromJust (game' ^. roleModel) === target ^. name++prop_choosePlayersCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_choosePlayersCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryChoosePlayersCommand game) $ verbose_runCommandErrors game . getBlind++prop_choosePlayersCommandErrorsWhenCallerDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property+prop_choosePlayersCommandErrorsWhenCallerDoesNotExist (GameAtScapegoatsTurn game) caller =+ forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do+ let command = choosePlayersCommand (caller ^. name) (targets ^.. names)++ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game command++prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property+prop_choosePlayersCommandErrorsWhenAnyTargetDoesNotExist (GameAtScapegoatsTurn game) target = do+ let scapegoat = game ^?! players . scapegoats+ let command = choosePlayersCommand (scapegoat ^. name) [target ^. name]++ not (doesPlayerExist (target ^. name) game)+ ==> verbose_runCommandErrors game command++prop_choosePlayersCommandErrorsWhenAnyTargetIsDead :: GameAtScapegoatsTurn -> Property+prop_choosePlayersCommandErrorsWhenAnyTargetIsDead (GameAtScapegoatsTurn game) = do+ let scapegoat = game ^?! players . scapegoats++ forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) ->+ forAll (elements targets) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = choosePlayersCommand (scapegoat ^. name) (targets ^.. names)++ verbose_runCommandErrors game' command++prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn :: Game -> Property+prop_choosePlayersCommandErrorsWhenNotScapegoatsTurn game =+ hasn't (stage . _ScapegoatsTurn) game+ ==> forAll (arbitraryChoosePlayersCommand game) $ verbose_runCommandErrors game . getBlind++prop_choosePlayersCommandErrorsWhenCallerNotScapegoat :: GameAtScapegoatsTurn -> Property+prop_choosePlayersCommandErrorsWhenCallerNotScapegoat (GameAtScapegoatsTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't scapegoat)) $ \caller ->+ forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do+ let command = choosePlayersCommand (caller ^. name) (targets ^.. names)++ verbose_runCommandErrors game command++prop_choosePlayersCommandSetsAllowedVoters :: GameAtScapegoatsTurn -> Property+prop_choosePlayersCommandSetsAllowedVoters (GameAtScapegoatsTurn game) = do+ let scapegoat = game ^?! players . scapegoats++ forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do+ let command = choosePlayersCommand (scapegoat ^. name) (targets ^.. names)+ let game' = run_ (apply command) game++ game' ^. allowedVoters === targets ^.. names++prop_choosePlayersCommandResetsScapegoatBlamed :: GameAtScapegoatsTurn -> Property+prop_choosePlayersCommandResetsScapegoatBlamed (GameAtScapegoatsTurn game) = do+ forAll (arbitraryChoosePlayersCommand game) $ \(Blind command) ->+ not $ run_ (apply command) game ^. scapegoatBlamed
+ test/src/Game/Werewolf/Test/Command/Heal.hs view
@@ -0,0 +1,96 @@+{-|+Module : Game.Werewolf.Test.Command.Heal+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Heal (+ -- * Tests+ allHealCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allHealCommandTests :: [TestTree]+allHealCommandTests =+ [ 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+ ]++prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = do+ let witch = game ^?! players . witches+ let command = healCommand $ witch ^. name++ verbose_runCommandErrors game command++prop_healCommandErrorsWhenCallerDoesNotExist :: GameWithDevourEvent -> Player -> Property+prop_healCommandErrorsWhenCallerDoesNotExist (GameWithDevourEvent game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game (healCommand (caller ^. name))++prop_healCommandErrorsWhenCallerIsDead :: GameWithDevourEvent -> Property+prop_healCommandErrorsWhenCallerIsDead (GameWithDevourEvent game) =+ forAll (arbitraryPlayer game) $ \caller -> do+ let game' = killPlayer (caller ^. name) game+ let command = healCommand (caller ^. name)++ verbose_runCommandErrors game' command++prop_healCommandErrorsWhenNoTargetIsDevoured :: GameAtWitchsTurn -> Property+prop_healCommandErrorsWhenNoTargetIsDevoured (GameAtWitchsTurn game) = do+ let witch = game ^?! players . witches+ let command = healCommand $ witch ^. name++ verbose_runCommandErrors game command++prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property+prop_healCommandErrorsWhenNotWitchsTurn game = do+ let witch = game ^?! players . witches+ let command = healCommand $ witch ^. name++ hasn't (stage . _WitchsTurn) game+ ==> verbose_runCommandErrors game command++prop_healCommandErrorsWhenCallerHasHealed :: GameWithHeal -> Property+prop_healCommandErrorsWhenCallerHasHealed (GameWithHeal game) = do+ let witch = game ^?! players . witches+ let command = healCommand $ witch ^. name++ verbose_runCommandErrors game command++prop_healCommandErrorsWhenCallerNotWitch :: GameWithDevourEvent -> Property+prop_healCommandErrorsWhenCallerNotWitch (GameWithDevourEvent game) =+ forAll (suchThat (arbitraryPlayer game) (isn't witch)) $ \caller -> do+ let command = healCommand (caller ^. name)++ verbose_runCommandErrors game command++prop_healCommandSetsHeal :: GameWithDevourEvent -> Property+prop_healCommandSetsHeal (GameWithDevourEvent game) =+ forAll (arbitraryHealCommand game) $ \(Blind command) ->+ (run_ (apply command) game) ^. heal++prop_healCommandSetsHealUsed :: GameWithDevourEvent -> Property+prop_healCommandSetsHealUsed (GameWithDevourEvent game) =+ forAll (arbitraryHealCommand game) $ \(Blind command) ->+ (run_ (apply command) game) ^. healUsed
+ test/src/Game/Werewolf/Test/Command/Pass.hs view
@@ -0,0 +1,97 @@+{-|+Module : Game.Werewolf.Test.Command.Pass+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Pass (+ -- * Tests+ allPassCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allPassCommandTests :: [TestTree]+allPassCommandTests =+ [ testProperty "pass devoted servant's turn command errors when game is over" prop_passDevotedServantsTurnCommandErrorsWhenGameIsOver+ , testProperty "pass devoted servant's turn command errors when caller does not exist" prop_passDevotedServantsTurnCommandErrorsWhenCallerDoesNotExist+ , testProperty "pass devoted servant's turn command errors when caller is dead" prop_passDevotedServantsTurnCommandErrorsWhenCallerIsDead+ , testProperty "pass devoted servant's turn command errors when not devoted servant's turn" prop_passDevotedServantsTurnCommandErrorsWhenNotDevotedServantsTurn+ , testProperty "pass devoted servant's turn command updates passes" prop_passDevotedServantsTurnCommandUpdatesPasses++ , testProperty "pass witch's turn command errors when game is over" prop_passWitchsTurnCommandErrorsWhenGameIsOver+ , testProperty "pass witch's turn command errors when caller does not exist" prop_passWitchsTurnCommandErrorsWhenCallerDoesNotExist+ , testProperty "pass witch's turn command errors when caller is dead" prop_passWitchsTurnCommandErrorsWhenCallerIsDead+ , testProperty "pass witch's turn command errors when not witch's turn" prop_passWitchsTurnCommandErrorsWhenNotWitchsTurn+ , testProperty "pass witch's turn command updates passes" prop_passWitchsTurnCommandUpdatesPasses+ ]++prop_passDevotedServantsTurnCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_passDevotedServantsTurnCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryPassDevotedServantsTurnCommand game) $ verbose_runCommandErrors game . getBlind++prop_passDevotedServantsTurnCommandErrorsWhenCallerDoesNotExist :: GameAtDevotedServantsTurn -> Player -> Property+prop_passDevotedServantsTurnCommandErrorsWhenCallerDoesNotExist (GameAtDevotedServantsTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game (passDevotedServantsTurnCommand (caller ^. name))++prop_passDevotedServantsTurnCommandErrorsWhenCallerIsDead :: GameAtDevotedServantsTurn -> Property+prop_passDevotedServantsTurnCommandErrorsWhenCallerIsDead (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let game' = killPlayer devotedServantsName game+ let command = passDevotedServantsTurnCommand devotedServantsName++ verbose_runCommandErrors game' command++prop_passDevotedServantsTurnCommandErrorsWhenNotDevotedServantsTurn :: Game -> Property+prop_passDevotedServantsTurnCommandErrorsWhenNotDevotedServantsTurn game =+ hasn't (stage . _DevotedServantsTurn) game+ ==> forAll (arbitraryPassDevotedServantsTurnCommand game) $ verbose_runCommandErrors game . getBlind++prop_passDevotedServantsTurnCommandUpdatesPasses :: GameAtDevotedServantsTurn -> Property+prop_passDevotedServantsTurnCommandUpdatesPasses (GameAtDevotedServantsTurn game) =+ forAll (arbitraryPassDevotedServantsTurnCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ length (game' ^. passes) == 1++prop_passWitchsTurnCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_passWitchsTurnCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryPassWitchsTurnCommand game) $ verbose_runCommandErrors game . getBlind++prop_passWitchsTurnCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property+prop_passWitchsTurnCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game (passWitchsTurnCommand (caller ^. name))++prop_passWitchsTurnCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property+prop_passWitchsTurnCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do+ let witchsName = game ^?! players . witches . name+ let game' = killPlayer witchsName game+ let command = passWitchsTurnCommand witchsName++ verbose_runCommandErrors game' command++prop_passWitchsTurnCommandErrorsWhenNotWitchsTurn :: Game -> Property+prop_passWitchsTurnCommandErrorsWhenNotWitchsTurn game =+ hasn't (stage . _WitchsTurn) game+ ==> forAll (arbitraryPassWitchsTurnCommand game) $ verbose_runCommandErrors game . getBlind++prop_passWitchsTurnCommandUpdatesPasses :: GameAtWitchsTurn -> Property+prop_passWitchsTurnCommandUpdatesPasses (GameAtWitchsTurn game) =+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ length (game' ^. passes) == 1
+ test/src/Game/Werewolf/Test/Command/Poison.hs view
@@ -0,0 +1,121 @@+{-|+Module : Game.Werewolf.Test.Command.Poison+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Poison (+ -- * Tests+ allPoisonCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Data.Maybe++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allPoisonCommandTests :: [TestTree]+allPoisonCommandTests =+ [ 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+ ]++prop_poisonCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_poisonCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind++prop_poisonCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property+prop_poisonCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = poisonCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_poisonCommandErrorsWhenTargetDoesNotExist :: GameAtWitchsTurn -> Player -> Property+prop_poisonCommandErrorsWhenTargetDoesNotExist (GameAtWitchsTurn game) target = do+ let witch = game ^?! players . witches+ let command = poisonCommand (witch ^. name) (target ^. name)++ not (doesPlayerExist (target ^. name) game)+ ==> verbose_runCommandErrors game command++prop_poisonCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property+prop_poisonCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do+ let witch = game ^?! players . witches++ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (witch ^. name) game+ let command = poisonCommand (witch ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_poisonCommandErrorsWhenTargetIsDead :: GameAtWitchsTurn -> Property+prop_poisonCommandErrorsWhenTargetIsDead (GameAtWitchsTurn game) = do+ let witch = game ^?! players . witches++ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = poisonCommand (witch ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_poisonCommandErrorsWhenTargetIsDevoured :: GameWithDevourEvent -> Property+prop_poisonCommandErrorsWhenTargetIsDevoured (GameWithDevourEvent game) = do+ let witchsName = game ^?! players . witches . name+ let targetName = game ^?! events . traverse . _DevourEvent+ let command = poisonCommand witchsName targetName++ verbose_runCommandErrors game command++prop_poisonCommandErrorsWhenNotWitchsTurn :: Game -> Property+prop_poisonCommandErrorsWhenNotWitchsTurn game =+ hasn't (stage . _WitchsTurn) game+ ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind++prop_poisonCommandErrorsWhenCallerHasPoisoned :: GameWithPoison -> Property+prop_poisonCommandErrorsWhenCallerHasPoisoned (GameWithPoison game) = do+ let witch = game ^?! players . witches++ forAll (arbitraryPlayer game) $ \target -> do+ let command = poisonCommand (witch ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_poisonCommandErrorsWhenCallerNotWitch :: GameAtWitchsTurn -> Property+prop_poisonCommandErrorsWhenCallerNotWitch (GameAtWitchsTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't witch)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = poisonCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_poisonCommandSetsPoison :: GameAtWitchsTurn -> Property+prop_poisonCommandSetsPoison (GameAtWitchsTurn game) =+ forAll (arbitraryPoisonCommand game) $ \(Blind command) ->+ isJust (run_ (apply command) game ^. poison)++prop_poisonCommandSetsPoisonUsed :: GameAtWitchsTurn -> Property+prop_poisonCommandSetsPoisonUsed (GameAtWitchsTurn game) =+ forAll (arbitraryPoisonCommand game) $ \(Blind command) ->+ run_ (apply command) game ^. poisonUsed
+ test/src/Game/Werewolf/Test/Command/Protect.hs view
@@ -0,0 +1,112 @@+{-|+Module : Game.Werewolf.Test.Command.Protect+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Protect (+ -- * Tests+ allProtectCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Data.Maybe++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allProtectCommandTests :: [TestTree]+allProtectCommandTests =+ [ 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 prior protect" prop_protectCommandErrorsWhenTargetIsPriorProtect+ , testProperty "protect command sets prior protect" prop_protectCommandSetsPriorProtect+ , testProperty "protect command sets protect" prop_protectCommandSetsProtect+ ]++prop_protectCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_protectCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind++prop_protectCommandErrorsWhenCallerDoesNotExist :: GameAtDefendersTurn -> Player -> Property+prop_protectCommandErrorsWhenCallerDoesNotExist (GameAtDefendersTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = protectCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_protectCommandErrorsWhenTargetDoesNotExist :: GameAtDefendersTurn -> Player -> Property+prop_protectCommandErrorsWhenTargetDoesNotExist (GameAtDefendersTurn game) target = do+ let defender = game ^?! players . defenders+ let command = protectCommand (defender ^. name) (target ^. name)++ not (doesPlayerExist (target ^. name) game)+ ==> verbose_runCommandErrors game command++prop_protectCommandErrorsWhenCallerIsDead :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenCallerIsDead (GameAtDefendersTurn game) = do+ let defender = game ^?! players . defenders+ let game' = killPlayer (defender ^. name) game++ forAll (arbitraryPlayer game') $ \target -> do+ let command = protectCommand (defender ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_protectCommandErrorsWhenTargetIsDead :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenTargetIsDead (GameAtDefendersTurn game) = do+ let defender = game ^?! players . defenders++ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = protectCommand (defender ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_protectCommandErrorsWhenNotDefendersTurn :: Game -> Property+prop_protectCommandErrorsWhenNotDefendersTurn game =+ hasn't (stage . _DefendersTurn) game+ ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind++prop_protectCommandErrorsWhenCallerNotDefender :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenCallerNotDefender (GameAtDefendersTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't defender)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = protectCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_protectCommandErrorsWhenTargetIsPriorProtect :: GameWithProtect -> Property+prop_protectCommandErrorsWhenTargetIsPriorProtect (GameWithProtect game) = do+ let game' = game & protect .~ Nothing++ let defender = game ^?! players . defenders+ let command = protectCommand (defender ^. name) (fromJust $ game' ^. priorProtect)++ verbose_runCommandErrors game' command++prop_protectCommandSetsPriorProtect :: GameAtDefendersTurn -> Property+prop_protectCommandSetsPriorProtect (GameAtDefendersTurn game) =+ forAll (arbitraryProtectCommand game) $ \(Blind command) ->+ isJust $ run_ (apply command) game ^. priorProtect++prop_protectCommandSetsProtect :: GameAtDefendersTurn -> Property+prop_protectCommandSetsProtect (GameAtDefendersTurn game) =+ forAll (arbitraryProtectCommand game) $ \(Blind command) ->+ isJust $ run_ (apply command) game ^. protect
+ test/src/Game/Werewolf/Test/Command/Quit.hs view
@@ -0,0 +1,148 @@+{-|+Module : Game.Werewolf.Test.Command.Quit+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Quit (+ -- * Tests+ allQuitCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Data.Maybe++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allQuitCommandTests :: [TestTree]+allQuitCommandTests =+ [ 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 allegiance chosen when caller is wolf-hound" prop_quitCommandClearsAllegianceChosenWhenCallerIsWolfHound+ , 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 "quit command clears role model when caller is wild-child" prop_quitCommandClearsRoleModelWhenCallerIsWildChild+ , testProperty "quit command sets angel's allegiance when caller is angel" prop_quitCommandSetsAngelsAllegianceWhenCallerIsAngel+ ]++prop_quitCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_quitCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game . getBlind++prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property+prop_quitCommandErrorsWhenCallerDoesNotExist game caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game (quitCommand $ caller ^. name)++prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property+prop_quitCommandErrorsWhenCallerIsDead game =+ forAll (arbitraryPlayer game) $ \caller -> do+ let game' = killPlayer (caller ^. name) game+ let command = quitCommand $ caller ^. name++ verbose_runCommandErrors game' command++prop_quitCommandKillsPlayer :: Game -> Property+prop_quitCommandKillsPlayer game =+ hasn't (stage . _GameOver) game+ ==> forAll (arbitraryQuitCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ length (game' ^.. players . traverse . dead) == 1++prop_quitCommandClearsAllegianceChosenWhenCallerIsWolfHound :: GameWithAllegianceChosen -> Bool+prop_quitCommandClearsAllegianceChosenWhenCallerIsWolfHound (GameWithAllegianceChosen game) = do+ let wolfHoundsName = game ^?! players . wolfHounds . name+ let command = quitCommand wolfHoundsName++ isNothing $ run_ (apply command) game ^. allegianceChosen++prop_quitCommandClearsHealWhenCallerIsWitch :: GameWithHeal -> Bool+prop_quitCommandClearsHealWhenCallerIsWitch (GameWithHeal game) = do+ let witch = game ^?! players . witches+ let command = quitCommand (witch ^. name)++ not $ run_ (apply command) game ^. heal++prop_quitCommandClearsHealUsedWhenCallerIsWitch :: GameWithHeal -> Bool+prop_quitCommandClearsHealUsedWhenCallerIsWitch (GameWithHeal game) = do+ let witch = game ^?! players . witches+ let command = quitCommand (witch ^. name)++ not $ run_ (apply command) game ^. healUsed++prop_quitCommandClearsPoisonWhenCallerIsWitch :: GameWithPoison -> Bool+prop_quitCommandClearsPoisonWhenCallerIsWitch (GameWithPoison game) = do+ let witch = game ^?! players . witches+ let command = quitCommand (witch ^. name)++ isNothing $ run_ (apply command) game ^. poison++prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: GameWithPoison -> Bool+prop_quitCommandClearsPoisonUsedWhenCallerIsWitch (GameWithPoison game) = do+ let witch = game ^?! players . witches+ let command = quitCommand (witch ^. name)++ not $ run_ (apply command) game ^. poisonUsed++prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: GameWithProtect -> Bool+prop_quitCommandClearsPriorProtectWhenCallerIsDefender (GameWithProtect game) = do+ let defender = game ^?! players . defenders+ let command = quitCommand (defender ^. name)++ isNothing $ run_ (apply command) game ^. priorProtect++prop_quitCommandClearsProtectWhenCallerIsDefender :: GameWithProtect -> Bool+prop_quitCommandClearsProtectWhenCallerIsDefender (GameWithProtect game) = do+ let defender = game ^?! players . defenders+ let command = quitCommand (defender ^. name)++ isNothing $ run_ (apply command) game ^. protect++prop_quitCommandClearsPlayersDevourVote :: GameWithDevourVotes -> Property+prop_quitCommandClearsPlayersDevourVote (GameWithDevourVotes game) =+ forAll (arbitraryWerewolf game) $ \caller -> do+ let command = quitCommand (caller ^. name)++ isNothing $ run_ (apply command) game ^. votes . at (caller ^. name)++prop_quitCommandClearsPlayersLynchVote :: GameWithLynchVotes -> Property+prop_quitCommandClearsPlayersLynchVote (GameWithLynchVotes game) =+ forAll (arbitraryPlayer game) $ \caller -> do+ let command = quitCommand (caller ^. name)++ isNothing $ run_ (apply command) game ^. votes . at (caller ^. name)++prop_quitCommandClearsRoleModelWhenCallerIsWildChild :: GameWithRoleModel -> Bool+prop_quitCommandClearsRoleModelWhenCallerIsWildChild (GameWithRoleModel game) = do+ let wildChild = game ^?! players . wildChildren+ let command = quitCommand (wildChild ^. name)++ isNothing $ run_ (apply command) game ^. roleModel++prop_quitCommandSetsAngelsAllegianceWhenCallerIsAngel :: Game -> Bool+prop_quitCommandSetsAngelsAllegianceWhenCallerIsAngel game = do+ let angelsName = game ^?! players . angels . name+ let command = quitCommand angelsName+ let game' = run_ (apply command) game++ is villager $ game' ^?! players . angels
+ test/src/Game/Werewolf/Test/Command/Reveal.hs view
@@ -0,0 +1,137 @@+{-|+Module : Game.Werewolf.Test.Command.Reveal+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Reveal (+ -- * Tests+ allRevealCommandTests,+) where++import Control.Lens hiding (isn't)++import Data.Maybe++import Game.Werewolf.Game+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Player+import Game.Werewolf.Role hiding (name)+import Game.Werewolf.Command+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allRevealCommandTests :: [TestTree]+allRevealCommandTests =+ [ testProperty "reveal command errors when game is over" prop_revealCommandErrorsWhenGameIsOver+ , testProperty "reveal command errors when caller does not exist" prop_revealCommandErrorsWhenCallerDoesNotExist+ , testProperty "reveal command errors when caller is dead" prop_revealCommandErrorsWhenCallerIsDead+ , testProperty "reveal command errors when not devoted servant's turn" prop_revealCommandErrorsWhenNotDevotedServantsTurn+ , testProperty "reveal command errors when caller not devoted servant" prop_revealCommandErrorsWhenCallerNotDevotedServant+ , testProperty "reveal command sets caller's role" prop_revealCommandSetsCallersRole+ , testProperty "reveal command sets target's role" prop_revealCommandSetsTargetsRole+ , testProperty "reveal command resets role when village idiot" prop_revealCommandResetsRoleWhenVillageIdiot+ , testProperty "reveal command resets role when wild-child" prop_revealCommandResetsRoleWhenWildChild+ , testProperty "reveal command resets role when witch" prop_revealCommandResetsRoleWhenWitch+ , testProperty "reveal command resets role when wolf-hound" prop_revealCommandResetsRoleWhenWolfHound+ ]++prop_revealCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_revealCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryRevealCommand game) $ verbose_runCommandErrors game . getBlind++prop_revealCommandErrorsWhenCallerDoesNotExist :: GameAtDevotedServantsTurn -> Player -> Property+prop_revealCommandErrorsWhenCallerDoesNotExist (GameAtDevotedServantsTurn game) caller = do+ let command = revealCommand $ caller ^. name++ not (doesPlayerExist (caller ^. name) game)+ ==> verbose_runCommandErrors game command++prop_revealCommandErrorsWhenCallerIsDead :: GameAtDevotedServantsTurn -> Property+prop_revealCommandErrorsWhenCallerIsDead (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let game' = killPlayer devotedServantsName game+ let command = revealCommand devotedServantsName++ verbose_runCommandErrors game' command++prop_revealCommandErrorsWhenNotDevotedServantsTurn :: Game -> Property+prop_revealCommandErrorsWhenNotDevotedServantsTurn game =+ hasn't (stage . _DevotedServantsTurn) game+ ==> forAll (arbitraryRevealCommand game) $ verbose_runCommandErrors game . getBlind++prop_revealCommandErrorsWhenCallerNotDevotedServant :: GameAtDevotedServantsTurn -> Property+prop_revealCommandErrorsWhenCallerNotDevotedServant (GameAtDevotedServantsTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't devotedServant)) $ \caller -> do+ let command = revealCommand $ caller ^. name++ verbose_runCommandErrors game command++prop_revealCommandSetsCallersRole :: GameAtDevotedServantsTurn -> Property+prop_revealCommandSetsCallersRole (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = revealCommand devotedServantsName+ let game' = run_ (apply command) game++ game' ^?! players . traverse . filteredBy name devotedServantsName . role === target ^. role+ where+ target = head $ getVoteResult game++prop_revealCommandSetsTargetsRole :: GameAtDevotedServantsTurn -> Bool+prop_revealCommandSetsTargetsRole (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = revealCommand devotedServantsName+ let game' = run_ (apply command) game++ is devotedServant $ game' ^?! players . traverse . filteredBy name targetsName+ where+ targetsName = head (getVoteResult game) ^. name++prop_revealCommandResetsRoleWhenVillageIdiot :: GameAtDevotedServantsTurn -> Bool+prop_revealCommandResetsRoleWhenVillageIdiot (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = revealCommand devotedServantsName+ let game'' = run_ (apply command) game'++ not $ game'' ^. villageIdiotRevealed+ where+ targetsName = head (getVoteResult game) ^. name+ game' = game & players . traverse . filteredBy name targetsName . role .~ villageIdiotRole & villageIdiotRevealed .~ True++prop_revealCommandResetsRoleWhenWildChild :: GameAtDevotedServantsTurn -> Bool+prop_revealCommandResetsRoleWhenWildChild (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = revealCommand devotedServantsName+ let game'' = run_ (apply command) game'++ isNothing $ game'' ^. roleModel+ where+ targetsName = head (getVoteResult game) ^. name+ game' = game & players . traverse . filteredBy name targetsName . role .~ wildChildRole & roleModel .~ Just targetsName++prop_revealCommandResetsRoleWhenWitch :: GameAtDevotedServantsTurn -> Bool+prop_revealCommandResetsRoleWhenWitch (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = revealCommand devotedServantsName+ let game'' = run_ (apply command) game'++ not (game'' ^. healUsed) && not (game'' ^. poisonUsed)+ where+ targetsName = head (getVoteResult game) ^. name+ game' = game & players . traverse . filteredBy name targetsName . role .~ witchRole & healUsed .~ True & poisonUsed .~ True++prop_revealCommandResetsRoleWhenWolfHound :: GameAtDevotedServantsTurn -> Bool+prop_revealCommandResetsRoleWhenWolfHound (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = revealCommand devotedServantsName+ let game'' = run_ (apply command) game'++ isNothing $ game'' ^. allegianceChosen+ where+ targetsName = head (getVoteResult game) ^. name+ game' = game & players . traverse . filteredBy name targetsName . role .~ wolfHoundRole & allegianceChosen .~ Just Villagers
+ test/src/Game/Werewolf/Test/Command/See.hs view
@@ -0,0 +1,96 @@+{-|+Module : Game.Werewolf.Test.Command.See+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.See (+ -- * Tests+ allSeeCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import Data.Maybe++import Game.Werewolf.Command+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allSeeCommandTests :: [TestTree]+allSeeCommandTests =+ [ 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+ ]++prop_seeCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_seeCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind++prop_seeCommandErrorsWhenCallerDoesNotExist :: GameAtSeersTurn -> Player -> Property+prop_seeCommandErrorsWhenCallerDoesNotExist (GameAtSeersTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = seeCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_seeCommandErrorsWhenTargetDoesNotExist :: GameAtSeersTurn -> Player -> Property+prop_seeCommandErrorsWhenTargetDoesNotExist (GameAtSeersTurn game) target = do+ let seer = game ^?! players . seers+ let command = seeCommand (seer ^. name) (target ^. name)++ not (doesPlayerExist (target ^. name) game)+ ==> verbose_runCommandErrors game command++prop_seeCommandErrorsWhenCallerIsDead :: GameAtSeersTurn -> Property+prop_seeCommandErrorsWhenCallerIsDead (GameAtSeersTurn game) = do+ let seer = game ^?! players . seers+ let game' = killPlayer (seer ^. name) game++ forAll (arbitraryPlayer game') $ \target -> do+ let command = seeCommand (seer ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_seeCommandErrorsWhenTargetIsDead :: GameAtSeersTurn -> Property+prop_seeCommandErrorsWhenTargetIsDead (GameAtSeersTurn game) = do+ let seer = game ^?! players . seers++ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = seeCommand (seer ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property+prop_seeCommandErrorsWhenNotSeersTurn game =+ hasn't (stage . _SeersTurn) game+ ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind++prop_seeCommandErrorsWhenCallerNotSeer :: GameAtSeersTurn -> Property+prop_seeCommandErrorsWhenCallerNotSeer (GameAtSeersTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't seer)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = seeCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_seeCommandSetsSee :: GameAtSeersTurn -> Property+prop_seeCommandSetsSee (GameAtSeersTurn game) =+ forAll (arbitrarySeeCommand game) $ \(Blind command) ->+ isJust $ run_ (apply command) game ^. see
+ test/src/Game/Werewolf/Test/Command/Vote.hs view
@@ -0,0 +1,201 @@+{-|+Module : Game.Werewolf.Test.Command.Vote+Copyright : (c) Henry J. Wylde, 2016+License : BSD3+Maintainer : public@hjwylde.com+-}++{-# LANGUAGE OverloadedStrings #-}++module Game.Werewolf.Test.Command.Vote (+ -- * Tests+ allVoteCommandTests,+) where++import Control.Lens hiding (elements, isn't)++import qualified Data.Map as Map++import Game.Werewolf.Command+import Game.Werewolf.Engine (checkStage)+import Game.Werewolf.Game+import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary+import Game.Werewolf.Test.Util++import Test.Tasty+import Test.Tasty.QuickCheck++allVoteCommandTests :: [TestTree]+allVoteCommandTests =+ [ testProperty "vote devour command errors when game is over" prop_voteDevourCommandErrorsWhenGameIsOver+ , testProperty "vote devour command errors when caller does not exist" prop_voteDevourCommandErrorsWhenCallerDoesNotExist+ , testProperty "vote devour command errors when target does not exist" prop_voteDevourCommandErrorsWhenTargetDoesNotExist+ , testProperty "vote devour command errors when caller is dead" prop_voteDevourCommandErrorsWhenCallerIsDead+ , testProperty "vote devour command errors when target is dead" prop_voteDevourCommandErrorsWhenTargetIsDead+ , testProperty "vote devour command errors when not werewolves turn" prop_voteDevourCommandErrorsWhenNotWerewolvesTurn+ , testProperty "vote devour command errors when caller not werewolf" prop_voteDevourCommandErrorsWhenCallerNotWerewolf+ , testProperty "vote devour command errors when caller has voted" prop_voteDevourCommandErrorsWhenCallerHasVoted+ , testProperty "vote devour command errors when target werewolf" prop_voteDevourCommandErrorsWhenTargetWerewolf+ , testProperty "vote devour command updates votes" prop_voteDevourCommandUpdatesVotes++ , testProperty "vote lynch command errors when game is over" prop_voteLynchCommandErrorsWhenGameIsOver+ , testProperty "vote lynch command errors when caller does not exist" prop_voteLynchCommandErrorsWhenCallerDoesNotExist+ , testProperty "vote lynch command errors when target does not exist" prop_voteLynchCommandErrorsWhenTargetDoesNotExist+ , testProperty "vote lynch command errors when caller is dead" prop_voteLynchCommandErrorsWhenCallerIsDead+ , testProperty "vote lynch command errors when target is dead" prop_voteLynchCommandErrorsWhenTargetIsDead+ , testProperty "vote lynch command errors when not villages turn" prop_voteLynchCommandErrorsWhenNotVillagesTurn+ , testProperty "vote lynch command errors when caller has voted" prop_voteLynchCommandErrorsWhenCallerHasVoted+ , testProperty "vote lynch command errors when caller is not in allowed voters" prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters+ , testProperty "vote lynch command errors when caller is known village idiot" prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot+ , testProperty "vote lynch command updates votes" prop_voteLynchCommandUpdatesVotes+ ]++prop_voteDevourCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_voteDevourCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryVoteDevourCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteDevourCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property+prop_voteDevourCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property+prop_voteDevourCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target =+ not (doesPlayerExist (target ^. name) game)+ ==> forAll (arbitraryWerewolf game) $ \caller -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) =+ forAll (arbitraryWerewolf game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (caller ^. name) game+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteDevourCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) =+ forAll (arbitraryWerewolf game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteDevourCommandErrorsWhenNotWerewolvesTurn :: Game -> Property+prop_voteDevourCommandErrorsWhenNotWerewolvesTurn game =+ hasn't (stage . _WerewolvesTurn) game+ ==> forAll (arbitraryVoteDevourCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteDevourCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) =+ forAll (suchThat (arbitraryPlayer game) (isn't werewolf)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property+prop_voteDevourCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) =+ forAll (arbitraryWerewolf game) $ \caller ->+ forAll (suchThat (arbitraryPlayer game) (isn't werewolf)) $ \target -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryWerewolf game) $ \target ->+ verbose_runCommandErrors game (voteDevourCommand (caller ^. name) (target ^. name))++prop_voteDevourCommandUpdatesVotes :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandUpdatesVotes (GameAtWerewolvesTurn game) =+ forAll (arbitraryVoteDevourCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ Map.size (game' ^. votes) == 1++prop_voteLynchCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_voteLynchCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryVoteLynchCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteLynchCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property+prop_voteLynchCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller =+ not (doesPlayerExist (caller ^. name) game)+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteLynchCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property+prop_voteLynchCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target =+ not (doesPlayerExist (target ^. name) game)+ ==> forAll (arbitraryPlayer game) $ \caller -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteLynchCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property+prop_voteLynchCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (caller ^. name) game+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteLynchCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property+prop_voteLynchCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteLynchCommandErrorsWhenNotVillagesTurn :: Game -> Property+prop_voteLynchCommandErrorsWhenNotVillagesTurn game =+ hasn't (stage . _VillagesTurn) game+ ==> forAll (arbitraryVoteLynchCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteLynchCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property+prop_voteLynchCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters :: GameWithAllowedVoters -> Property+prop_voteLynchCommandErrorsWhenCallerIsNotInAllowedVoters (GameWithAllowedVoters game) =+ forAll (suchThat (arbitraryPlayer game') (`notElem` getAllowedVoters game')) $ \caller ->+ forAll (arbitraryPlayer game') $ \target -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command+ where+ game' = run_ checkStage game++prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot :: GameWithVillageIdiotRevealedAtVillagesTurn -> Property+prop_voteLynchCommandErrorsWhenCallerIsKnownVillageIdiot (GameWithVillageIdiotRevealedAtVillagesTurn game) =+ forAll (arbitraryPlayer game) $ \target -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command+ where+ caller = game ^?! players . villageIdiots++prop_voteLynchCommandUpdatesVotes :: GameAtVillagesTurn -> Property+prop_voteLynchCommandUpdatesVotes (GameAtVillagesTurn game) =+ forAll (arbitraryVoteLynchCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ Map.size (game' ^. votes) == 1
test/src/Game/Werewolf/Test/Engine.hs view
@@ -37,19 +37,37 @@ allEngineTests :: [TestTree] allEngineTests =- [ testProperty "check stage skips defender's turn when no defender" prop_checkStageSkipsDefendersTurnWhenNoDefender- , testProperty "check stage skips scapegoat's turn when no seer" prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat- , testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer- , testProperty "check stage skips village's turn when allowed voters empty" prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty- , testProperty "check stage skips wild-child's turn when no wild-child" prop_checkStageSkipsWildChildsTurnWhenNoWildChild- , testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch- , testProperty "check stage skips wolf-hound's turn when no wolf-hound" prop_checkStageSkipsWolfHoundsTurnWhenNoWolfHound- , testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver+ [ testProperty "check stage skips defender's turn when no defender" prop_checkStageSkipsDefendersTurnWhenNoDefender+ , testProperty "check stage skips devoted servant's turn when no devoted servant" prop_checkStageSkipsDevotedServantsTurnWhenNoDevotedServant+ , testProperty "check stage skips scapegoat's turn when no scapegoat" prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat+ , testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer+ , testProperty "check stage skips village's turn when allowed voters empty" prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty+ , testProperty "check stage skips wild-child's turn when no wild-child" prop_checkStageSkipsWildChildsTurnWhenNoWildChild+ , testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch+ , testProperty "check stage skips wolf-hound's turn when no wolf-hound" prop_checkStageSkipsWolfHoundsTurnWhenNoWolfHound , testProperty "check defender's turn advances to werewolves' turn" prop_checkDefendersTurnAdvancesToWerewolvesTurn , testProperty "check defender's turn advances when no defender" prop_checkDefendersTurnAdvancesWhenNoDefender , testProperty "check defender's turn does nothing unless protected" prop_checkDefendersTurnDoesNothingUnlessProtected + , testProperty "check devoted servant's turn advances to wolf-hound's turn" prop_checkDevotedServantsTurnAdvancesToWolfHoundsTurn+ , testProperty "check devoted servant's turn advances when no devoted servant" prop_checkDevotedServantsTurnAdvancesWhenNoDevotedServant+ , testProperty "check devoted servant's turn does nothing unless revealed or passed" prop_checkDevotedServantsTurnDoesNothingUnlessRevealedOrPassed++ , testProperty "check lynching lynches one player when consensus" prop_checkLynchingLynchesOnePlayerWhenConsensus+ , testProperty "check lynching lynches no one when target is village idiot" prop_checkLynchingLynchesNoOneWhenTargetIsVillageIdiot+ , testProperty "check lynching lynches scapegoat when conflicted" prop_checkLynchingLynchesScapegoatWhenConflicted+ , testProperty "check lynching lynches no one when conflicted and no scapegoats" prop_checkLynchingLynchesNoOneWhenConflictedAndNoScapegoats+ , testProperty "check lynching resets votes" prop_checkLynchingResetsVotes+ , testProperty "check lynching sets allowed voters" prop_checkLynchingSetsAllowedVoters++ , testProperty "check game over advances stage when one allegiance alive" prop_checkGameOverAdvancesStageWhenOneAllegianceAlive+ -- TODO (hjw): pending+ --, testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive+ , testProperty "check game over advances stage when after first round and angel dead" prop_checkGameOverAdvancesStageWhenAfterFirstRoundAndAngelDead+ , testProperty "check game over does nothing when angel dead but aligned with villagers" prop_checkGameOverDoesNothingWhenAngelDeadButAlignedWithVillagers+ , testProperty "check game over does nothing when game over" prop_checkGameOverDoesNothingWhenGameOver+ , testProperty "check scapegoat's turn advances to wolf-hound's turn" prop_checkScapegoatsTurnAdvancesToWolfHoundsTurn , testProperty "check scapegoat's turn skips wolf-hound's turn when allegiance chosen" prop_checkScapegoatsTurnSkipsWolfHoundsTurnWhenAllegianceChosen , testProperty "check scapegoat's turn does nothing while scapegoat blamed" prop_checkScapegoatsTurnDoesNothingWhileScapegoatBlamed@@ -64,14 +82,9 @@ , testProperty "check sunset sets wild-child's allegiance when role model dead" prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead - , testProperty "check villages' turn advances to scapegoat's turn" prop_checkVillagesTurnAdvancesToScapegoatsTurn- , testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus- , testProperty "check villages' turn lynches no one when target is village idiot" prop_checkVillagesTurnLynchesNoOneWhenTargetIsVillageIdiot- , testProperty "check villages' turn lynches no one when conflicted and no scapegoats" prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats- , testProperty "check villages' turn lynches scapegoat when conflicted" prop_checkVillagesTurnLynchesScapegoatWhenConflicted- , testProperty "check villages' turn resets votes" prop_checkVillagesTurnResetsVotes- , testProperty "check villages' turn sets allowed voters" prop_checkVillagesTurnSetsAllowedVoters- , testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted+ , testProperty "check villages' turn advances to devoted servant's turn" prop_checkVillagesTurnAdvancesToDevotedServantsTurn+ , testProperty "check villages' turn skips devoted servant's turn when conflicted" prop_checkVillagesTurnSkipsDevotedServantsTurnWhenConflicted+ , testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted , testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn , testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned@@ -101,12 +114,6 @@ , testProperty "check wolf-hound's turn sets wolf-hound's allegiance" prop_checkWolfHoundsTurnSetsWolfHoundsAllegiance , testProperty "check wolf-hound's turn does nothing unless allegiance chosen" prop_checkWolfHoundsTurnDoesNothingUnlessAllegianceChosen - , testProperty "check game over advances stage when one allegiance alive" prop_checkGameOverAdvancesStageWhenOneAllegianceAlive- -- TODO (hjw): pending- --, testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive- , testProperty "check game over advances stage when after first round and angel dead" prop_checkGameOverAdvancesStageWhenAfterFirstRoundAndAngelDead- , testProperty "check game over does nothing when angel dead but aligned with villagers" prop_checkGameOverDoesNothingWhenAngelDeadButAlignedWithVillagers- , 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@@ -121,15 +128,22 @@ defendersName = game ^?! players . defenders . name game' = run_ (apply (quitCommand defendersName) >> checkStage) game -prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat :: GameWithLynchVotes -> Bool-prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat (GameWithLynchVotes game) =+prop_checkStageSkipsDevotedServantsTurnWhenNoDevotedServant :: GameWithMajorityVote -> Bool+prop_checkStageSkipsDevotedServantsTurnWhenNoDevotedServant (GameWithMajorityVote game) =+ hasn't (stage . _DevotedServantsTurn) game'+ where+ devotedServantsName = game ^?! players . devotedServants . name+ game' = run_ (apply (quitCommand devotedServantsName) >> checkStage) game++prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat :: GameWithConflictingVote -> Bool+prop_checkStageSkipsScapegoatsTurnWhenNoScapegoat (GameWithConflictingVote game) = hasn't (stage . _ScapegoatsTurn) game' where scapegoatsName = game ^?! players . scapegoats . name game' = run_ (apply (quitCommand scapegoatsName) >> checkStage) game -prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithLynchVotes -> Bool-prop_checkStageSkipsSeersTurnWhenNoSeer (GameWithLynchVotes game) =+prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithPassAtDevotedServantsTurn -> Bool+prop_checkStageSkipsSeersTurnWhenNoSeer (GameWithPassAtDevotedServantsTurn game) = hasn't (stage . _SeersTurn) game' where seersName = game ^?! players . seers . name@@ -137,8 +151,8 @@ prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty :: GameAtWitchsTurn -> Property prop_checkStageSkipsVillagesTurnWhenAllowedVotersEmpty (GameAtWitchsTurn game) =- forAll (arbitraryPassCommand game') $ \(Blind passCommand) -> do- hasn't (stage . _VillagesTurn) (run_ (apply passCommand >> checkStage) game')+ forAll (arbitraryPassWitchsTurnCommand game') $ \(Blind passWitchsTurnCommand) -> do+ hasn't (stage . _VillagesTurn) (run_ (apply passWitchsTurnCommand >> checkStage) game') where game' = game & allowedVoters .~ [] @@ -164,10 +178,6 @@ wolfHoundsName = game ^?! players . wolfHounds . name game' = run_ (apply (quitCommand wolfHoundsName) >> checkStage) game -prop_checkStageDoesNothingWhenGameOver :: GameAtGameOver -> Property-prop_checkStageDoesNothingWhenGameOver (GameAtGameOver game) =- run_ checkStage game === game- prop_checkDefendersTurnAdvancesToWerewolvesTurn :: GameWithProtect -> Bool prop_checkDefendersTurnAdvancesToWerewolvesTurn (GameWithProtect game) = has (stage . _WerewolvesTurn) (run_ checkStage game)@@ -183,6 +193,60 @@ prop_checkDefendersTurnDoesNothingUnlessProtected (GameAtDefendersTurn game) = has (stage . _DefendersTurn) (run_ checkStage game) +prop_checkDevotedServantsTurnAdvancesToWolfHoundsTurn :: GameAtDevotedServantsTurn -> Property+prop_checkDevotedServantsTurnAdvancesToWolfHoundsTurn (GameAtDevotedServantsTurn game) = do+ forAll (arbitraryCommand game) $ \(Blind command) ->+ isn't angel target && isn't wolfHound target+ ==> has (stage . _WolfHoundsTurn) (run_ (apply command >> checkStage) game)+ where+ target = head $ getVoteResult game++prop_checkDevotedServantsTurnAdvancesWhenNoDevotedServant :: GameAtDevotedServantsTurn -> Bool+prop_checkDevotedServantsTurnAdvancesWhenNoDevotedServant (GameAtDevotedServantsTurn game) = do+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = quitCommand devotedServantsName++ hasn't (stage . _DevotedServantsTurn) (run_ (apply command >> checkStage) game)++prop_checkDevotedServantsTurnDoesNothingUnlessRevealedOrPassed :: GameAtDevotedServantsTurn -> Bool+prop_checkDevotedServantsTurnDoesNothingUnlessRevealedOrPassed (GameAtDevotedServantsTurn game) =+ has (stage . _DevotedServantsTurn) (run_ checkStage game)++prop_checkLynchingLynchesOnePlayerWhenConsensus :: GameWithPassAtDevotedServantsTurn -> Property+prop_checkLynchingLynchesOnePlayerWhenConsensus (GameWithPassAtDevotedServantsTurn game) =+ isn't villageIdiot target+ ==> length (run_ checkStage game ^.. players . traverse . dead) == 1+ where+ target = head $ getVoteResult game++prop_checkLynchingLynchesNoOneWhenTargetIsVillageIdiot :: GameAtVillagesTurn -> Bool+prop_checkLynchingLynchesNoOneWhenTargetIsVillageIdiot (GameAtVillagesTurn game) = do+ let game' = foldr (\player -> run_ (apply $ voteLynchCommand (player ^. name) (villageIdiot ^. name))) game (game ^. players)++ none (is dead) (run_ checkStage game' ^. players)+ where+ villageIdiot = game ^?! players . villageIdiots++prop_checkLynchingLynchesScapegoatWhenConflicted :: GameAtScapegoatsTurn -> Bool+prop_checkLynchingLynchesScapegoatWhenConflicted (GameAtScapegoatsTurn game) =+ is dead $ run_ checkStage game ^?! players . scapegoats++prop_checkLynchingResetsVotes :: GameWithPassAtDevotedServantsTurn -> Property+prop_checkLynchingResetsVotes (GameWithPassAtDevotedServantsTurn game) =+ isn't devotedServant target+ ==> Map.null $ run_ checkStage game ^. votes+ where+ target = head $ getVoteResult game++prop_checkLynchingSetsAllowedVoters :: GameWithLynchVotes -> Property+prop_checkLynchingSetsAllowedVoters (GameWithLynchVotes game) =+ game' ^. allowedVoters === expectedAllowedVoters ^.. names+ where+ game' = run_ checkStage game+ expectedAllowedVoters+ | game' ^. villageIdiotRevealed = filter (isn't villageIdiot) $ game' ^. players+ | otherwise = game' ^.. players . traverse . alive+ prop_checkScapegoatsTurnAdvancesToWolfHoundsTurn :: GameWithAllowedVoters -> Bool prop_checkScapegoatsTurnAdvancesToWolfHoundsTurn (GameWithAllowedVoters game) = has (stage . _WolfHoundsTurn) (run_ checkStage game)@@ -231,34 +295,28 @@ prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead (GameWithRoleModelAtVillagesTurn game) = do let game' = foldr (\player -> run_ (apply $ voteLynchCommand (player ^. name) (roleModel' ^. name))) game (game ^. players) - isn't angel roleModel' && isn't villageIdiot roleModel'- ==> is werewolf $ run_ checkStage game' ^?! players . wildChildren+ let devotedServantsName = game ^?! players . devotedServants . name+ let command = passDevotedServantsTurnCommand devotedServantsName++ isn't angel roleModel' && isn't devotedServant roleModel' && isn't villageIdiot roleModel'+ ==> is werewolf $ run_ (checkStage >> apply command >> checkStage) game' ^?! players . wildChildren where roleModel' = game ^?! players . traverse . filteredBy name (fromJust $ game ^. roleModel) -prop_checkVillagesTurnAdvancesToScapegoatsTurn :: GameWithScapegoatBlamed -> Bool-prop_checkVillagesTurnAdvancesToScapegoatsTurn (GameWithScapegoatBlamed game) =- has (stage . _ScapegoatsTurn) (run_ checkStage game)--prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: GameWithLynchVotes -> Property-prop_checkVillagesTurnLynchesOnePlayerWhenConsensus (GameWithLynchVotes game) =- length (getVoteResult game) == 1- && isn't villageIdiot target- ==> length (run_ checkStage game ^.. players . traverse . dead) == 1+prop_checkVillagesTurnAdvancesToDevotedServantsTurn :: GameWithMajorityVote -> Property+prop_checkVillagesTurnAdvancesToDevotedServantsTurn (GameWithMajorityVote game) =+ isn't angel target && isn't devotedServant target+ ==> has (stage . _DevotedServantsTurn) (run_ checkStage game) where target = head $ getVoteResult game -prop_checkVillagesTurnLynchesNoOneWhenTargetIsVillageIdiot :: GameAtVillagesTurn -> Bool-prop_checkVillagesTurnLynchesNoOneWhenTargetIsVillageIdiot (GameAtVillagesTurn game) = do- let game' = foldr (\player -> run_ (apply $ voteLynchCommand (player ^. name) (villageIdiot ^. name))) game (game ^. players)-- none (is dead) (run_ checkStage game' ^. players)- where- villageIdiot = game ^?! players . villageIdiots+prop_checkVillagesTurnSkipsDevotedServantsTurnWhenConflicted :: GameWithConflictingVote -> Bool+prop_checkVillagesTurnSkipsDevotedServantsTurnWhenConflicted (GameWithConflictingVote game) =+ hasn't (stage . _DevotedServantsTurn) (run_ checkStage game) -- TODO (hjw): tidy this test-prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats :: Game -> Property-prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats game =+prop_checkLynchingLynchesNoOneWhenConflictedAndNoScapegoats :: Game -> Property+prop_checkLynchingLynchesNoOneWhenConflictedAndNoScapegoats game = forAll (runArbitraryCommands n game') $ \game'' -> length (getVoteResult game'') > 1 ==> run_ checkStage game'' ^. players == game' ^. players@@ -267,23 +325,6 @@ game' = killPlayer scapegoatsName game & stage .~ VillagesTurn n = length $ game' ^. players -prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: GameAtScapegoatsTurn -> Bool-prop_checkVillagesTurnLynchesScapegoatWhenConflicted (GameAtScapegoatsTurn game) =- is dead $ run_ checkStage game ^?! players . scapegoats--prop_checkVillagesTurnResetsVotes :: GameWithLynchVotes -> Bool-prop_checkVillagesTurnResetsVotes (GameWithLynchVotes game) =- Map.null $ run_ checkStage game ^. votes--prop_checkVillagesTurnSetsAllowedVoters :: GameWithLynchVotes -> Property-prop_checkVillagesTurnSetsAllowedVoters (GameWithLynchVotes game) =- game' ^. allowedVoters === expectedAllowedVoters ^.. names- where- game' = run_ checkStage game- expectedAllowedVoters- | game' ^. villageIdiotRevealed = filter (isn't villageIdiot) $ game' ^. players- | otherwise = game' ^.. players . traverse . alive- prop_checkVillagesTurnDoesNothingUnlessAllVoted :: GameAtVillagesTurn -> Property prop_checkVillagesTurnDoesNothingUnlessAllVoted (GameAtVillagesTurn game) = forAll (runArbitraryCommands n game) $ \game' ->@@ -353,7 +394,7 @@ prop_checkWitchsTurnAdvancesToVillagesTurn :: GameAtWitchsTurn -> Property prop_checkWitchsTurnAdvancesToVillagesTurn (GameAtWitchsTurn game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> has (stage . _VillagesTurn) (run_ (apply command >> checkStage) game) prop_checkWitchsTurnAdvancesWhenNoWitch :: GameAtWitchsTurn -> Bool@@ -365,17 +406,17 @@ prop_checkWitchsTurnHealsDevoureeWhenHealed :: GameWithHeal -> Property prop_checkWitchsTurnHealsDevoureeWhenHealed (GameWithHeal game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> none (is dead) (run_ (apply command >> checkStage) game ^. players) prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: GameWithPoison -> Property prop_checkWitchsTurnKillsOnePlayerWhenPoisoned (GameWithPoison game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> length (run_ (apply command >> checkStage) game ^.. players . traverse . dead) == 1 prop_checkWitchsTurnDoesNothingWhenPassed :: GameAtWitchsTurn -> Property prop_checkWitchsTurnDoesNothingWhenPassed (GameAtWitchsTurn game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> none (is dead) $ run_ (apply command >> checkStage) game ^. players prop_checkWitchsTurnDoesNothingUnlessActionedOrPassed :: GameAtWitchsTurn -> Bool@@ -384,17 +425,17 @@ prop_checkWitchsTurnResetsHeal :: GameWithHeal -> Property prop_checkWitchsTurnResetsHeal (GameWithHeal game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> not $ run_ (apply command >> checkStage) game ^. heal prop_checkWitchsTurnResetsPoison :: GameWithPoison -> Property prop_checkWitchsTurnResetsPoison (GameWithPoison game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> isNothing $ run_ (apply command >> checkStage) game ^. poison prop_checkWitchsTurnClearsPasses :: GameAtWitchsTurn -> Property prop_checkWitchsTurnClearsPasses (GameAtWitchsTurn game) =- forAll (arbitraryPassCommand game) $ \(Blind command) ->+ forAll (arbitraryPassWitchsTurnCommand game) $ \(Blind command) -> null $ run_ (apply command >> checkStage) game ^. passes prop_checkWolfHoundsTurnAdvancesToSeersTurn :: GameAtWolfHoundsTurn -> Property@@ -425,6 +466,10 @@ let game' = foldr killPlayer game (players' ^.. names) has (stage . _GameOver) $ run_ checkGameOver game'++prop_checkGameOverDoesNothingWhenGameOver :: GameAtGameOver -> Property+prop_checkGameOverDoesNothingWhenGameOver (GameAtGameOver game) =+ run_ checkStage game === game -- TODO (hjw): pending --prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive :: GameWithDeadPlayers -> Property
test/src/Game/Werewolf/Test/Util.hs view
@@ -7,7 +7,7 @@ module Game.Werewolf.Test.Util ( -- * Utility functions- run, run_,+ run, run_, verbose_runCommandErrors, ) where import Control.Monad.Except@@ -16,11 +16,20 @@ import Data.Either.Extra +import Game.Werewolf.Command import Game.Werewolf.Game import Game.Werewolf.Response +import Test.QuickCheck+ 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++verbose_runCommandErrors :: Game -> Command -> Property+verbose_runCommandErrors game command = whenFail (mapM_ putStrLn data_) (isLeft result)+ where+ result = run (apply command) game+ data_ = [show game, show $ fromRight result]
werewolf.cabal view
@@ -1,5 +1,5 @@ name: werewolf-version: 0.4.8.0+version: 0.4.9.0 author: Henry J. Wylde maintainer: public@hjwylde.com@@ -28,22 +28,23 @@ hs-source-dirs: app/ ghc-options: -threaded -with-rtsopts=-N other-modules:- Werewolf.Commands.Choose- Werewolf.Commands.Circle- 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- Werewolf.Commands.Status- Werewolf.Commands.Version- Werewolf.Commands.Vote+ Werewolf.Command.Choose+ Werewolf.Command.Circle+ Werewolf.Command.End+ Werewolf.Command.Heal+ Werewolf.Command.Help+ Werewolf.Command.Interpret+ Werewolf.Command.Pass+ Werewolf.Command.Ping+ Werewolf.Command.Poison+ Werewolf.Command.Protect+ Werewolf.Command.Quit+ Werewolf.Command.Reveal+ Werewolf.Command.See+ Werewolf.Command.Start+ Werewolf.Command.Status+ Werewolf.Command.Version+ Werewolf.Command.Vote Werewolf.Game Werewolf.Messages Werewolf.Options@@ -113,6 +114,15 @@ other-modules: Game.Werewolf.Test.Arbitrary Game.Werewolf.Test.Command+ Game.Werewolf.Test.Command.Choose+ Game.Werewolf.Test.Command.Heal+ Game.Werewolf.Test.Command.Pass+ Game.Werewolf.Test.Command.Poison+ Game.Werewolf.Test.Command.Protect+ Game.Werewolf.Test.Command.Quit+ Game.Werewolf.Test.Command.Reveal+ Game.Werewolf.Test.Command.See+ Game.Werewolf.Test.Command.Vote Game.Werewolf.Test.Engine Game.Werewolf.Test.Game Game.Werewolf.Test.Player