werewolf 0.4.0.1 → 0.4.1.0

raw patch · 25 files changed

+1095/−328 lines, 25 files

Files

• CHANGELOG.md +3/−4
• README.md +41/−34
• app/Main.hs +6/−0
• app/Werewolf/Commands/Help.hs +16/−6
• app/Werewolf/Commands/Pass.hs +41/−0
• app/Werewolf/Commands/Ping.hs +0/−2
• app/Werewolf/Commands/Poison.hs +49/−0
• app/Werewolf/Commands/Quit.hs +0/−2
• app/Werewolf/Commands/See.hs +0/−2
• app/Werewolf/Commands/Start.hs +0/−2
• app/Werewolf/Commands/Status.hs +0/−2
• app/Werewolf/Commands/Vote.hs +0/−2
• app/Werewolf/Options.hs +16/−0
• src/Game/Werewolf/Command.hs +60/−10
• src/Game/Werewolf/Engine.hs +64/−20
• src/Game/Werewolf/Game.hs +59/−22
• src/Game/Werewolf/Player.hs +8/−2
• src/Game/Werewolf/Response.hs +77/−31
• src/Game/Werewolf/Role.hs +19/−2
• test/app/Main.hs +117/−69
• test/src/Game/Werewolf/Test/Arbitrary.hs +46/−12
• test/src/Game/Werewolf/Test/Command.hs +299/−57
• test/src/Game/Werewolf/Test/Engine.hs +149/−45
• test/src/Game/Werewolf/Test/Game.hs +22/−1
• werewolf.cabal +3/−1

@@ -2,11 +2,11 @@  #### Upcoming -#### v0.4.0.1+#### v0.4.1.0 -*Revisions*+*Minor* -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83))+* Added a Witch role. ([#5](https://github.com/hjwylde/werewolf/issues/5))  #### v0.4.0.0 @@ -14,7 +14,6 @@  * Restricted count of special roles to 1. ([#32](https://github.com/hjwylde/werewolf/issues/32)) * Changed private message structure to only ever be for a single player. ([#21](https://github.com/hjwylde/werewolf/issues/21))-* Changed `start` to assume the caller wishes to play. ([#75](https://github.com/hjwylde/werewolf/issues/75))  *Minor* 

@@ -24,6 +24,7 @@ * Seer. * Villager. * Werewolf.+* Witch.  ### Installing @@ -52,13 +53,15 @@ All werewolf commands are designed to be run by a user from the chat client. E.g., to start a game: ```bash-> werewolf --caller @foo start @foo @bar @baz @qux @quux @corge @grault+> werewolf --caller @foo start --extra-roles seer @bar @baz @qux @quux @corge @grault {"ok":true,"messages":[-    {"to":["@foo"],"message":"You're a Villager.\nAn ordinary townsperson humbly living in Millers Hollow.\n"},+    {"to":null,"message":"A new game of werewolf is starting with @foo, @bar, @baz, @qux, @quux, @corge, @grault!"},+    {"to":null,"message":"The roles in play are Seer (1), Villager (4), Werewolf (2)."},+    {"to":"@foo","message":"You're a Werewolf, along with @baz.\nA shapeshifting townsperson that, at night, hunts the residents of Millers Hollow."},     ...,     {"to":null,"message":"Night falls, the village is asleep."},-    {"to":null,"message":"The Seers wake up."},-    {"to":["@grault"],"message":"Who's allegiance would you like to see?"}+    {"to":null,"message":"The Seer wakes up."},+    {"to":"@qux","message":"Whose allegiance would you like to see?"}     ]} ``` @@ -68,56 +71,60 @@  Any command ran returns a JSON result. The result contains a boolean for whether the command was successful and a list of messages.-The `to` header on a message may either be `null` for a public message or have a list of intended-    recipients.+The `to` header on a message may either be `null`---for a public message---or have an intended+    recipient. -It's the Seers' turn now.+It's the Seer's turn now. ```bash-> werewolf --caller @grault see @qux+> werewolf --caller @qux see @grault {"ok":true,"messages":[-    {"to":["@grault"],"message":"@qux is a Villager."},+    {"to":"@qux","message":"@grault is aligned with the Villagers."},     {"to":null,"message":"The Werewolves wake up, recognise one another and choose a new victim."},-    {"to":["@bar","@corge"],"message":"Who would you like to devour?"}+    {"to":"@foo","message":"Whom would you like to devour?"},+    {"to":"@baz","message":"Whom would you like to devour?"}     ]} ``` -Let's have _@bar_, a Werewolf, vote to devour a Villager.+Let's have the Werewolves, _@foo_ and _@baz_, vote to devour a Villager. ```bash-> werewolf --caller @bar vote @foo-{"ok":true,"messages":[]}+> werewolf --caller @foo vote @bar+{"ok":true,"messages":[+    {"to":"@baz","message":"@foo voted to devour @bar."}+    ]}+> werewolf --caller @baz vote @bar+{"ok":true,"messages":[+    {"to":"@foo","message":"@baz voted to devour @bar."},+    {"to":null,"message":"The sun rises. Everybody wakes up and opens their eyes..."},+    {"to":null,"message":"As you open them you notice a door broken down and @bar's guts half devoured and spilling out over the cobblestones. From the look of their personal effects, you deduce they were a Villager."},+    {"to":null,"message":"As the village gathers in the town square the town clerk calls for a vote."},+    {"to":null,"message":"Whom would you like to lynch?"}+    ]} ``` -This time, even though the command was successful, there are no messages.-In this implementation of werewolf votes are only revealed once tallied.-+Too bad for _@bar_. Maybe the village can get some vengeance... ```bash-> werewolf --caller @bar vote @foo-{"ok":false,"messages":[{"to":["@bar"],"message":"You've already voted!"}]}+> werewolf --caller @qux vote @foo+{"ok":true,"messages":[]} ``` -Here the command was unsuccessful and an error message is sent to _@bar_.-Note that even though the command was unsuccessful, the chat client interface probably won't need to-    do anything special.-Relaying the error message back to the user should suffice.+This time, even though the command was successful, there are no messages.  ```bash-> werewolf --caller @corge vote @foo-{"ok":true,"messages":[-    {"to":["@bar","@corge"],"message":"@bar voted to devour @foo."},-    {"to":["@bar","@corge"],"message":"@corge voted to devour @foo."},-    {"to":null,"message":"The sun rises. Everybody wakes up and opens their eyes..."},-    {"to":null,"message":"As you open them you notice a door broken down and @foo's guts spilling out over the cobblestones. From the look of their personal effects, you deduce they were a Villager."}-    ]}+> werewolf --caller @qux vote @foo+{"ok":false,"messages":[{"to":["@qux"],"message":"You've already voted!"}]} ``` -And so on.+Here the command was unsuccessful and an error message is sent to _@qux_.+Even though the command was unsuccessful, the chat client interface probably won't need to do+    anything special.+Relaying the error message back to the user should suffice.  Thus a chat client interface must implement the following: * The ability to call werewolf commands. This includes passing the `--caller` option and arguments-  correctly. Note that it is possible to just implement the `interpret` command, which interprets-  the caller's input.-* The ability to send resultant messages. Resultant messages may be to everyone or to specific-  users.+  correctly. It is possible to only implement the `interpret` command, which interprets the+  caller's input.+* The ability to send resultant messages. Resultant messages may be to everyone or to a specific+  user.  #### Commands 

@@ -23,9 +23,12 @@ import System.Environment  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.Quit      as Quit import qualified Werewolf.Commands.See       as See import qualified Werewolf.Commands.Start     as Start@@ -50,9 +53,12 @@ handle :: Options -> IO () handle (Options callerName command) = case command of     End                                 -> End.handle callerName+    Heal                                -> Heal.handle callerName     Help options                        -> Help.handle callerName options     Interpret (Interpret.Options args)  -> interpret callerName args+    Pass                                -> Pass.handle callerName     Ping                                -> Ping.handle callerName+    Poison options                      -> Poison.handle callerName options     Quit                                -> Quit.handle callerName     See options                         -> See.handle callerName options     Start options                       -> Start.handle callerName options

@@ -64,14 +64,23 @@     "end",     "- Ends the current game."     ], [+    "heal PLAYER",+    "- Heal a devoured player. The Witch may heal a devoured player at nighttime."+    ], [+    "pass",+    "- Pass. A Witch may pass on poisoning a player."+    ], [     "ping",     "- Pings the status of the current game publicly."     ], [+    "poison PLAYER",+    "- Poison a player. The Witch may poison a player at nighttime."+    ], [     "quit",     "- Quit the current game."     ], [     "see PLAYER",-    "- See a player's allegiance. A Seer may determine a player's allegiance once per day."+    "- See a player's allegiance. The Seer may determine a player's allegiance once per day."     ], [     "start [--extra-roles ROLE,...] PLAYER ...",     "- Starts a new game with the given players and extra roles. A game requires at least 7 players."@@ -113,8 +122,8 @@     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.",-        "Depending upon the number of players and variants used in the game,",-        "there are 1, 2, 3 or 4 Werewolves in play."+        "The number of Werewolves in play depends upon",+        " the number of players and variants used in the game,"         ],     T.unwords [         "Each day,",@@ -130,10 +139,11 @@         "at the start of the game. A game begins at night and follows a standard cycle."         ],     "1. The village falls asleep.",-    "2. The Seers wake up and each see someone.",+    "2. The Seer wakes up and sees someone's allegiance.",     "3. The Werewolves wake up and select a victim.",-    "4. The village wakes up and find the victim.",-    "5. The village votes to lynch a suspect.",+    "4. The Witch wakes up and may heal the victim and/or poison someone.",+    "5. The village wakes up and find the victim.",+    "6. The village votes to lynch a suspect.",     "The game is over when only Villagers or Werewolves are left alive."     ]] 

@@ -0,0 +1,41 @@+{-|+Module      : Werewolf.Commands.Pass+Description : Handler for the pass subcommand.++Copyright   : (c) Henry J. Wylde, 2015+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.Command+import Game.Werewolf.Engine+import Game.Werewolf.Response++-- | Handle.+handle :: MonadIO m => Text -> m ()+handle callerName = do+    unlessM doesGameExist $ exitWith failure {+        messages = [noGameRunningMessage callerName]+        }++    game <- readGame++    let command = 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 }

@@ -9,8 +9,6 @@ Handler for the ping subcommand. -} -{-# LANGUAGE OverloadedStrings #-}- module Werewolf.Commands.Ping (     -- * Handle     handle,

@@ -0,0 +1,49 @@+{-|+Module      : Werewolf.Commands.Poison+Description : Options and handler for the poison subcommand.++Copyright   : (c) Henry J. Wylde, 2015+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.Command+import Game.Werewolf.Engine+import Game.Werewolf.Response++-- | Options.+data Options = Options+    { argTarget :: Text+    } deriving (Eq, Show)++-- | Handle.+handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options targetName) = do+    unlessM doesGameExist $ exitWith failure {+        messages = [noGameRunningMessage callerName]+        }++    game <- readGame++    let command = 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 }

@@ -9,8 +9,6 @@ Handler for the quit subcommand. -} -{-# LANGUAGE OverloadedStrings #-}- module Werewolf.Commands.Quit (     -- * Handle     handle,

@@ -9,8 +9,6 @@ Options and handler for the see subcommand. -} -{-# LANGUAGE OverloadedStrings #-}- module Werewolf.Commands.See (     -- * Options     Options(..),

@@ -9,8 +9,6 @@ Options and handler for the start subcommand. -} -{-# LANGUAGE OverloadedStrings #-}- module Werewolf.Commands.Start (     -- * Options     Options(..),

@@ -9,8 +9,6 @@ Handler for the status subcommand. -} -{-# LANGUAGE OverloadedStrings #-}- module Werewolf.Commands.Status (     -- * Handle     handle,

@@ -9,8 +9,6 @@ Options and handler for the vote subcommand. -} -{-# LANGUAGE OverloadedStrings #-}- module Werewolf.Commands.Vote (     -- * Options     Options(..),

@@ -27,6 +27,7 @@  import qualified Werewolf.Commands.Help      as Help import qualified Werewolf.Commands.Interpret as Interpret+import qualified Werewolf.Commands.Poison    as Poison import qualified Werewolf.Commands.See       as See import qualified Werewolf.Commands.Start     as Start import qualified Werewolf.Commands.Vote      as Vote@@ -43,9 +44,12 @@ -- | Command. data Command     = End+    | Heal     | Help Help.Options     | Interpret Interpret.Options+    | Pass     | Ping+    | Poison Poison.Options     | Quit     | See See.Options     | Start Start.Options@@ -84,9 +88,12 @@         ])     <*> subparser (mconcat [         command "end"       $ info (helper <*> end)         (fullDesc <> progDesc "End the current game"),+        command "heal"      $ info (helper <*> heal)        (fullDesc <> progDesc "Heal the devoured player"),         command "help"      $ info (helper <*> help_)       (fullDesc <> progDesc "Help documents"),         command "interpret" $ info (helper <*> interpret)   (fullDesc <> progDesc "Interpret a command" <> noIntersperse),+        command "pass"      $ info (helper <*> pass)        (fullDesc <> progDesc "Pass"),         command "ping"      $ info (helper <*> ping)        (fullDesc <> progDesc "Pings the status of the current game publicly"),+        command "poison"    $ info (helper <*> poison)      (fullDesc <> progDesc "Poison a player"),         command "quit"      $ info (helper <*> quit)        (fullDesc <> progDesc "Quit the current game"),         command "see"       $ info (helper <*> see)         (fullDesc <> progDesc "See a player's allegiance"),         command "start"     $ info (helper <*> start)       (fullDesc <> progDesc "Start a new game"),@@ -97,6 +104,9 @@ end :: Parser Command end = pure End +heal :: Parser Command+heal = pure Heal+ help_ :: Parser Command help_ = Help . Help.Options     <$> optional (subparser $ mconcat [@@ -109,8 +119,14 @@ interpret :: Parser Command interpret = Interpret . Interpret.Options <$> many (T.pack <$> strArgument (metavar "-- COMMAND ARG...")) +pass :: Parser Command+pass = pure Pass+ ping :: Parser Command ping = pure Ping++poison :: Parser Command+poison = Poison . Poison.Options . T.pack <$> strArgument (metavar "PLAYER")  quit :: Parser Command quit = pure Quit

@@ -18,8 +18,8 @@     Command(..),      -- ** Instances-    devourVoteCommand, lynchVoteCommand, noopCommand, pingCommand, quitCommand, seeCommand,-    statusCommand,+    devourVoteCommand, healCommand, lynchVoteCommand, noopCommand, passCommand, pingCommand,+    poisonCommand, quitCommand, seeCommand, statusCommand, ) where  import Control.Lens         hiding (only)@@ -28,12 +28,15 @@ import Control.Monad.State  hiding (state) import Control.Monad.Writer -import qualified Data.Map  as Map-import           Data.Text (Text)+import           Data.List+import qualified Data.Map   as Map+import           Data.Maybe+import           Data.Text  (Text)  import Game.Werewolf.Engine-import Game.Werewolf.Game     hiding (getPendingVoters, getPlayerVote, isGameOver, isSeersTurn,-                               isVillagesTurn, isWerewolvesTurn, killPlayer)+import Game.Werewolf.Game     hiding (getDevourEvent, getPendingVoters, getPlayerVote, isGameOver,+                               isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWitchsTurn,+                               killPlayer) import Game.Werewolf.Player   hiding (doesPlayerExist) import Game.Werewolf.Response @@ -46,14 +49,25 @@     unlessM isWerewolvesTurn                        $ throwError [playerCannotDoThatRightNowMessage callerName]     whenJustM (getPlayerVote callerName) . const    $ throwError [playerHasAlreadyVotedMessage callerName]     validatePlayer callerName targetName-    whenM (isPlayerWerewolf targetName)             $ throwError [playerCannotDevourAnotherWerewolf callerName]+    whenM (isPlayerWerewolf targetName)             $ throwError [playerCannotDevourAnotherWerewolfMessage callerName]      votes %= Map.insert callerName targetName -    aliveWerewolves <- uses players $ filterAlive . filterWerewolves+    aliveWerewolfNames <- uses players $ map _name . filterAlive . filterWerewolves -    tell $ map (\werewolf -> playerMadeDevourVoteMessage (werewolf ^. name) callerName targetName) aliveWerewolves+    tell $ map (\werewolfName -> playerMadeDevourVoteMessage werewolfName callerName targetName) (aliveWerewolfNames \\ [callerName]) +healCommand :: Text -> Command+healCommand callerName = Command $ do+    validatePlayer callerName callerName+    unlessM (isPlayerWitch callerName)      $ throwError [playerCannotDoThatMessage callerName]+    unlessM isWitchsTurn                    $ throwError [playerCannotDoThatRightNowMessage callerName]+    whenM (use healUsed)                    $ throwError [playerHasAlreadyHealedMessage callerName]+    whenM (isNothing <$> getDevourEvent)    $ throwError [playerCannotDoThatRightNowMessage callerName]++    heal        .= True+    healUsed    .= True+ lynchVoteCommand :: Text -> Text -> Command lynchVoteCommand callerName targetName = Command $ do     validatePlayer callerName callerName@@ -66,6 +80,14 @@ noopCommand :: Command noopCommand = Command $ return () +passCommand :: Text -> Command+passCommand callerName = Command $ do+    validatePlayer callerName callerName+    unlessM (isPlayerWitch callerName)      $ throwError [playerCannotDoThatMessage callerName]+    unlessM isWitchsTurn                    $ throwError [playerCannotDoThatRightNowMessage callerName]++    passes %= nub . cons callerName+ pingCommand :: Command pingCommand = Command $ use stage >>= \stage' -> case stage' of     GameOver        -> return ()@@ -86,7 +108,25 @@          tell [pingWerewolvesMessage]         tell $ map (pingPlayerMessage . _name) (filterWerewolves pendingVoters)+    WitchsTurn      -> do+        witch <- uses players $ head . filterAlive . filterWitches +        tell [pingWitchMessage]+        tell [pingPlayerMessage $ witch ^. name]++poisonCommand :: Text -> Text -> Command+poisonCommand callerName targetName = Command $ do+    validatePlayer callerName callerName+    unlessM (isPlayerWitch callerName)      $ throwError [playerCannotDoThatMessage callerName]+    unlessM isWitchsTurn                    $ throwError [playerCannotDoThatRightNowMessage callerName]+    whenM (use poisonUsed)                  $ throwError [playerHasAlreadyPoisonedMessage callerName]+    validatePlayer callerName targetName+    whenJustM getDevourEvent                $ \(DevourEvent targetName') ->+        when (targetName == targetName') $ throwError [playerCannotDoThatMessage callerName]++    poison      .= Just targetName+    poisonUsed  .= True+ quitCommand :: Text -> Command quitCommand callerName = Command $ do     validatePlayer callerName callerName@@ -96,7 +136,13 @@     killPlayer caller     tell [playerQuitMessage caller] -    when (isSeer caller) $ see .= Nothing+    passes %= delete callerName+    when (isWitch caller)   $ do+        heal        .= False+        healUsed    .= False+        poison      .= Nothing+        poisonUsed  .= False+    when (isSeer caller)    $ see .= Nothing     votes %= Map.delete callerName  seeCommand :: Text -> Text -> Command@@ -130,6 +176,10 @@         tell $ standardStatusMessages stage' (game ^. players)         whenM (doesPlayerExist callerName &&^ isPlayerWerewolf callerName) $             tell [waitingOnMessage (Just callerName) pendingVoters]+    WitchsTurn      -> do+        game <- get++        tell $ standardStatusMessages stage' (game ^. players)     where         standardStatusMessages stage players =             currentStageMessages callerName stage ++ [

@@ -23,25 +23,30 @@     startGame, killPlayer,      -- ** Queries-    isGameOver, isSeersTurn, isVillagesTurn, isWerewolvesTurn, getPlayerVote, getPendingVoters,-    getVoteResult,+    isGameOver, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, getPlayerVote,+    getPendingVoters, getVoteResult,      -- ** Reading and writing     defaultFilePath, writeGame, readGame, deleteGame, doesGameExist, +    -- * Event++    -- ** Queries+    getDevourEvent,+     -- * Player      -- ** Manipulations     createPlayers,      -- ** Queries-    doesPlayerExist, isPlayerSeer, isPlayerWerewolf, isPlayerDead,+    doesPlayerExist, isPlayerSeer, isPlayerWerewolf, isPlayerWitch, isPlayerAlive, isPlayerDead,      -- * Role     randomiseRoles, ) where -import Control.Lens         hiding (cons)+import Control.Lens         hiding (cons, snoc) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Random@@ -53,15 +58,15 @@ import           Data.Text       (Text) import qualified Data.Text       as T -import           Game.Werewolf.Game     hiding (getPendingVoters, getPlayerVote, getVoteResult,-                                         isGameOver, isSeersTurn, isVillagesTurn, isWerewolvesTurn,-                                         killPlayer)+import           Game.Werewolf.Game     hiding (getDevourEvent, getPassers, getPendingVoters,+                                         getPlayerVote, getVoteResult, isGameOver, isSeersTurn,+                                         isVillagesTurn, isWerewolvesTurn, isWitchsTurn, killPlayer) import qualified Game.Werewolf.Game     as Game import           Game.Werewolf.Player   hiding (doesPlayerExist) import qualified Game.Werewolf.Player   as Player import           Game.Werewolf.Response import           Game.Werewolf.Role     (Role, scapegoatRole, seerRole, villagerRole, werewolfRole,-                                         _allegiance)+                                         witchRole, _allegiance) import qualified Game.Werewolf.Role     as Role  import System.Directory@@ -81,8 +86,8 @@     GameOver -> return ()      SeersTurn -> whenJustM (use see) $ \targetName -> do-        seer <- uses players (head . filterSeers)-        target <- uses players (findByName_ targetName)+        seer    <- uses players (head . filterSeers)+        target  <- uses players (findByName_ targetName)          tell [playerSeenMessage (seer ^. name) target] @@ -115,26 +120,38 @@          whenM (uses votes $ (length aliveWerewolves ==) . Map.size) $ do             getVoteResult >>= \votees -> case votees of-                [target]    -> events %= cons (Devour $ target ^. name)+                [target]    -> events %= cons (DevourEvent $ target ^. name)                 _           -> tell [noPlayerDevouredMessage]              advanceStage +    WitchsTurn -> do+        whenJustM (use poison) $ \targetName -> do+            events %= (++ [PoisonEvent targetName])+            poison .= Nothing++        witch <- uses players (head . filterWitches)++        whenM (use healUsed &&^ use poisonUsed) advanceStage+        whenM (fmap (witch `elem`) getPassers)  advanceStage+ advanceStage :: (MonadState Game m, MonadWriter [Message] m) => m () advanceStage = do-    stage' <- use stage-    alivePlayers <- uses players filterAlive+    game            <- get+    stage'          <- use stage+    alivePlayers    <- uses players filterAlive      let nextStage = if length (nub $ map (_allegiance . _role) alivePlayers) <= 1         then GameOver-        else head $ filter (stageAvailable $ map _role alivePlayers) (drop1 $ dropWhile (stage' /=) stageCycle)--    tell $ stageMessages nextStage alivePlayers+        else head $ filter (stageAvailable game) (drop1 $ dropWhile (stage' /=) stageCycle)      stage   .= nextStage+    passes  .= []     see     .= Nothing     votes   .= Map.empty +    tell . stageMessages =<< get+ checkEvents :: (MonadState Game m, MonadWriter [Message] m) => m () checkEvents = do     (available, pending) <- use events >>= partitionM eventAvailable@@ -144,15 +161,27 @@     mapM_ applyEvent available  eventAvailable :: MonadState Game m => Event -> m Bool-eventAvailable (Devour _) = gets isSunrise+eventAvailable (DevourEvent _) = gets isSunrise+eventAvailable (PoisonEvent _) = gets isSunrise  applyEvent :: (MonadState Game m, MonadWriter [Message] m) => Event -> m ()-applyEvent (Devour name) = do+applyEvent (DevourEvent targetName) = do+    player  <- uses players $ findByName_ targetName+    heal'   <- use heal++    if heal'+        then tell [playerHealedMessage $ player ^. name]+        else do+            killPlayer player+            tell [playerDevouredMessage player]++    heal .= False+applyEvent (PoisonEvent name) = do     player <- uses players $ findByName_ name      killPlayer player -    tell [playerDevouredMessage player]+    tell [playerPoisonedMessage player]  checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do@@ -175,7 +204,7 @@     return game     where         playerNames = map _name players-        restrictedRoles = [scapegoatRole, seerRole]+        restrictedRoles = [scapegoatRole, seerRole, witchRole]  killPlayer :: MonadState Game m => Player -> m () killPlayer player = players %= map (\player' -> if player' == player then player' & state .~ Dead else player')@@ -189,9 +218,15 @@ isWerewolvesTurn :: MonadState Game m => m Bool isWerewolvesTurn = gets Game.isWerewolvesTurn +isWitchsTurn :: MonadState Game m => m Bool+isWitchsTurn = gets Game.isWitchsTurn+ isGameOver :: MonadState Game m => m Bool isGameOver = gets Game.isGameOver +getPassers :: MonadState Game m => m [Player]+getPassers = gets Game.getPassers+ getPlayerVote :: MonadState Game m => Text -> m (Maybe Text) getPlayerVote playerName = gets $ Game.getPlayerVote playerName @@ -219,6 +254,9 @@ doesGameExist :: MonadIO m => m Bool doesGameExist = liftIO $ defaultFilePath >>= doesFileExist +getDevourEvent :: MonadState Game m => m (Maybe Event)+getDevourEvent = gets Game.getDevourEvent+ createPlayers :: MonadIO m => [Text] -> [Role] -> m [Player] createPlayers playerNames extraRoles = zipWith newPlayer playerNames <$> randomiseRoles extraRoles (length playerNames) @@ -230,6 +268,12 @@  isPlayerWerewolf :: MonadState Game m => Text -> m Bool isPlayerWerewolf name = uses players $ isWerewolf . findByName_ name++isPlayerWitch :: MonadState Game m => Text -> m Bool+isPlayerWitch name = uses players $ isWitch . findByName_ name++isPlayerAlive :: MonadState Game m => Text -> m Bool+isPlayerAlive name = uses players $ isAlive . findByName_ name  isPlayerDead :: MonadState Game m => Text -> m Bool isPlayerDead name = uses players $ isDead . findByName_ name

@@ -13,15 +13,15 @@  module Game.Werewolf.Game (     -- * Game-    Game(..), stage, players, events, see, votes,+    Game(..), stage, players, events, passes, heal, healUsed, poison, poisonUsed, see, votes,     newGame,      -- ** Manipulations     killPlayer,      -- ** Queries-    isGameOver, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn, getPlayerVote,-    getPendingVoters, getVoteResult,+    isGameOver, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn, isWitchsTurn,+    getPassers, getPlayerVote, getPendingVoters, getVoteResult,      -- * Stage     Stage(..),@@ -29,6 +29,9 @@      -- * Event     Event(..),++    -- ** Queries+    getDevourEvent ) where  import Control.Lens@@ -36,23 +39,28 @@ import           Data.List.Extra import           Data.Map        (Map) import qualified Data.Map        as Map+import           Data.Maybe import           Data.Text       (Text)  import Game.Werewolf.Player-import Game.Werewolf.Role   hiding (Villagers, Werewolves, _name)  data Game = Game-    { _stage   :: Stage-    , _players :: [Player]-    , _events  :: [Event]-    , _see     :: Maybe Text-    , _votes   :: Map Text Text+    { _stage      :: Stage+    , _players    :: [Player]+    , _events     :: [Event]+    , _passes     :: [Text]+    , _heal       :: Bool+    , _healUsed   :: Bool+    , _poison     :: Maybe Text+    , _poisonUsed :: Bool+    , _see        :: Maybe Text+    , _votes      :: Map Text Text     } deriving (Eq, Read, Show) -data Stage = GameOver | SeersTurn | Sunrise | Sunset | VillagesTurn | WerewolvesTurn+data Stage = GameOver | SeersTurn | Sunrise | Sunset | VillagesTurn | WerewolvesTurn | WitchsTurn     deriving (Eq, Read, Show) -data Event = Devour Text+data Event = DevourEvent Text | PoisonEvent Text     deriving (Eq, Read, Show)  makeLenses ''Game@@ -60,10 +68,20 @@ makeLenses ''Stage  newGame :: [Player] -> Game-newGame players = Game stage players [] Nothing Map.empty+newGame players = game { _stage = head $ filter (stageAvailable game) stageCycle }     where-        stage       = head $ filter (stageAvailable aliveRoles) stageCycle-        aliveRoles  = map _role $ filterAlive players+        game = Game+            { _stage        = Sunset+            , _players      = players+            , _events       = []+            , _passes       = []+            , _heal         = False+            , _healUsed     = False+            , _poison       = Nothing+            , _poisonUsed   = False+            , _see          = Nothing+            , _votes        = Map.empty+            }  killPlayer :: Game -> Player -> Game killPlayer game player = game & players %~ map (\player' -> if player' == player then player' & state .~ Dead else player')@@ -86,6 +104,15 @@ isWerewolvesTurn :: Game -> Bool isWerewolvesTurn game = game ^. stage == WerewolvesTurn +isWitchsTurn :: Game -> Bool+isWitchsTurn game = game ^. stage == WitchsTurn++getPassers :: Game -> [Player]+getPassers game = map (`findByName_` players') passes'+    where+        players'    = game ^. players+        passes'     = game ^. passes+ getPlayerVote :: Text -> Game -> Maybe Text getPlayerVote playerName game = game ^. votes . at playerName @@ -103,12 +130,22 @@         result      = last $ groupSortOn (\votee -> length $ elemIndices votee votees) (nub votees)  stageCycle :: [Stage]-stageCycle = cycle [Sunset, SeersTurn, WerewolvesTurn, Sunrise, VillagesTurn]+stageCycle = cycle [Sunset, SeersTurn, WerewolvesTurn, WitchsTurn, Sunrise, VillagesTurn] -stageAvailable :: [Role] -> Stage -> Bool-stageAvailable _ GameOver                   = False-stageAvailable aliveRoles SeersTurn         = seerRole `elem` aliveRoles-stageAvailable _ Sunrise                    = True-stageAvailable _ Sunset                     = True-stageAvailable _ VillagesTurn               = True-stageAvailable aliveRoles WerewolvesTurn    = werewolfRole `elem` aliveRoles+stageAvailable :: Game -> Stage -> Bool+stageAvailable _ GameOver           = False+stageAvailable game SeersTurn       = any isSeer (filterAlive $ game ^. players)+stageAvailable _ Sunrise            = True+stageAvailable _ Sunset             = True+stageAvailable _ VillagesTurn       = True+stageAvailable game WerewolvesTurn  = any isWerewolf (filterAlive $ game ^. players)+stageAvailable game WitchsTurn      = and [+    any isWitch (filterAlive $ game ^. players),+    not (game ^. healUsed) || not (game ^. poisonUsed),+    (witch ^. name `notElem` [name | (DevourEvent name) <- game ^. events])+    ]+    where+        witch = head . filterWitches $ game ^. players++getDevourEvent :: Game -> Maybe Event+getDevourEvent game = listToMaybe [event | event@(DevourEvent _) <- game ^. events]

@@ -20,10 +20,10 @@     findByName, findByName_,      -- ** Filters-    filterScapegoats, filterSeers, filterVillagers, filterWerewolves,+    filterScapegoats, filterSeers, filterVillagers, filterWerewolves, filterWitches,      -- ** Queries-    doesPlayerExist, isScapegoat, isSeer, isVillager, isWerewolf, isAlive, isDead,+    doesPlayerExist, isScapegoat, isSeer, isVillager, isWerewolf, isWitch, isAlive, isDead,      -- * State     State(..),@@ -72,6 +72,9 @@ filterWerewolves :: [Player] -> [Player] filterWerewolves = filter isWerewolf +filterWitches :: [Player] -> [Player]+filterWitches = filter isWitch+ doesPlayerExist :: Text -> [Player] -> Bool doesPlayerExist name = isJust . findByName name @@ -86,6 +89,9 @@  isWerewolf :: Player -> Bool isWerewolf player = player ^. role == werewolfRole++isWitch :: Player -> Bool+isWitch player = player ^. role == witchRole  isAlive :: Player -> Bool isAlive player = player ^. state == Alive

@@ -34,7 +34,7 @@     newGameMessages, stageMessages, gameOverMessages, playerQuitMessage,      -- ** Ping messages-    pingPlayerMessage, pingSeerMessage, pingWerewolvesMessage,+    pingPlayerMessage, pingSeerMessage, pingWerewolvesMessage, pingWitchMessage,      -- ** Status messages     currentStageMessages, rolesInGameMessage, playersInGameMessage, waitingOnMessage,@@ -49,6 +49,9 @@     -- ** Werewolves' turn messages     playerMadeDevourVoteMessage, playerDevouredMessage, noPlayerDevouredMessage, +    -- ** Witch's turn messages+    playerHealedMessage, playerPoisonedMessage,+     -- ** Generic error messages     gameIsOverMessage, playerDoesNotExistMessage, playerCannotDoThatMessage,     playerCannotDoThatRightNowMessage, playerIsDeadMessage, roleDoesNotExistMessage,@@ -57,7 +60,10 @@     playerHasAlreadyVotedMessage, targetIsDeadMessage,      -- ** Werewolves' turn error messages-    playerCannotDevourAnotherWerewolf,+    playerCannotDevourAnotherWerewolfMessage,++    -- ** Witch's turn error messages+    playerHasAlreadyHealedMessage, playerHasAlreadyPoisonedMessage, ) where  import Control.Lens@@ -68,6 +74,7 @@ import Data.Aeson.Types #endif import           Data.List.Extra+import           Data.Maybe import           Data.Text               (Text) import qualified Data.Text               as T import qualified Data.Text.Lazy.Encoding as T@@ -75,7 +82,7 @@  import           Game.Werewolf.Game import           Game.Werewolf.Player-import           Game.Werewolf.Role   (Role, allegiance, description, _allegiance)+import           Game.Werewolf.Role   (Allegiance (..), Role, allegiance, description, _allegiance) import qualified Game.Werewolf.Role   as Role import           GHC.Generics @@ -136,10 +143,9 @@     newPlayersInGameMessage players',     rolesInGameMessage Nothing $ map _role players'     ] ++ map (newPlayerMessage players') players'-    ++ stageMessages stage' players'+    ++ stageMessages game     where-        stage'      = game ^. stage-        players'    = game ^. players+        players' = game ^. players  newPlayersInGameMessage :: [Player] -> Message newPlayersInGameMessage players = publicMessage $ T.concat [@@ -156,18 +162,20 @@             | length (filterWerewolves players) <= 1    = "."             | otherwise                                 = T.concat [", along with ", T.intercalate ", " (map _name $ filterWerewolves players \\ [player]), "."] -stageMessages :: Stage -> [Player] -> [Message]-stageMessages GameOver _                    = []-stageMessages SeersTurn alivePlayers        = seersTurnMessages . head $ filterSeers alivePlayers-stageMessages Sunrise _                     = [sunriseMessage]-stageMessages Sunset _                      = [nightFallsMessage]-stageMessages VillagesTurn _                = villagesTurnMessages-stageMessages WerewolvesTurn alivePlayers   = werewolvesTurnMessages $ filterWerewolves alivePlayers+stageMessages :: Game -> [Message]+stageMessages game = case game ^. stage of+    GameOver        -> []+    SeersTurn       -> seersTurnMessages (_name . head . filterSeers $ game ^. players)+    Sunrise         -> [sunriseMessage]+    Sunset          -> [nightFallsMessage]+    VillagesTurn    -> villagesTurnMessages+    WerewolvesTurn  -> werewolvesTurnMessages (map _name . filterAlive . filterWerewolves $ game ^. players)+    WitchsTurn      -> witchsTurnMessages game -seersTurnMessages :: Player -> [Message]-seersTurnMessages seer = [+seersTurnMessages :: Text -> [Message]+seersTurnMessages seerName = [     publicMessage "The Seer wakes up.",-    privateMessage (seer ^. name) "Whose allegiance would you like to see?"+    privateMessage seerName "Whose allegiance would you like to see?"     ]  sunriseMessage :: Message@@ -178,15 +186,35 @@  villagesTurnMessages :: [Message] villagesTurnMessages = [-    publicMessage "As the village gathers in the town square the town clerk calls for a vote.",+    publicMessage "As the village gathers in the square the town clerk calls for a vote.",     publicMessage "Whom would you like to lynch?"     ] -werewolvesTurnMessages :: [Player] -> [Message]-werewolvesTurnMessages werewolves = [+werewolvesTurnMessages :: [Text] -> [Message]+werewolvesTurnMessages werewolfNames = [     publicMessage "The Werewolves wake up, recognise one another and choose a new victim."-    ] ++ groupMessages (map _name werewolves) "Whom would you like to devour?"+    ] ++ groupMessages werewolfNames "Whom would you like to devour?" +witchsTurnMessages :: Game -> [Message]+witchsTurnMessages game = wakeUpMessage:devourMessages ++ healMessages ++ poisonMessages ++ [passMessage]+    where+        witchName       = (head . filterWitches $ game ^. players) ^. name+        wakeUpMessage   = publicMessage "The Witch wakes up."+        passMessage     = privateMessage witchName "Type `pass` to end your turn."+        devourMessages  = maybe+            []+            (\(DevourEvent targetName) ->+                [privateMessage witchName $ T.unwords ["You see", targetName, "sprawled outside bleeding uncontrollably."]]+                )+            (getDevourEvent game)+        healMessages+            | not (game ^. healUsed)+                && isJust (getDevourEvent game) = [privateMessage witchName "Would you like to heal them?"]+            | otherwise                         = []+        poisonMessages+            | not (game ^. poisonUsed)          = [privateMessage witchName "Whom would you like to poison?"]+            | otherwise                         = []+ gameOverMessages :: Game -> [Message] gameOverMessages game = case aliveAllegiances of     [allegiance]    -> concat [@@ -217,21 +245,17 @@ pingWerewolvesMessage :: Message pingWerewolvesMessage = publicMessage "Waiting on the Werewolves..." +pingWitchMessage :: Message+pingWitchMessage = publicMessage "Waiting on the Witch..."+ currentStageMessages :: Text -> Stage -> [Message] currentStageMessages to GameOver    = [gameIsOverMessage to] currentStageMessages _ Sunrise      = [] currentStageMessages _ Sunset       = []+    -- TODO (hjw): pluralise this correctly for the Seer currentStageMessages to turn        = [privateMessage to $ T.concat [-    "It's currently the ", showTurn turn, " turn."+    "It's currently the ", T.pack $ show turn, "' turn."     ]]-    where-        showTurn :: Stage -> Text-        showTurn GameOver       = undefined-        showTurn SeersTurn      = "Seer's"-        showTurn Sunrise        = undefined-        showTurn Sunset         = undefined-        showTurn VillagesTurn   = "Village's"-        showTurn WerewolvesTurn = "Werewolves'"  rolesInGameMessage :: Maybe Text -> [Role] -> Message rolesInGameMessage mTo roles = Message mTo $ T.concat [@@ -320,6 +344,22 @@     "Perhaps the Werewolves have left Miller's Hollow?"     ] +playerHealedMessage :: Text -> Message+playerHealedMessage name = publicMessage $ T.unwords [+    "As you open them you notice a door broken down and blood over the cobblestones.",+    name, "hobbles over, clutching the bandages round their stomach.",+    "The Witch must have seen their body and healed them..."+    ]++playerPoisonedMessage :: Player -> Message+playerPoisonedMessage player = publicMessage $ T.concat [+    "Upon further discovery, it looks like the Witch has struck for the side of ", side, ".",+    " ", player ^. name, " the ", player ^. role . Role.name, " is lying in their bed, poisoned,",+    " drooling over the side."+    ]+    where+        side = if player ^. role . allegiance == Villagers then "evil" else "good"+ gameIsOverMessage :: Text -> Message gameIsOverMessage to = privateMessage to "The game is over!" @@ -348,5 +388,11 @@     targetName, "is already dead!"     ] -playerCannotDevourAnotherWerewolf :: Text -> Message-playerCannotDevourAnotherWerewolf to = privateMessage to "You cannot devour another Werewolf!"+playerCannotDevourAnotherWerewolfMessage :: Text -> Message+playerCannotDevourAnotherWerewolfMessage to = privateMessage to "You cannot devour another Werewolf!"++playerHasAlreadyHealedMessage :: Text -> Message+playerHasAlreadyHealedMessage to = privateMessage to "You've already healed someone!"++playerHasAlreadyPoisonedMessage :: Text -> Message+playerHasAlreadyPoisonedMessage to = privateMessage to "You've already poisoned someone!"

@@ -18,6 +18,7 @@      -- ** Instances     allRoles, diurnalRoles, nocturnalRoles, scapegoatRole, seerRole, villagerRole, werewolfRole,+    witchRole,      -- ** Queries     findByName,@@ -43,10 +44,10 @@     } deriving (Eq, Read, Show)  allRoles :: [Role]-allRoles = [seerRole, villagerRole, werewolfRole, scapegoatRole]+allRoles = [scapegoatRole, seerRole, villagerRole, werewolfRole, witchRole]  diurnalRoles :: [Role]-diurnalRoles = [villagerRole, scapegoatRole]+diurnalRoles = [scapegoatRole, villagerRole, witchRole]  nocturnalRoles :: [Role] nocturnalRoles = allRoles \\ diurnalRoles@@ -90,6 +91,22 @@     , _description  = "A shapeshifting townsperson that, at night, hunts the residents of Millers Hollow."     , _advice       =         "Voting against your partner can be a good way to deflect suspicion from yourself."+    }++witchRole :: Role+witchRole = Role+    { _name         = "Witch"+    , _allegiance   = Villagers+    , _description  = T.unwords+        [ "A conniving townsperson."+        , "She knows how to make up 2 extremely powerful potions;"+        , "one healing potion which can revive the Werewolves' victim,"+        , "one poison potion which when used at night can kill a player."+        ]+    , _advice       = T.unwords+        [ "Each potion may be used once per game,"+        , "but there are no restrictions on how many you may use at night."+        ]     }  findByName :: Text -> Maybe Role

@@ -28,95 +28,143 @@  allCommandTests :: [TestTree] allCommandTests = [-    testProperty "PROP: devour vote command errors when game is over" prop_devourVoteCommandErrorsWhenGameIsOver,-    testProperty "PROP: devour vote command errors when caller does not exist" prop_devourVoteCommandErrorsWhenCallerDoesNotExist,-    testProperty "PROP: devour vote command errors when target does not exist" prop_devourVoteCommandErrorsWhenTargetDoesNotExist,-    testProperty "PROP: devour vote command errors when caller is dead" prop_devourVoteCommandErrorsWhenCallerIsDead,-    testProperty "PROP: devour vote command errors when target is dead" prop_devourVoteCommandErrorsWhenTargetIsDead,-    testProperty "PROP: devour vote command errors when not werewolves turn" prop_devourVoteCommandErrorsWhenNotWerewolvesTurn,-    testProperty "PROP: devour vote command errors when caller not werewolf" prop_devourVoteCommandErrorsWhenCallerNotWerewolf,-    testProperty "PROP: devour vote command errors when caller has voted" prop_devourVoteCommandErrorsWhenCallerHasVoted,-    testProperty "PROP: devour vote command errors when target werewolf" prop_devourVoteCommandErrorsWhenTargetWerewolf,-    testProperty "PROP: devour vote command updates votes" prop_devourVoteCommandUpdatesVotes,+    testProperty "devour vote command errors when game is over" prop_devourVoteCommandErrorsWhenGameIsOver,+    testProperty "devour vote command errors when caller does not exist" prop_devourVoteCommandErrorsWhenCallerDoesNotExist,+    testProperty "devour vote command errors when target does not exist" prop_devourVoteCommandErrorsWhenTargetDoesNotExist,+    testProperty "devour vote command errors when caller is dead" prop_devourVoteCommandErrorsWhenCallerIsDead,+    testProperty "devour vote command errors when target is dead" prop_devourVoteCommandErrorsWhenTargetIsDead,+    testProperty "devour vote command errors when not werewolves turn" prop_devourVoteCommandErrorsWhenNotWerewolvesTurn,+    testProperty "devour vote command errors when caller not werewolf" prop_devourVoteCommandErrorsWhenCallerNotWerewolf,+    testProperty "devour vote command errors when caller has voted" prop_devourVoteCommandErrorsWhenCallerHasVoted,+    testProperty "devour vote command errors when target werewolf" prop_devourVoteCommandErrorsWhenTargetWerewolf,+    testProperty "devour vote command updates votes" prop_devourVoteCommandUpdatesVotes, -    testProperty "PROP: lynch vote command errors when game is over" prop_lynchVoteCommandErrorsWhenGameIsOver,-    testProperty "PROP: lynch vote command errors when caller does not exist" prop_lynchVoteCommandErrorsWhenCallerDoesNotExist,-    testProperty "PROP: lynch vote command errors when target does not exist" prop_lynchVoteCommandErrorsWhenTargetDoesNotExist,-    testProperty "PROP: lynch vote command errors when caller is dead" prop_lynchVoteCommandErrorsWhenCallerIsDead,-    testProperty "PROP: lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead,-    testProperty "PROP: lynch vote command errors when not villages turn" prop_lynchVoteCommandErrorsWhenNotVillagesTurn,-    testProperty "PROP: lynch vote command errors when caller has voted" prop_lynchVoteCommandErrorsWhenCallerHasVoted,-    testProperty "PROP: lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes,+    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 "PROP: quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver,-    testProperty "PROP: quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist,-    testProperty "PROP: quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead,-    testProperty "PROP: quit command kills player" prop_quitCommandKillsPlayer,-    testProperty "PROP: quit command clears players devour vote" prop_quitCommandClearsPlayersDevourVote,-    testProperty "PROP: quit command clears players lynch vote" prop_quitCommandClearsPlayersLynchVote,-    testProperty "PROP: quit command clears players see" prop_quitCommandClearsPlayersSee,+    testProperty "lynch vote command errors when game is over" prop_lynchVoteCommandErrorsWhenGameIsOver,+    testProperty "lynch vote command errors when caller does not exist" prop_lynchVoteCommandErrorsWhenCallerDoesNotExist,+    testProperty "lynch vote command errors when target does not exist" prop_lynchVoteCommandErrorsWhenTargetDoesNotExist,+    testProperty "lynch vote command errors when caller is dead" prop_lynchVoteCommandErrorsWhenCallerIsDead,+    testProperty "lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead,+    testProperty "lynch vote command errors when not villages turn" prop_lynchVoteCommandErrorsWhenNotVillagesTurn,+    testProperty "lynch vote command errors when caller has voted" prop_lynchVoteCommandErrorsWhenCallerHasVoted,+    testProperty "lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes, -    testProperty "PROP: see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver,-    testProperty "PROP: see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist,-    testProperty "PROP: see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist,-    testProperty "PROP: see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead,-    testProperty "PROP: see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead,-    testProperty "PROP: see command errors when not seers turn" prop_seeCommandErrorsWhenNotSeersTurn,-    testProperty "PROP: see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer,-    testProperty "PROP: see command sets see" prop_seeCommandSetsSee+    testProperty "pass command errors when game is over" prop_passCommandErrorsWhenGameIsOver,+    testProperty "pass command errors when caller does not exist" prop_passCommandErrorsWhenCallerDoesNotExist,+    testProperty "pass command errors when caller is dead" prop_passCommandErrorsWhenCallerIsDead,+    testProperty "pass command errors when not witch's turn" prop_passCommandErrorsWhenNotWitchsTurn,+    testProperty "pass command updates passes" prop_passCommandUpdatesPasses,++    testProperty "poison command errors when game is over" prop_poisonCommandErrorsWhenGameIsOver,+    testProperty "poison command errors when caller does not exist" prop_poisonCommandErrorsWhenCallerDoesNotExist,+    testProperty "poison command errors when target does not exist" prop_poisonCommandErrorsWhenTargetDoesNotExist,+    testProperty "poison command errors when caller is dead" prop_poisonCommandErrorsWhenCallerIsDead,+    testProperty "poison command errors when target is dead" prop_poisonCommandErrorsWhenTargetIsDead,+    testProperty "poison command errors when target is devoured" prop_poisonCommandErrorsWhenTargetIsDevoured,+    testProperty "poison command errors when not witch's turn" prop_poisonCommandErrorsWhenNotWitchsTurn,+    testProperty "poison command errors when caller has poisoned" prop_poisonCommandErrorsWhenCallerHasPoisoned,+    testProperty "poison command errors when caller not witch" prop_poisonCommandErrorsWhenCallerNotWitch,+    testProperty "poison command sets poison" prop_poisonCommandSetsPoison,+    testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed,++    testProperty "quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver,+    testProperty "quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist,+    testProperty "quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead,+    testProperty "quit command kills player" prop_quitCommandKillsPlayer,+    testProperty "quit command clears heal when caller is witch" prop_quitCommandClearsHealWhenCallerIsWitch,+    testProperty "quit command clears heal used when caller is witch" prop_quitCommandClearsHealUsedWhenCallerIsWitch,+    testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonWhenCallerIsWitch,+    testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonUsedWhenCallerIsWitch,+    testProperty "quit command clears player's devour vote" prop_quitCommandClearsPlayersDevourVote,+    testProperty "quit command clears player's lynch vote" prop_quitCommandClearsPlayersLynchVote,++    testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver,+    testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist,+    testProperty "see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist,+    testProperty "see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead,+    testProperty "see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead,+    testProperty "see command errors when not seer's turn" prop_seeCommandErrorsWhenNotSeersTurn,+    testProperty "see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer,+    testProperty "see command sets see" prop_seeCommandSetsSee     ]  allEngineTests :: [TestTree] allEngineTests = [-    testProperty "PROP: check stage skips seers when no seers" prop_checkStageSkipsSeersWhenNoSeers,-    testProperty "PROP: check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver,+    testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer,+    testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch,+    testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver, -    testProperty "PROP: check seers turn advances to werewolves" prop_checkSeersTurnAdvancesToWerewolves,-    testProperty "PROP: check seers turn resets sees" prop_checkSeersTurnResetsSee,-    testProperty "PROP: check seers turn does nothing unless all seen" prop_checkSeersTurnDoesNothingUnlessAllSeen,+    testProperty "check seer's turn advances to werewolves' turn" prop_checkSeersTurnAdvancesToWerewolvesTurn,+    testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee,+    testProperty "check seer's turn does nothing unless seen" prop_checkSeersTurnDoesNothingUnlessSeen, -    testProperty "PROP: check villages turn advances to seers" prop_checkVillagesTurnAdvancesToSeers,-    testProperty "PROP: check villages turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus,-    testProperty "PROP: check villages turn lynches no one when conflicted and no scapegoats" prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats,-    testProperty "PROP: check villages turn lynches scapegoat when conflicted" prop_checkVillagesTurnLynchesScapegoatWhenConflicted,-    testProperty "PROP: check villages turn resets votes" prop_checkVillagesTurnResetsVotes,-    testProperty "PROP: check villages turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted,+    testProperty "check villages' turn advances to seer's turn" prop_checkVillagesTurnAdvancesToSeersTurn,+    testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus,+    testProperty "check villages' turn lynches no one when conflicted and no scapegoats" prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats,+    testProperty "check villages' turn lynches scapegoat when conflicted" prop_checkVillagesTurnLynchesScapegoatWhenConflicted,+    testProperty "check villages' turn resets votes" prop_checkVillagesTurnResetsVotes,+    testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted, -    testProperty "PROP: check werewolves turn advances to villages" prop_checkWerewolvesTurnAdvancesToVillages,-    testProperty "PROP: check werewolves turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus,-    testProperty "PROP: check werewolves turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted,-    testProperty "PROP: check werewolves turn resets votes" prop_checkWerewolvesTurnResetsVotes,-    testProperty "PROP: check werewolves turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted,+    testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn,+    testProperty "check werewolves' turn skips witch's turn when witch devoured" prop_checkWerewolvesTurnSkipsWitchsTurnWhenWitchDevoured,+    testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned,+    testProperty "check werewolves' turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus,+    testProperty "check werewolves' turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted,+    testProperty "check werewolves' turn resets votes" prop_checkWerewolvesTurnResetsVotes,+    testProperty "check werewolves' turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, -    testProperty "PROP: check game over advances stage" prop_checkGameOverAdvancesStage,-    testProperty "PROP: check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive,+    testProperty "check witch's turn advances to villages' turn" prop_checkWitchsTurnAdvancesToVillagesTurn,+    testProperty "check witch's turn heals devouree when healed" prop_checkWitchsTurnHealsDevoureeWhenHealed,+    testProperty "check witch's turn kills one player when poisoned" prop_checkWitchsTurnKillsOnePlayerWhenPoisoned,+    testProperty "check witch's turn does nothing when passed" prop_checkWitchsTurnDoesNothingWhenPassed,+    testProperty "check witch's turn resets heal" prop_checkWitchsTurnResetsHeal,+    testProperty "check witch's turn resets poison" prop_checkWitchsTurnResetsPoison, -    testProperty "PROP: start game starts with sunset stage" prop_startGameStartsWithSunsetStage,-    testProperty "PROP: start game uses given players" prop_startGameUsesGivenPlayers,-    testProperty "PROP: start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames,-    testProperty "PROP: start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players,-    testProperty "PROP: start game errors when more than 24 players" prop_startGameErrorsWhenMoreThan24Players,-    testProperty "PROP: start game errors when more than 1 seer" prop_startGameErrorsWhenMoreThan1Seer,-    testProperty "PROP: start game errors when more than 1 scapegoat" prop_startGameErrorsWhenMoreThan1Scapegoat,+    testProperty "check game over advances stage" prop_checkGameOverAdvancesStage,+    testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive, -    testProperty "PROP: create players uses given player names" prop_createPlayersUsesGivenPlayerNames,-    testProperty "PROP: create players uses given roles" prop_createPlayersUsesGivenRoles,-    testProperty "PROP: create players creates alive players" prop_createPlayersCreatesAlivePlayers,+    testProperty "start game starts with sunset stage" prop_startGameStartsWithSunsetStage,+    testProperty "start game uses given players" prop_startGameUsesGivenPlayers,+    testProperty "start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames,+    testProperty "start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players,+    testProperty "start game errors when more than 24 players" prop_startGameErrorsWhenMoreThan24Players,+    testProperty "start game errors when more than 1 scapegoat" prop_startGameErrorsWhenMoreThan1Scapegoat,+    testProperty "start game errors when more than 1 seer" prop_startGameErrorsWhenMoreThan1Seer,+    testProperty "start game errors when more than 1 witch" prop_startGameErrorsWhenMoreThan1Witch, -    testProperty "PROP: randomise roles returns n roles" prop_randomiseRolesReturnsNRoles,-    testProperty "PROP: randomise roles uses given roles" prop_randomiseRolesUsesGivenRoles,-    testProperty "PROP: randomise roles proportions allegiances" prop_randomiseRolesProportionsAllegiances+    testProperty "create players uses given player names" prop_createPlayersUsesGivenPlayerNames,+    testProperty "create players uses given roles" prop_createPlayersUsesGivenRoles,+    testProperty "create players creates alive players" prop_createPlayersCreatesAlivePlayers,++    testProperty "randomise roles returns n roles" prop_randomiseRolesReturnsNRoles,+    testProperty "randomise roles uses given roles" prop_randomiseRolesUsesGivenRoles,+    testProperty "randomise roles proportions allegiances" prop_randomiseRolesProportionsAllegiances     ]  allGameTests :: [TestTree] allGameTests = [-    testProperty "PROP: new game starts with sunset stage" prop_newGameStartsWithSunsetStage,-    testProperty "PROP: new game starts with no see" prop_newGameStartsWithNoSee,-    testProperty "PROP: new game starts with votes empty" prop_newGameStartsWithVotesEmpty,-    testProperty "PROP: new game uses given players" prop_newGameUsesGivenPlayers+    testProperty "new game starts with sunset stage" prop_newGameStartsWithSunsetStage,+    testProperty "new game starts with events empty" prop_newGameStartsWithEventsEmpty,+    testProperty "new game starts with passes empty" prop_newGameStartsWithPassesEmpty,+    testProperty "new game starts with no heal" prop_newGameStartsWithNoHeal,+    testProperty "new game starts with no heal used" prop_newGameStartsWithNoHealUsed,+    testProperty "new game starts with no poison" prop_newGameStartsWithNoPoison,+    testProperty "new game starts with no poison used" prop_newGameStartsWithNoPoisonUsed,+    testProperty "new game starts with no see" prop_newGameStartsWithNoSee,+    testProperty "new game starts with votes empty" prop_newGameStartsWithVotesEmpty,+    testProperty "new game uses given players" prop_newGameUsesGivenPlayers     ]  allPlayerTests :: [TestTree] allPlayerTests = [-    testProperty "PROP: new player is alive" prop_newPlayerIsAlive+    testProperty "new player is alive" prop_newPlayerIsAlive     ]

@@ -10,9 +10,10 @@  module Game.Werewolf.Test.Arbitrary (     -- * Contextual arbitraries-    arbitraryCommand, arbitraryDevourVoteCommand, arbitraryLynchVoteCommand, arbitraryQuitCommand,-    arbitrarySeeCommand, arbitraryNewGame, arbitraryPlayer, arbitraryPlayerSet, arbitraryScapegoat,-    arbitrarySeer, arbitraryVillager, arbitraryWerewolf,+    arbitraryCommand, arbitraryDevourVoteCommand, arbitraryHealCommand, arbitraryLynchVoteCommand,+    arbitraryPassCommand, arbitraryPoisonCommand, arbitraryQuitCommand, arbitrarySeeCommand,+    arbitraryNewGame, arbitraryPlayer, arbitraryPlayerSet, arbitraryScapegoat, arbitrarySeer,+    arbitraryVillager, arbitraryWerewolf, arbitraryWitch,      -- * Utility functions     run, run_, runArbitraryCommands,@@ -48,6 +49,11 @@     SeersTurn       -> arbitrarySeeCommand game     VillagesTurn    -> arbitraryLynchVoteCommand game     WerewolvesTurn  -> arbitraryDevourVoteCommand game+    WitchsTurn      -> oneof [+        arbitraryHealCommand game,+        arbitraryPassCommand game,+        arbitraryPoisonCommand game+        ]  arbitraryDevourVoteCommand :: Game -> Gen Command arbitraryDevourVoteCommand game = do@@ -67,6 +73,29 @@         then return noopCommand         else elements applicableCallers >>= \caller -> return $ lynchVoteCommand (caller ^. name) (target ^. name) +arbitraryHealCommand :: Game -> Gen Command+arbitraryHealCommand game = do+    let witchName = (head . filterWitches $ game ^. players) ^. name++    return $ if game ^. healUsed+        then noopCommand+        else seq (fromJust (getDevourEvent game)) $ healCommand witchName++arbitraryPassCommand :: Game -> Gen Command+arbitraryPassCommand game = do+    witch <- arbitraryWitch game++    return $ passCommand (witch ^. name)++arbitraryPoisonCommand :: Game -> Gen Command+arbitraryPoisonCommand game = do+    let witch   = head . filterWitches $ game ^. players+    target      <- arbitraryPlayer game++    return $ if isJust (game ^. poison)+        then noopCommand+        else poisonCommand (witch ^. name) (target ^. name)+ arbitraryQuitCommand :: Game -> Gen Command arbitraryQuitCommand game = do     let applicableCallers = filterAlive $ game ^. players@@ -80,9 +109,9 @@     let seer    = head . filterSeers $ game ^. players     target      <- arbitraryPlayer game -    if isJust (game ^. see)-        then return noopCommand-        else return $ seeCommand (seer ^. name) (target ^. name)+    return $ if isJust (game ^. see)+        then noopCommand+        else seeCommand (seer ^. name) (target ^. name)  instance Arbitrary Game where     arbitrary = do@@ -95,7 +124,7 @@ arbitraryNewGame = newGame <$> arbitraryPlayerSet  instance Arbitrary Stage where-    arbitrary = elements [GameOver, SeersTurn, VillagesTurn, WerewolvesTurn]+    arbitrary = elements [GameOver, SeersTurn, VillagesTurn, WerewolvesTurn, WitchsTurn]  instance Arbitrary Player where     arbitrary = newPlayer <$> arbitrary <*> arbitrary@@ -108,13 +137,18 @@     n <- choose (7, 24)     players <- nubOn _name <$> infiniteList +    let scapegoat   = head $ filterScapegoats players     let seer        = head $ filterSeers players+    let witch       = head $ filterWitches players+     let werewolves  = take (n `quot` 6 + 1) $ filterWerewolves players-    let villagers   = take (n - 2 - (length werewolves)) $ filterVillagers players-    let scapegoat   = head $ filterScapegoats players+    let villagers   = take (n - 3 - (length werewolves)) $ filterVillagers players -    return $ seer:scapegoat:werewolves ++ villagers+    return $ scapegoat:seer:witch:werewolves ++ villagers +arbitraryScapegoat :: Game -> Gen Player+arbitraryScapegoat = elements . filterAlive . filterScapegoats . _players+ arbitrarySeer :: Game -> Gen Player arbitrarySeer = elements . filterAlive . filterSeers . _players @@ -124,8 +158,8 @@ arbitraryWerewolf :: Game -> Gen Player arbitraryWerewolf = elements . filterAlive . filterWerewolves . _players -arbitraryScapegoat :: Game -> Gen Player-arbitraryScapegoat = elements . filterAlive . filterScapegoats . _players+arbitraryWitch :: Game -> Gen Player+arbitraryWitch = elements . filterAlive . filterWitches . _players  instance Arbitrary State where     arbitrary = elements [Alive, Dead]

@@ -17,17 +17,39 @@     prop_devourVoteCommandErrorsWhenCallerHasVoted, prop_devourVoteCommandErrorsWhenTargetWerewolf,     prop_devourVoteCommandUpdatesVotes, +    -- * healCommand+    prop_healCommandErrorsWhenGameIsOver, prop_healCommandErrorsWhenCallerDoesNotExist,+    prop_healCommandErrorsWhenCallerIsDead, prop_healCommandErrorsWhenNoTargetIsDevoured,+    prop_healCommandErrorsWhenNotWitchsTurn, prop_healCommandErrorsWhenCallerHasHealed,+    prop_healCommandErrorsWhenCallerNotWitch, prop_healCommandSetsHeal,+    prop_healCommandSetsHealUsed,+     -- * lynchVoteCommand     prop_lynchVoteCommandErrorsWhenGameIsOver, prop_lynchVoteCommandErrorsWhenCallerDoesNotExist,     prop_lynchVoteCommandErrorsWhenTargetDoesNotExist, prop_lynchVoteCommandErrorsWhenCallerIsDead,     prop_lynchVoteCommandErrorsWhenTargetIsDead, prop_lynchVoteCommandErrorsWhenNotVillagesTurn,     prop_lynchVoteCommandErrorsWhenCallerHasVoted, prop_lynchVoteCommandUpdatesVotes, +    -- * passCommand+    prop_passCommandErrorsWhenGameIsOver, prop_passCommandErrorsWhenCallerDoesNotExist,+    prop_passCommandErrorsWhenCallerIsDead, prop_passCommandErrorsWhenNotWitchsTurn,+    prop_passCommandUpdatesPasses,++    -- * poisonCommand+    prop_poisonCommandErrorsWhenGameIsOver, prop_poisonCommandErrorsWhenCallerDoesNotExist,+    prop_poisonCommandErrorsWhenTargetDoesNotExist, prop_poisonCommandErrorsWhenCallerIsDead,+    prop_poisonCommandErrorsWhenTargetIsDead, prop_poisonCommandErrorsWhenTargetIsDevoured,+    prop_poisonCommandErrorsWhenNotWitchsTurn, prop_poisonCommandErrorsWhenCallerHasPoisoned,+    prop_poisonCommandErrorsWhenCallerNotWitch, prop_poisonCommandSetsPoison,+    prop_poisonCommandSetsPoisonUsed,+     -- * quitCommand     prop_quitCommandErrorsWhenGameIsOver, prop_quitCommandErrorsWhenCallerDoesNotExist,     prop_quitCommandErrorsWhenCallerIsDead, prop_quitCommandKillsPlayer,-    prop_quitCommandClearsPlayersDevourVote, prop_quitCommandClearsPlayersLynchVote,-    prop_quitCommandClearsPlayersSee,+    prop_quitCommandClearsHealWhenCallerIsWitch, prop_quitCommandClearsHealUsedWhenCallerIsWitch,+    prop_quitCommandClearsPoisonWhenCallerIsWitch,+    prop_quitCommandClearsPoisonUsedWhenCallerIsWitch, prop_quitCommandClearsPlayersDevourVote,+    prop_quitCommandClearsPlayersLynchVote,      -- * seeCommand     prop_seeCommandErrorsWhenGameIsOver, prop_seeCommandErrorsWhenCallerDoesNotExist,@@ -38,11 +60,12 @@  import Control.Lens hiding (elements) -import Data.Either.Extra-import Data.Map          as Map-import Data.Maybe+import           Data.Either.Extra+import qualified Data.Map          as Map+import           Data.Maybe  import Game.Werewolf.Command+import Game.Werewolf.Engine         (checkStage) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Test.Arbitrary@@ -51,8 +74,9 @@  prop_devourVoteCommandErrorsWhenGameIsOver :: Game -> Property prop_devourVoteCommandErrorsWhenGameIsOver game =-    isGameOver game-    ==> forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game+    forAll (arbitraryDevourVoteCommand game') $ verbose_runCommandErrors game'+    where+        game' = game { _stage = GameOver }  prop_devourVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_devourVoteCommandErrorsWhenCallerDoesNotExist game caller =@@ -85,35 +109,109 @@  prop_devourVoteCommandErrorsWhenCallerNotWerewolf :: Game -> Property prop_devourVoteCommandErrorsWhenCallerNotWerewolf game =-    forAll (arbitraryPlayer game) $ \caller -> not (isWerewolf caller)-    ==> forAll (arbitraryPlayer game) $ \target ->-        verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))+    forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \caller ->+    forAll (arbitraryPlayer game) $ \target ->+    verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))  prop_devourVoteCommandErrorsWhenCallerHasVoted :: Game -> Property prop_devourVoteCommandErrorsWhenCallerHasVoted game =-    isWerewolvesTurn game ==>-    forAll (arbitraryWerewolf game) $ \caller ->-    forAll (arbitraryPlayer game) $ \target ->-    not (isWerewolf target)-    ==> let command = devourVoteCommand (caller ^. name) (target ^. name)-        in verbose_runCommandErrors (run_ (apply command) game) command+    forAll (arbitraryWerewolf game') $ \caller ->+    forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target ->+    let command = devourVoteCommand (caller ^. name) (target ^. name)+    in verbose_runCommandErrors (run_ (apply command) game') command+    where+        game' = game { _stage = WerewolvesTurn }  prop_devourVoteCommandErrorsWhenTargetWerewolf :: Game -> Property prop_devourVoteCommandErrorsWhenTargetWerewolf game =-    forAll (arbitraryPlayer game) $ \target -> isWerewolf target-    ==> forAll (arbitraryPlayer game) $ \caller ->-        verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))+    forAll (suchThat (arbitraryPlayer game) isWerewolf) $ \target ->+    forAll (arbitraryPlayer game) $ \caller ->+    verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))  prop_devourVoteCommandUpdatesVotes :: Game -> Property prop_devourVoteCommandUpdatesVotes game =-    isWerewolvesTurn game-    ==> forAll (arbitraryDevourVoteCommand game) $ \command ->-        Map.size (run_ (apply command) game ^. votes) == 1+    forAll (arbitraryDevourVoteCommand game') $ \command ->+    Map.size (run_ (apply command) game' ^. votes) == 1+    where+        game' = game { _stage = WerewolvesTurn } +prop_healCommandErrorsWhenGameIsOver :: Game -> Property+prop_healCommandErrorsWhenGameIsOver game =+    forAll (arbitraryWitch game') $ \witch ->+    verbose_runCommandErrors game' (healCommand $ witch ^. name)+    where+        game' = game { _stage = GameOver }++prop_healCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property+prop_healCommandErrorsWhenCallerDoesNotExist game caller =+    not (doesPlayerExist (caller ^. name) (game ^. players))+    ==> verbose_runCommandErrors game (healCommand (caller ^. name))++prop_healCommandErrorsWhenCallerIsDead :: Game -> Property+prop_healCommandErrorsWhenCallerIsDead game =+    forAll (arbitraryPlayer game) $ \caller ->+    verbose_runCommandErrors (killPlayer game caller) (healCommand (caller ^. name))++prop_healCommandErrorsWhenNoTargetIsDevoured :: Game -> Property+prop_healCommandErrorsWhenNoTargetIsDevoured game =+    forAll (arbitraryWitch game) $ \witch ->+    verbose_runCommandErrors game (healCommand $ witch ^. name)++prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property+prop_healCommandErrorsWhenNotWitchsTurn game =+    not (isWitchsTurn game)+    ==> forAll (arbitraryWitch game) $ \witch ->+        verbose_runCommandErrors game (healCommand $ witch ^. name)++prop_healCommandErrorsWhenCallerHasHealed :: Game -> Property+prop_healCommandErrorsWhenCallerHasHealed game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> let game''' = run_ checkStage game''+            in  forAll (arbitraryHealCommand game''') $ \command ->+                run_ (apply command) game''' ^. heal+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players++prop_healCommandErrorsWhenCallerNotWitch :: Game -> Property+prop_healCommandErrorsWhenCallerNotWitch game =+    forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller ->+    verbose_runCommandErrors game (healCommand (caller ^. name))++prop_healCommandSetsHeal :: Game -> Property+prop_healCommandSetsHeal game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> let game''' = run_ checkStage game''+            in  forAll (arbitraryHealCommand game''') $ \command ->+                run_ (apply command) game''' ^. heal+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players++prop_healCommandSetsHealUsed :: Game -> Property+prop_healCommandSetsHealUsed game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> let game''' = run_ checkStage game''+            in  forAll (arbitraryHealCommand game''') $ \command ->+                run_ (apply command) game''' ^. heal+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players+ prop_lynchVoteCommandErrorsWhenGameIsOver :: Game -> Property prop_lynchVoteCommandErrorsWhenGameIsOver game =-    isGameOver game-    ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game+    forAll (arbitraryLynchVoteCommand game') $ verbose_runCommandErrors game'+    where+        game' = game { _stage = GameOver }  prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_lynchVoteCommandErrorsWhenCallerDoesNotExist game caller =@@ -146,22 +244,129 @@  prop_lynchVoteCommandErrorsWhenCallerHasVoted :: Game -> Property prop_lynchVoteCommandErrorsWhenCallerHasVoted game =-    isVillagesTurn game ==>-    forAll (arbitraryPlayer game) $ \caller ->-    forAll (arbitraryPlayer game) $ \target ->+    forAll (arbitraryPlayer game') $ \caller ->+    forAll (arbitraryPlayer game') $ \target ->     let command = lynchVoteCommand (caller ^. name) (target ^. name)-        in verbose_runCommandErrors (run_ (apply command) game) command+    in verbose_runCommandErrors (run_ (apply command) game') command+    where+        game' = game { _stage = VillagesTurn }  prop_lynchVoteCommandUpdatesVotes :: Game -> Property prop_lynchVoteCommandUpdatesVotes game =-    isVillagesTurn game ==>-    forAll (arbitraryLynchVoteCommand game) $ \command ->-    Map.size (run_ (apply command) game ^. votes) == 1+    forAll (arbitraryLynchVoteCommand game') $ \command ->+    Map.size (run_ (apply command) game' ^. votes) == 1+    where+        game' = game { _stage = VillagesTurn } +prop_passCommandErrorsWhenGameIsOver :: Game -> Property+prop_passCommandErrorsWhenGameIsOver game =+    forAll (arbitraryPassCommand game') $ verbose_runCommandErrors game'+    where+        game' = game { _stage = GameOver }++prop_passCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property+prop_passCommandErrorsWhenCallerDoesNotExist game caller =+    not (doesPlayerExist (caller ^. name) (game ^. players))+    ==> verbose_runCommandErrors game (passCommand (caller ^. name))++prop_passCommandErrorsWhenCallerIsDead :: Game -> Property+prop_passCommandErrorsWhenCallerIsDead game =+    forAll (arbitraryPlayer game) $ \caller ->+    verbose_runCommandErrors (killPlayer game caller) (passCommand (caller ^. name))++prop_passCommandErrorsWhenNotWitchsTurn :: Game -> Property+prop_passCommandErrorsWhenNotWitchsTurn game =+    not (isWitchsTurn game)+    ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game++prop_passCommandUpdatesPasses :: Game -> Property+prop_passCommandUpdatesPasses game =+    forAll (arbitraryPassCommand game') $ \command ->+    length (run_ (apply command) game' ^. passes) == 1+    where+        game' = game { _stage = WitchsTurn }++prop_poisonCommandErrorsWhenGameIsOver :: Game -> Property+prop_poisonCommandErrorsWhenGameIsOver game =+    forAll (arbitraryPoisonCommand game') $ verbose_runCommandErrors game'+    where+        game' = game { _stage = GameOver }++prop_poisonCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property+prop_poisonCommandErrorsWhenCallerDoesNotExist game caller =+    not (doesPlayerExist (caller ^. name) (game ^. players))+    ==> forAll (arbitraryPlayer game) $ \target ->+        verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name))++prop_poisonCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property+prop_poisonCommandErrorsWhenTargetDoesNotExist game target =+    not (doesPlayerExist (target ^. name) (game ^. players))+    ==> forAll (arbitraryPlayer game) $ \caller ->+        verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name))++prop_poisonCommandErrorsWhenCallerIsDead :: Game -> Property+prop_poisonCommandErrorsWhenCallerIsDead game =+    forAll (arbitraryPlayer game) $ \caller ->+    forAll (arbitraryPlayer game) $ \target ->+    verbose_runCommandErrors (killPlayer game caller) (poisonCommand (caller ^. name) (target ^. name))++prop_poisonCommandErrorsWhenTargetIsDead :: Game -> Property+prop_poisonCommandErrorsWhenTargetIsDead game =+    forAll (arbitraryPlayer game) $ \caller ->+    forAll (arbitraryPlayer game) $ \target ->+    verbose_runCommandErrors (killPlayer game target) (poisonCommand (caller ^. name) (target ^. name))++prop_poisonCommandErrorsWhenTargetIsDevoured :: Game -> Property+prop_poisonCommandErrorsWhenTargetIsDevoured game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> forAll (arbitraryWitch game'') $ \caller ->+        let game''' = run_ checkStage game''+            votee   = head (getVoteResult game'')+        in verbose_runCommandErrors game''' (poisonCommand (caller ^. name) (votee ^. name))+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players++prop_poisonCommandErrorsWhenNotWitchsTurn :: Game -> Property+prop_poisonCommandErrorsWhenNotWitchsTurn game =+    not (isWitchsTurn game)+    ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game++prop_poisonCommandErrorsWhenCallerHasPoisoned :: Game -> Property+prop_poisonCommandErrorsWhenCallerHasPoisoned game =+    forAll (arbitraryWitch game') $ \caller ->+    forAll (arbitraryPlayer game') $ \target ->+    let command = poisonCommand (caller ^. name) (target ^. name)+    in verbose_runCommandErrors (run_ (apply command) game') command+    where+        game' = game { _stage = WitchsTurn }++prop_poisonCommandErrorsWhenCallerNotWitch :: Game -> Property+prop_poisonCommandErrorsWhenCallerNotWitch game =+    forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller ->+    forAll (arbitraryPlayer game) $ \target ->+    verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name))++prop_poisonCommandSetsPoison :: Game -> Property+prop_poisonCommandSetsPoison game =+    forAll (arbitraryPoisonCommand game') $ \command ->+    isJust (run_ (apply command) game' ^. poison)+    where+        game' = game { _stage = WitchsTurn }++prop_poisonCommandSetsPoisonUsed :: Game -> Property+prop_poisonCommandSetsPoisonUsed game =+    forAll (arbitraryPoisonCommand game') $ \command ->+    run_ (apply command) game' ^. poisonUsed+    where+        game' = game { _stage = WitchsTurn }+ prop_quitCommandErrorsWhenGameIsOver :: Game -> Property prop_quitCommandErrorsWhenGameIsOver game =-    isGameOver game-    ==> forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game+    forAll (arbitraryQuitCommand game') $ verbose_runCommandErrors game'+    where+        game' = game { _stage = GameOver }  prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_quitCommandErrorsWhenCallerDoesNotExist game caller =@@ -179,38 +384,75 @@     ==> forAll (arbitraryQuitCommand game) $ \command ->         length (filterDead $ run_ (apply command) game ^. players) == 1 +prop_quitCommandClearsHealWhenCallerIsWitch :: Game -> Property+prop_quitCommandClearsHealWhenCallerIsWitch game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> forAll (arbitraryWitch game'') $ \caller ->+            let command = healCommand (caller ^. name)+                game''' = run_ (apply command) $ run_ checkStage game''+            in not $ run_ (apply $ quitCommand (caller ^. name)) game''' ^. heal+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players++prop_quitCommandClearsHealUsedWhenCallerIsWitch :: Game -> Property+prop_quitCommandClearsHealUsedWhenCallerIsWitch game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> forAll (arbitraryWitch game'') $ \caller ->+            let command = healCommand (caller ^. name)+                game''' = run_ (apply command) $ run_ checkStage game''+            in not $ run_ (apply $ quitCommand (caller ^. name)) game''' ^. healUsed+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players++prop_quitCommandClearsPoisonWhenCallerIsWitch :: Game -> Property+prop_quitCommandClearsPoisonWhenCallerIsWitch game =+    forAll (arbitraryWitch game') $ \caller ->+    forAll (arbitraryPlayer game') $ \target ->+    let game'' = run_ (apply $ poisonCommand (caller ^. name) (target ^. name)) game'+    in isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. poison+    where+        game' = game { _stage = WitchsTurn }++prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: Game -> Property+prop_quitCommandClearsPoisonUsedWhenCallerIsWitch game =+    forAll (arbitraryWitch game') $ \caller ->+    forAll (arbitraryPlayer game') $ \target ->+    let game'' = run_ (apply $ poisonCommand (caller ^. name) (target ^. name)) game'+    in not $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. poisonUsed+    where+        game' = game { _stage = WitchsTurn }+ prop_quitCommandClearsPlayersDevourVote :: Game -> Property prop_quitCommandClearsPlayersDevourVote game =     forAll (arbitraryWerewolf game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target ->-    not (isWerewolf target)-    ==> let game'' = run_ (apply $ devourVoteCommand (caller ^. name) (target ^. name)) game'-        in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes+    forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target ->+    let game'' = run_ (apply $ devourVoteCommand (caller ^. name) (target ^. name)) game'+    in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes     where         game' = game { _stage = WerewolvesTurn }  prop_quitCommandClearsPlayersLynchVote :: Game -> Property prop_quitCommandClearsPlayersLynchVote game =-    forAll (arbitraryWerewolf game') $ \caller ->+    forAll (arbitraryPlayer game') $ \caller ->     forAll (arbitraryPlayer game') $ \target ->     let game'' = run_ (apply $ lynchVoteCommand (caller ^. name) (target ^. name)) game'         in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes     where         game' = game { _stage = VillagesTurn } -prop_quitCommandClearsPlayersSee :: Game -> Property-prop_quitCommandClearsPlayersSee game =-    forAll (arbitrarySeer game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target ->-    let game'' = run_ (apply $ seeCommand (caller ^. name) (target ^. name)) game'-        in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes-    where-        game' = game { _stage = SeersTurn }- prop_seeCommandErrorsWhenGameIsOver :: Game -> Property prop_seeCommandErrorsWhenGameIsOver game =-    isGameOver game-    ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game+    forAll (arbitrarySeeCommand game') $ verbose_runCommandErrors game'+    where+        game' = game { _stage = GameOver }  prop_seeCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_seeCommandErrorsWhenCallerDoesNotExist game caller =@@ -243,16 +485,16 @@  prop_seeCommandErrorsWhenCallerNotSeer :: Game -> Property prop_seeCommandErrorsWhenCallerNotSeer game =-    forAll (arbitraryPlayer game) $ \caller ->-    not (isSeer caller)-    ==> forAll (arbitraryPlayer game) $ \target ->-        verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name))+    forAll (suchThat (arbitraryPlayer game) (not . isSeer)) $ \caller ->+    forAll (arbitraryPlayer game) $ \target ->+    verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name))  prop_seeCommandSetsSee :: Game -> Property prop_seeCommandSetsSee game =-    isSeersTurn game-    ==> forAll (arbitrarySeeCommand game) $ \command ->-        isJust $ run_ (apply command) game ^. see+    forAll (arbitrarySeeCommand game') $ \command ->+    isJust $ run_ (apply command) game' ^. see+    where+        game' = game { _stage = SeersTurn }  verbose_runCommandErrors :: Game -> Command -> Property-verbose_runCommandErrors game command = whenFail (mapM_ putStrLn [show game, show command, show . fromRight $ run (apply command) game]) (isLeft $ run (apply command) game)+verbose_runCommandErrors game command = whenFail (mapM_ putStrLn [show game, show . fromRight $ run (apply command) game]) (isLeft $ run (apply command) game)

@@ -10,24 +10,36 @@  module Game.Werewolf.Test.Engine (     -- * checkStage-    prop_checkStageSkipsSeersWhenNoSeers, prop_checkStageDoesNothingWhenGameOver,-    prop_checkSeersTurnAdvancesToWerewolves, prop_checkSeersTurnResetsSee,-    prop_checkSeersTurnDoesNothingUnlessAllSeen, prop_checkVillagesTurnAdvancesToSeers,-    prop_checkVillagesTurnLynchesOnePlayerWhenConsensus, prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats,+    prop_checkStageSkipsSeersTurnWhenNoSeer, prop_checkStageSkipsWitchsTurnWhenNoWitch,+    prop_checkStageDoesNothingWhenGameOver,++    prop_checkSeersTurnAdvancesToWerewolvesTurn, prop_checkSeersTurnResetsSee,+    prop_checkSeersTurnDoesNothingUnlessSeen,++    prop_checkVillagesTurnAdvancesToSeersTurn, prop_checkVillagesTurnLynchesOnePlayerWhenConsensus,+    prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats,     prop_checkVillagesTurnLynchesScapegoatWhenConflicted, prop_checkVillagesTurnResetsVotes,-    prop_checkVillagesTurnDoesNothingUnlessAllVoted, prop_checkWerewolvesTurnAdvancesToVillages,+    prop_checkVillagesTurnDoesNothingUnlessAllVoted,++    prop_checkWerewolvesTurnAdvancesToWitchsTurn,+    prop_checkWerewolvesTurnSkipsWitchsTurnWhenWitchDevoured,+    prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned,     prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus,     prop_checkWerewolvesTurnKillsNoOneWhenConflicted, prop_checkWerewolvesTurnResetsVotes,     prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, +    prop_checkWitchsTurnAdvancesToVillagesTurn, prop_checkWitchsTurnHealsDevoureeWhenHealed,+    prop_checkWitchsTurnKillsOnePlayerWhenPoisoned, prop_checkWitchsTurnDoesNothingWhenPassed,+    prop_checkWitchsTurnResetsHeal, prop_checkWitchsTurnResetsPoison,+     -- * checkGameOver     prop_checkGameOverAdvancesStage, prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive,      -- * startGame     prop_startGameStartsWithSunsetStage, prop_startGameUsesGivenPlayers,     prop_startGameErrorsUnlessUniquePlayerNames, prop_startGameErrorsWhenLessThan7Players,-    prop_startGameErrorsWhenMoreThan24Players, prop_startGameErrorsWhenMoreThan1Seer,-    prop_startGameErrorsWhenMoreThan1Scapegoat,+    prop_startGameErrorsWhenMoreThan24Players, prop_startGameErrorsWhenMoreThan1Scapegoat,+    prop_startGameErrorsWhenMoreThan1Seer, prop_startGameErrorsWhenMoreThan1Witch,      -- * createPlayers     prop_createPlayersUsesGivenPlayerNames, prop_createPlayersUsesGivenRoles,@@ -48,57 +60,62 @@ import           Data.Maybe import           Data.Text         (Text) -import           Game.Werewolf.Engine         hiding (doesPlayerExist, getVoteResult, isGameOver,-                                               isSeersTurn, isVillagesTurn, isWerewolvesTurn,+import           Game.Werewolf.Command+import           Game.Werewolf.Engine         hiding (doesPlayerExist, getDevourEvent,+                                               getVoteResult, isGameOver, isSeersTurn,+                                               isVillagesTurn, isWerewolvesTurn, isWitchsTurn,                                                killPlayer) import           Game.Werewolf.Game import           Game.Werewolf.Player-import           Game.Werewolf.Role           hiding (_name)+import           Game.Werewolf.Role           hiding (name, _name) import qualified Game.Werewolf.Role           as Role import           Game.Werewolf.Test.Arbitrary  import Test.QuickCheck import Test.QuickCheck.Monadic -prop_checkStageSkipsSeersWhenNoSeers :: Game -> Property-prop_checkStageSkipsSeersWhenNoSeers game =+prop_checkStageSkipsSeersTurnWhenNoSeer :: Game -> Property+prop_checkStageSkipsSeersTurnWhenNoSeer game =     forAll (runArbitraryCommands n game') $ \game'' ->     isWerewolvesTurn $ run_ checkStage game''     where         game'   = (foldl killPlayer game (filterSeers $ game ^. players)) { _stage = VillagesTurn }-        n       = length . filterAlive $ game' ^. players+        n       = length $ game' ^. players +prop_checkStageSkipsWitchsTurnWhenNoWitch :: Game -> Property+prop_checkStageSkipsWitchsTurnWhenNoWitch game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    isVillagesTurn $ run_ checkStage game''+    where+        game'   = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players+ prop_checkStageDoesNothingWhenGameOver :: Game -> Property prop_checkStageDoesNothingWhenGameOver game = run_ checkStage game' === game'     where         game' = game { _stage = GameOver } -prop_checkSeersTurnAdvancesToWerewolves :: Game -> Property-prop_checkSeersTurnAdvancesToWerewolves game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    isWerewolvesTurn $ run_ checkStage game''+prop_checkSeersTurnAdvancesToWerewolvesTurn :: Game -> Property+prop_checkSeersTurnAdvancesToWerewolvesTurn game =+    forAll (arbitraryCommand game') $ \command ->+    isWerewolvesTurn $ run_ checkStage (run_ (apply command) game')     where-        game'   = game { _stage = SeersTurn }-        n       = length . filterSeers $ game' ^. players+        game' = game { _stage = SeersTurn }  prop_checkSeersTurnResetsSee :: Game -> Property prop_checkSeersTurnResetsSee game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    isNothing $ run_ checkStage game'' ^. see+    forAll (arbitraryCommand game') $ \command ->+    isNothing $ run_ checkStage (run_ (apply command) game') ^. see     where-        game'   = game { _stage = SeersTurn }-        n       = length . filterSeers $ game' ^. players+        game' = game { _stage = SeersTurn } -prop_checkSeersTurnDoesNothingUnlessAllSeen :: Game -> Property-prop_checkSeersTurnDoesNothingUnlessAllSeen game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    isSeersTurn $ run_ checkStage game''+prop_checkSeersTurnDoesNothingUnlessSeen :: Game -> Bool+prop_checkSeersTurnDoesNothingUnlessSeen game = isSeersTurn $ run_ checkStage game'     where-        game'   = game { _stage = SeersTurn }-        n       = length (filterSeers $ game' ^. players) - 1+        game' = game { _stage = SeersTurn } -prop_checkVillagesTurnAdvancesToSeers :: Game -> Property-prop_checkVillagesTurnAdvancesToSeers game =+prop_checkVillagesTurnAdvancesToSeersTurn :: Game -> Property+prop_checkVillagesTurnAdvancesToSeersTurn game =     forAll (runArbitraryCommands n game') $ \game'' ->     not (null . filterAlive . filterSeers $ run_ checkStage game'' ^. players)     ==> isSeersTurn $ run_ checkStage game''@@ -150,22 +167,40 @@         game'   = game { _stage = VillagesTurn }         n       = length (game' ^. players) - 1 -prop_checkWerewolvesTurnAdvancesToVillages :: Game -> Property-prop_checkWerewolvesTurnAdvancesToVillages game =-    forAll (runArbitraryCommands n game') $ \game' ->-    isVillagesTurn $ run_ checkStage game'+prop_checkWerewolvesTurnAdvancesToWitchsTurn :: Game -> Property+prop_checkWerewolvesTurnAdvancesToWitchsTurn game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> isWitchsTurn $ run_ checkStage game''     where         game'   = game { _stage = WerewolvesTurn }         n       = length . filterWerewolves $ game' ^. players +prop_checkWerewolvesTurnSkipsWitchsTurnWhenWitchDevoured :: Game -> Property+prop_checkWerewolvesTurnSkipsWitchsTurnWhenWitchDevoured game =+    forAll (arbitraryWitch game) $ \witch ->+    let devourVoteCommands = map (\werewolf -> devourVoteCommand (werewolf ^. name) (witch ^. name)) (filterWerewolves $ game ^. players)+        game'' = foldl (flip $ run_ . apply) game' devourVoteCommands+    in not . isWitchsTurn $ run_ checkStage game''+    where+        game' = game { _stage = WerewolvesTurn }++prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned :: Game -> Bool+prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned game =+    not . isWitchsTurn $ run_ checkStage game'+    where+        game' = game { _stage = WerewolvesTurn, _healUsed = True, _poisonUsed = True }+ prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus :: Game -> Property prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus game =     forAll (runArbitraryCommands n game') $ \game'' ->     length (getVoteResult game'') == 1-    ==> length (filterDead $ run_ checkStage game'' ^. players) == 1+    ==> length (filterDead . filter (not . isWitch) $ run_ checkStage game'' ^. players) == 1     where-        game'   = game { _stage = WerewolvesTurn }-        n       = length $ game' ^. players+        game'   = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players  prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: Game -> Property prop_checkWerewolvesTurnKillsNoOneWhenConflicted game =@@ -174,12 +209,12 @@     ==> length (filterDead $ run_ checkStage game'' ^. players) == 0     where         game'   = game { _stage = WerewolvesTurn }-        n       = length $ game' ^. players+        n       = length . filterWerewolves $ game' ^. players  prop_checkWerewolvesTurnResetsVotes :: Game -> Property prop_checkWerewolvesTurnResetsVotes game =-    forAll (runArbitraryCommands n game') $ \game' ->-    Map.null $ run_ checkStage game' ^. votes+    forAll (runArbitraryCommands n game') $ \game'' ->+    Map.null $ run_ checkStage game'' ^. votes     where         game'   = game { _stage = WerewolvesTurn }         n       = length . filterWerewolves $ game' ^. players@@ -192,6 +227,70 @@         game'   = game { _stage = WerewolvesTurn }         n       = length (filterWerewolves $ game' ^. players) - 1 +prop_checkWitchsTurnAdvancesToVillagesTurn :: Game -> Property+prop_checkWitchsTurnAdvancesToVillagesTurn game =+    forAll (arbitraryPassCommand game') $ \command ->+    isVillagesTurn $ run_ checkStage (run_ (apply command) game')+    where+        game' = game { _stage = WitchsTurn }++prop_checkWitchsTurnHealsDevoureeWhenHealed :: Game -> Property+prop_checkWitchsTurnHealsDevoureeWhenHealed game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> let game''' = run_ checkStage game''+            in forAll (arbitraryHealCommand game''') $ \command ->+            forAll (arbitraryPassCommand game''') $ \passCommand ->+            null . filterDead $ run_ checkStage+                (run_ (apply passCommand) $+                    run_ (apply command) game'''+                    ) ^. players+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players++prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: Game -> Property+prop_checkWitchsTurnKillsOnePlayerWhenPoisoned game =+    forAll (arbitraryPoisonCommand game') $ \command ->+    forAll (arbitraryPassCommand game') $ \passCommand ->+    length (filterDead $ run_ checkStage (run_ (apply passCommand) $ run_ (apply command) game') ^. players) == 1+    where+        game' = game { _stage = WitchsTurn }++prop_checkWitchsTurnDoesNothingWhenPassed :: Game -> Property+prop_checkWitchsTurnDoesNothingWhenPassed game =+    forAll (arbitraryPassCommand game') $ \command ->+    null . filterDead $ run_ checkStage (run_ (apply command) game') ^. players+    where+        game' = game { _stage = WitchsTurn }++prop_checkWitchsTurnResetsHeal :: Game -> Property+prop_checkWitchsTurnResetsHeal game =+    forAll (runArbitraryCommands n game') $ \game'' ->+    length (getVoteResult game'') == 1+    ==> let target = head $ getVoteResult game''+        in not (isWitch target)+        ==> let game''' = run_ checkStage game''+            in forAll (arbitraryHealCommand game''') $ \command ->+            forAll (arbitraryPassCommand game''') $ \passCommand ->+            not $ run_ checkStage+                (run_ (apply passCommand) $+                    run_ (apply command) game'''+                    ) ^. heal+    where+        game'   = game { _stage = WerewolvesTurn }+        n       = length . filterWerewolves $ game' ^. players+++prop_checkWitchsTurnResetsPoison :: Game -> Property+prop_checkWitchsTurnResetsPoison game =+    forAll (arbitraryPoisonCommand game') $ \command ->+    isNothing $ run_ checkStage (run_ (apply command) game') ^. poison+    where+        game' = game { _stage = WitchsTurn }+ prop_checkGameOverAdvancesStage :: Game -> Property prop_checkGameOverAdvancesStage game =     forAll (sublistOf $ game ^. players) $ \players' ->@@ -234,14 +333,19 @@         length players > 24         ==> isLeft (runExcept . runWriterT $ startGame "" players) +prop_startGameErrorsWhenMoreThan1Scapegoat :: [Player] -> Property+prop_startGameErrorsWhenMoreThan1Scapegoat players =+    length (filterScapegoats players) > 1+    ==> isLeft (runExcept . runWriterT $ startGame "" players)+ prop_startGameErrorsWhenMoreThan1Seer :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Seer players =     length (filterSeers players) > 1     ==> isLeft (runExcept . runWriterT $ startGame "" players) -prop_startGameErrorsWhenMoreThan1Scapegoat :: [Player] -> Property-prop_startGameErrorsWhenMoreThan1Scapegoat players =-    length (filterScapegoats players) > 1+prop_startGameErrorsWhenMoreThan1Witch :: [Player] -> Property+prop_startGameErrorsWhenMoreThan1Witch players =+    length (filterWitches players) > 1     ==> isLeft (runExcept . runWriterT $ startGame "" players)  prop_createPlayersUsesGivenPlayerNames :: [Text] -> [Role] -> Property@@ -251,7 +355,7 @@ prop_createPlayersUsesGivenRoles playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . isSubsequenceOf extraRoles . map _role  prop_createPlayersCreatesAlivePlayers :: [Text] -> [Role] -> Property-prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . all ((==) Alive . _state)+prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . all ((Alive ==) . _state)  prop_randomiseRolesReturnsNRoles :: [Role] -> Int -> Property prop_randomiseRolesReturnsNRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . (==) n . length

@@ -8,7 +8,10 @@ {-# OPTIONS_HADDOCK hide, prune #-}  module Game.Werewolf.Test.Game (-    prop_newGameStartsWithSunsetStage, prop_newGameStartsWithNoSee,+    prop_newGameStartsWithSunsetStage, prop_newGameStartsWithEventsEmpty,+    prop_newGameStartsWithPassesEmpty, prop_newGameStartsWithNoHeal,+    prop_newGameStartsWithNoHealUsed, prop_newGameStartsWithNoPoison,+    prop_newGameStartsWithNoPoisonUsed, prop_newGameStartsWithNoSee,     prop_newGameStartsWithVotesEmpty, prop_newGameUsesGivenPlayers, ) where @@ -22,6 +25,24 @@  prop_newGameStartsWithSunsetStage :: [Player] -> Bool prop_newGameStartsWithSunsetStage players = isSunset (newGame players)++prop_newGameStartsWithEventsEmpty :: [Player] -> Bool+prop_newGameStartsWithEventsEmpty players = null $ newGame players ^. events++prop_newGameStartsWithPassesEmpty :: [Player] -> Bool+prop_newGameStartsWithPassesEmpty players = null $ newGame players ^. passes++prop_newGameStartsWithNoHeal :: [Player] -> Bool+prop_newGameStartsWithNoHeal players = not $ newGame players ^. heal++prop_newGameStartsWithNoHealUsed :: [Player] -> Bool+prop_newGameStartsWithNoHealUsed players = not $ newGame players ^. healUsed++prop_newGameStartsWithNoPoison :: [Player] -> Bool+prop_newGameStartsWithNoPoison players = isNothing $ newGame players ^. poison++prop_newGameStartsWithNoPoisonUsed :: [Player] -> Bool+prop_newGameStartsWithNoPoisonUsed players = not $ newGame players ^. poisonUsed  prop_newGameStartsWithNoSee :: [Player] -> Bool prop_newGameStartsWithNoSee players = isNothing $ newGame players ^. see

@@ -1,5 +1,5 @@ name:           werewolf-version:        0.4.0.1+version:        0.4.1.0  author:         Henry J. Wylde maintainer:     public@hjwylde.com@@ -31,7 +31,9 @@         Werewolf.Commands.End,         Werewolf.Commands.Help,         Werewolf.Commands.Interpret,+        Werewolf.Commands.Pass,         Werewolf.Commands.Ping,+        Werewolf.Commands.Poison,         Werewolf.Commands.Quit,         Werewolf.Commands.See,         Werewolf.Commands.Start,