werewolf 0.4.4.1 → 0.4.5.0
raw patch · 23 files changed
+1741/−881 lines, 23 files
Files
- CHANGELOG.md +16/−0
- README.md +9/−5
- app/Main.hs +4/−1
- app/Werewolf/Commands/Choose.hs +53/−0
- app/Werewolf/Commands/Help.hs +19/−10
- app/Werewolf/Commands/Start.hs +0/−1
- app/Werewolf/Commands/Version.hs +27/−0
- app/Werewolf/Commands/Vote.hs +2/−2
- app/Werewolf/Options.hs +14/−3
- src/Game/Werewolf/Command.hs +91/−60
- src/Game/Werewolf/Engine.hs +117/−46
- src/Game/Werewolf/Game.hs +87/−31
- src/Game/Werewolf/Player.hs +33/−24
- src/Game/Werewolf/Response.hs +253/−135
- src/Game/Werewolf/Role.hs +120/−26
- test/app/Main.hs +1/−177
- test/src/Game/Werewolf/Test/Arbitrary.hs +188/−48
- test/src/Game/Werewolf/Test/Command.hs +391/−197
- test/src/Game/Werewolf/Test/Engine.hs +264/−104
- test/src/Game/Werewolf/Test/Game.hs +38/−8
- test/src/Game/Werewolf/Test/Player.hs +11/−1
- test/src/Game/Werewolf/Test/Util.hs +0/−1
- werewolf.cabal +3/−1
CHANGELOG.md view
@@ -2,6 +2,22 @@ #### Upcoming +#### v0.4.5.0++*Minor*++* Added the Wolf-hound role. ([#50](https://github.com/hjwylde/werewolf/issues/50))+* Added a `version` command. ([#84](https://github.com/hjwylde/werewolf/issues/84))+* Added the Wild-child role. ([#49](https://github.com/hjwylde/werewolf/issues/49))+* Added the Angel role. ([#52](https://github.com/hjwylde/werewolf/issues/52))++*Revisions*++* Renamed the Villager role to Simple Villager.+* Renamed the Werewolf role to Simple Werewolf.+* Renamed the devourVoteCommand and lynchVoteCommand to voteDevourCommand and voteLynchCommand. ([#49](https://github.com/hjwylde/werewolf/issues/49))+* Fixed `quit` to advance the stage when the only role for that stage has quit.+ #### v0.4.4.1 *Revisions*
README.md view
@@ -14,19 +14,23 @@ It is now time to take control and eliminate this ancient evil, before the town loses its last few inhabitants. Objective of the Game: +For the Angel: die in the first round. For the Villagers: lynch all of the Werewolves. For the Werewolves: devour all of the Villagers. #### Roles The current implemented roles are:+* Angel. * Defender. * Scapegoat. * Seer.-* Villager.+* Simple Villager.+* Simple Werewolf. * Villager-Villager.-* Werewolf.+* Wild-child. * Witch.+* Wolf-hound. ### Installing @@ -58,8 +62,8 @@ > werewolf --caller @foo start --extra-roles seer @bar @baz @qux @quux @corge @grault {"ok":true,"messages":[ {"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":"The roles in play are Seer (1), Simple Villager (4), Simple Werewolf (2)."},+ {"to":"@foo","message":"You're a Simple 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 Seer wakes up."},@@ -97,7 +101,7 @@ {"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 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 Simple 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?"} ]}
app/Main.hs view
@@ -6,7 +6,6 @@ Maintainer : public@hjwylde.com -} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide, prune #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,6 +21,7 @@ import System.Environment +import qualified Werewolf.Commands.Choose as Choose import qualified Werewolf.Commands.End as End import qualified Werewolf.Commands.Heal as Heal import qualified Werewolf.Commands.Help as Help@@ -34,6 +34,7 @@ import qualified Werewolf.Commands.See as See import qualified Werewolf.Commands.Start as Start import qualified Werewolf.Commands.Status as Status+import qualified Werewolf.Commands.Version as Version import qualified Werewolf.Commands.Vote as Vote import Werewolf.Options @@ -53,6 +54,7 @@ handle :: Options -> IO () handle (Options callerName command) = case command of+ Choose options -> Choose.handle callerName options End -> End.handle callerName Heal -> Heal.handle callerName Help options -> Help.handle callerName options@@ -65,4 +67,5 @@ See options -> See.handle callerName options Start options -> Start.handle callerName options Status -> Status.handle callerName+ Version -> Version.handle callerName Vote options -> Vote.handle callerName options
+ app/Werewolf/Commands/Choose.hs view
@@ -0,0 +1,53 @@+{-|+Module : Werewolf.Commands.Choose+Description : Options and handler for the choose subcommand.++Copyright : (c) Henry J. Wylde, 2015+License : BSD3+Maintainer : public@hjwylde.com++Options and handler for the choose subcommand.+-}++module Werewolf.Commands.Choose (+ -- * 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 hiding (isWildChildsTurn)+import Game.Werewolf.Game+import Game.Werewolf.Response++-- | Options.+data Options = Options+ { arg :: Text+ } deriving (Eq, Show)++-- | Handle.+handle :: MonadIO m => Text -> Options -> m ()+handle callerName (Options arg) = do+ unlessM doesGameExist $ exitWith failure+ { messages = [noGameRunningMessage callerName]+ }++ game <- readGame++ let command = (if isWildChildsTurn game+ then choosePlayerCommand+ else chooseAllegianceCommand+ ) callerName arg++ case runExcept (runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game) of+ Left errorMessages -> exitWith failure { messages = errorMessages }+ Right (game, messages) -> writeGame game >> exitWith success { messages = messages }
app/Werewolf/Commands/Help.hs view
@@ -61,8 +61,9 @@ commandsMessages :: [Text] commandsMessages =- [ "end - ends the current game."- , "heal - heal a devoured player."+ [ "choose (ALLEGIANCE|PLAYER) - choose an allegiance or player."+ , "end - ends the current game."+ , "heal - heal the devoured player." , "pass - pass on healing or poisoning a player." , "ping - pings the status of the current game publicly." , "poison PLAYER - poison a player."@@ -91,6 +92,7 @@ ] ] , [ "Objective of the Game:"+ , "For the Angel: die in the first round." , "For the Villagers: lynch all of the Werewolves." , "For the Werewolves: devour all of the Villagers." ]@@ -116,15 +118,22 @@ , [ T.unwords [ "Each player is informed of their role (see `help roles' for a list)" , "at the start of the game. A game begins at night and follows a standard cycle."+ , "(N.B., when the Angel is in play the game begins with the village vote.)" ]- , "1. The village falls asleep."- , "2. The Defender wakes up and protects someone."- , "3. The Seer wakes up and sees someone's allegiance."- , "4. The Werewolves wake up and select a victim."- , "5. The Witch wakes up and may heal the victim and/or poison someone."- , "6. The village wakes up and find the victim."- , "7. The village votes to lynch a suspect."- , "The game is over when only Villagers or Werewolves are left alive."+ , "1. (When the Angel is in play) the village votes to lynch a suspect."+ , "2. The village falls asleep."+ , "3. (First round only) the Wild-child wakes up and chooses a role model."+ , "4. The Defender wakes up and protects someone."+ , "5. The Seer wakes up and sees someone's allegiance."+ , "6. (First round only) the Wolf-hound wakes up and chooses an allegiance."+ , "7. The Werewolves wake up and select a victim."+ , "8. The Witch wakes up and may heal the victim and/or poison someone."+ , "9. The village wakes up and find the victim."+ , "10. The village votes to lynch a suspect."+ , T.unwords+ [ "The game is over when only Villagers or Werewolves are left alive,"+ , "or one of the loners completes their own objective."+ ] ] ]
app/Werewolf/Commands/Start.hs view
@@ -59,6 +59,5 @@ Left errorMessages -> exitWith failure { messages = errorMessages } Right (game, messages) -> writeGame game >> exitWith success { messages = messages } - findByName :: Text -> Maybe Role findByName name' = find ((name' ==) . T.toLower . view name) allRoles
+ app/Werewolf/Commands/Version.hs view
@@ -0,0 +1,27 @@+{-|+Module : Werewolf.Commands.Version+Description : Handler for the version subcommand.++Copyright : (c) Henry J. Wylde, 2015+License : BSD3+Maintainer : public@hjwylde.com++Handler for the start subcommand.+-}++module Werewolf.Commands.Version (+ -- * Handle+ handle,+) where++import Control.Monad.Except++import Data.Text (Text)++import Game.Werewolf.Response++import Werewolf.Version++-- | Handle.+handle :: MonadIO m => Text -> m ()+handle callerName = exitWith success { messages = [engineVersionMessage callerName version] }
app/Werewolf/Commands/Vote.hs view
@@ -44,8 +44,8 @@ game <- readGame let command = (if isWerewolvesTurn game- then devourVoteCommand- else lynchVoteCommand+ then voteDevourCommand+ else voteLynchCommand ) callerName targetName case runExcept (runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game) of
app/Werewolf/Options.hs view
@@ -24,6 +24,7 @@ import qualified Data.Text as T import Data.Version (showVersion) +import qualified Werewolf.Commands.Choose as Choose import qualified Werewolf.Commands.Help as Help import qualified Werewolf.Commands.Interpret as Interpret import qualified Werewolf.Commands.Poison as Poison@@ -31,7 +32,7 @@ import qualified Werewolf.Commands.See as See import qualified Werewolf.Commands.Start as Start import qualified Werewolf.Commands.Vote as Vote-import Werewolf.Version as This+import qualified Werewolf.Version as This import Options.Applicative @@ -43,7 +44,8 @@ -- | Command. data Command- = End+ = Choose Choose.Options+ | End | Heal | Help Help.Options | Interpret Interpret.Options@@ -55,6 +57,7 @@ | See See.Options | Start Start.Options | Status+ | Version | Vote Vote.Options deriving (Eq, Show) @@ -88,7 +91,8 @@ , help "Specify the calling player's name" ]) <*> subparser (mconcat- [ command "end" $ info (helper <*> end) (fullDesc <> progDesc "End the current game")+ [ command "choose" $ info (helper <*> choose) (fullDesc <> progDesc "Choose an allegiance")+ , 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)@@ -100,9 +104,13 @@ , command "see" $ info (helper <*> see) (fullDesc <> progDesc "See a player's allegiance") , command "start" $ info (helper <*> start) (fullDesc <> progDesc "Start a new game") , command "status" $ info (helper <*> status) (fullDesc <> progDesc "Get the status of the current game")+ , command "version" $ info (helper <*> version) (fullDesc <> progDesc "Show this engine's version") , command "vote" $ info (helper <*> vote) (fullDesc <> progDesc "Vote against a player") ]) +choose :: Parser Command+choose = Choose . Choose.Options . T.pack <$> strArgument (metavar "ALLEGIANCE")+ end :: Parser Command end = pure End @@ -152,6 +160,9 @@ status :: Parser Command status = pure Status++version :: Parser Command+version = pure Version vote :: Parser Command vote = Vote . Vote.Options <$> playerArgument
src/Game/Werewolf/Command.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Game.Werewolf.Command (@@ -18,8 +19,9 @@ Command(..), -- ** Instances- devourVoteCommand, healCommand, lynchVoteCommand, noopCommand, passCommand, pingCommand,- poisonCommand, protectCommand, quitCommand, seeCommand, statusCommand,+ chooseAllegianceCommand, choosePlayerCommand, healCommand, noopCommand, passCommand,+ pingCommand, poisonCommand, protectCommand, quitCommand, seeCommand, statusCommand,+ voteDevourCommand, voteLynchCommand, ) where import Control.Lens hiding (only)@@ -32,59 +34,59 @@ import qualified Data.Map as Map import Data.Maybe import Data.Text (Text)+import qualified Data.Text as T -import Game.Werewolf.Engine-import Game.Werewolf.Game hiding (getDevourEvent, getPendingVoters, getPlayerVote,- isDefendersTurn, isGameOver, isSeersTurn, isVillagesTurn,- isWerewolvesTurn, isWitchsTurn, killPlayer)-import Game.Werewolf.Player hiding (doesPlayerExist)-import Game.Werewolf.Response+import Game.Werewolf.Engine+import Game.Werewolf.Game hiding (getDevourEvent, getPendingVoters, getPlayerVote,+ isDefendersTurn, isGameOver, isSeersTurn, isVillagesTurn,+ isWerewolvesTurn, isWildChildsTurn, isWitchsTurn,+ isWolfHoundsTurn, killPlayer, setPlayerRole)+import Game.Werewolf.Player hiding (doesPlayerExist)+import Game.Werewolf.Response+import Game.Werewolf.Role hiding (name)+import qualified Game.Werewolf.Role as Role data Command = Command { apply :: forall m . (MonadError [Message] m, MonadState Game m, MonadWriter [Message] m) => m () } -devourVoteCommand :: Text -> Text -> Command-devourVoteCommand callerName targetName = Command $ do+chooseAllegianceCommand :: Text -> Text -> Command+chooseAllegianceCommand callerName allegianceName = Command $ do validatePlayer callerName callerName- unlessM (isPlayerWerewolf callerName) $ throwError [playerCannotDoThatMessage callerName]- unlessM isWerewolvesTurn $ throwError [playerCannotDoThatRightNowMessage callerName]- whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName]- validatePlayer callerName targetName- whenM (isPlayerWerewolf targetName) $ throwError [playerCannotDevourAnotherWerewolfMessage callerName]+ unlessM (isPlayerWolfHound callerName) $ throwError [playerCannotDoThatMessage callerName]+ unlessM isWolfHoundsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]+ when (isNothing mRole) $ throwError [allegianceDoesNotExistMessage callerName allegianceName] - votes %= Map.insert callerName targetName+ setPlayerRole callerName (fromJust mRole)+ where+ mRole = case T.toLower allegianceName of+ "villagers" -> Just simpleVillagerRole+ "werewolves" -> Just simpleWerewolfRole+ _ -> Nothing - aliveWerewolfNames <- uses players $ map (view name) . filterAlive . filterWerewolves+choosePlayerCommand :: Text -> Text -> Command+choosePlayerCommand callerName targetName = Command $ do+ validatePlayer callerName callerName+ unlessM (isPlayerWildChild callerName) $ throwError [playerCannotDoThatMessage callerName]+ unlessM isWildChildsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]+ when (callerName == targetName) $ throwError [playerCannotChooseSelfMessage callerName]+ validatePlayer callerName targetName - tell $ map (\werewolfName -> playerMadeDevourVoteMessage werewolfName callerName targetName) (aliveWerewolfNames \\ [callerName])+ roleModel .= Just targetName healCommand :: Text -> Command healCommand callerName = Command $ do- validatePlayer callerName callerName- unlessM (isPlayerWitch callerName) $ throwError [playerCannotDoThatMessage callerName]- unlessM isWitchsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]+ validateWitchsCommand 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- unlessM isVillagesTurn $ throwError [playerCannotDoThatRightNowMessage callerName]- whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName]- validatePlayer callerName targetName-- votes %= Map.insert callerName targetName- 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]+ validateWitchsCommand callerName passes %= nub . cons callerName @@ -92,14 +94,14 @@ pingCommand = Command $ use stage >>= \stage' -> case stage' of GameOver -> return () DefendersTurn -> do- defender <- uses players $ head . filterDefenders+ defender <- findPlayerByRole_ defenderRole - tell [pingDefenderMessage]+ tell [pingRoleMessage $ defender ^. role . Role.name] tell [pingPlayerMessage $ defender ^. name] SeersTurn -> do- seer <- uses players $ head . filterSeers+ seer <- findPlayerByRole_ seerRole - tell [pingSeerMessage]+ tell [pingRoleMessage $ seer ^. role . Role.name] tell [pingPlayerMessage $ seer ^. name] Sunrise -> return () Sunset -> return ()@@ -111,22 +113,30 @@ WerewolvesTurn -> do pendingVoters <- getPendingVoters - tell [pingWerewolvesMessage]+ tell [pingRoleMessage "Werewolves"] tell $ map (pingPlayerMessage . view name) (filterWerewolves pendingVoters)+ WildChildsTurn -> do+ wildChild <- findPlayerByRole_ wildChildRole++ tell [pingRoleMessage $ wildChild ^. role . Role.name]+ tell [pingPlayerMessage $ wildChild ^. name] WitchsTurn -> do- witch <- uses players $ head . filterWitches+ witch <- findPlayerByRole_ witchRole - tell [pingWitchMessage]+ tell [pingRoleMessage $ witch ^. role . Role.name] tell [pingPlayerMessage $ witch ^. name]+ WolfHoundsTurn -> do+ wolfHound <- findPlayerByRole_ wolfHoundRole + tell [pingRoleMessage $ wolfHound ^. role . Role.name]+ tell [pingPlayerMessage $ wolfHound ^. 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]+ validateWitchsCommand callerName+ whenM (use poisonUsed) $ throwError [playerHasAlreadyPoisonedMessage callerName] validatePlayer callerName targetName- whenJustM getDevourEvent $ \(DevourEvent targetName') ->+ whenJustM getDevourEvent $ \(DevourEvent targetName') -> when (targetName == targetName') $ throwError [playerCannotDoThatMessage callerName] poison .= Just targetName@@ -149,16 +159,18 @@ quitCommand callerName = Command $ do validatePlayer callerName callerName - caller <- uses players $ findByName_ callerName+ caller <- findPlayerByName_ callerName - killPlayer caller+ killPlayer callerName tell [playerQuitMessage caller] passes %= delete callerName+ when (isAngel caller) $ setPlayerRole callerName simpleVillagerRole when (isDefender caller) $ do protect .= Nothing priorProtect .= Nothing when (isSeer caller) $ see .= Nothing+ when (isWildChild caller) $ roleModel .= Nothing when (isWitch caller) $ do heal .= False healUsed .= False@@ -178,14 +190,6 @@ statusCommand :: Text -> Command statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of GameOver -> get >>= tell . gameOverMessages- DefendersTurn -> do- game <- get-- tell $ standardStatusMessages stage' (game ^. players)- SeersTurn -> do- game <- get-- tell $ standardStatusMessages stage' (game ^. players) Sunrise -> return () Sunset -> return () VillagesTurn -> do@@ -201,19 +205,46 @@ tell $ standardStatusMessages stage' (game ^. players) whenM (doesPlayerExist callerName &&^ isPlayerWerewolf callerName) $ tell [waitingOnMessage (Just callerName) pendingVoters]- WitchsTurn -> do+ _ -> do game <- get tell $ standardStatusMessages stage' (game ^. players) where standardStatusMessages stage players =- currentStageMessages callerName stage ++ [- rolesInGameMessage (Just callerName) $ map (view role) players,- playersInGameMessage callerName players- ]+ currentStageMessages callerName stage ++ [playersInGameMessage callerName players] +voteDevourCommand :: Text -> Text -> Command+voteDevourCommand callerName targetName = Command $ do+ validatePlayer callerName callerName+ unlessM (isPlayerWerewolf callerName) $ throwError [playerCannotDoThatMessage callerName]+ unlessM isWerewolvesTurn $ throwError [playerCannotDoThatRightNowMessage callerName]+ whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName]+ validatePlayer callerName targetName+ whenM (isPlayerWerewolf targetName) $ throwError [playerCannotDevourAnotherWerewolfMessage callerName]++ votes %= Map.insert callerName targetName++ aliveWerewolfNames <- uses players $ map (view name) . filterAlive . filterWerewolves++ tell $ map (\werewolfName -> playerMadeDevourVoteMessage werewolfName callerName targetName) (aliveWerewolfNames \\ [callerName])++voteLynchCommand :: Text -> Text -> Command+voteLynchCommand callerName targetName = Command $ do+ validatePlayer callerName callerName+ unlessM isVillagesTurn $ throwError [playerCannotDoThatRightNowMessage callerName]+ whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName]+ validatePlayer callerName targetName++ votes %= Map.insert callerName targetName+ validatePlayer :: (MonadError [Message] m, MonadState Game m) => Text -> Text -> m () validatePlayer callerName name = do whenM isGameOver $ throwError [gameIsOverMessage callerName] unlessM (doesPlayerExist name) $ throwError [playerDoesNotExistMessage callerName name] whenM (isPlayerDead name) $ throwError [if callerName == name then playerIsDeadMessage callerName else targetIsDeadMessage callerName name]++validateWitchsCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m ()+validateWitchsCommand callerName = do+ validatePlayer callerName callerName+ unlessM (isPlayerWitch callerName) $ throwError [playerCannotDoThatMessage callerName]+ unlessM isWitchsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]
src/Game/Werewolf/Engine.hs view
@@ -20,10 +20,14 @@ -- * Game -- ** Manipulations- startGame, killPlayer,+ startGame, killPlayer, setPlayerRole, + -- ** Searches+ findPlayerByName_, findPlayerByRole_,+ -- ** Queries- isGameOver, isDefendersTurn, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWitchsTurn,+ isGameOver, isDefendersTurn, isSeersTurn, isVillagesTurn, isWerewolvesTurn, isWildChildsTurn,+ isWitchsTurn, isWolfHoundsTurn, getPlayerVote, getPendingVoters, getVoteResult, -- ** Reading and writing@@ -40,8 +44,10 @@ createPlayers, -- ** Queries- doesPlayerExist, isPlayerDefender, isPlayerSeer, isPlayerWerewolf, isPlayerWitch, isPlayerAlive,- isPlayerDead,+ doesPlayerExist, isPlayerDefender, isPlayerSeer, isPlayerWildChild, isPlayerWitch,+ isPlayerWolfHound,+ isPlayerWerewolf,+ isPlayerAlive, isPlayerDead, -- * Role randomiseRoles,@@ -62,7 +68,8 @@ import Game.Werewolf.Game hiding (getDevourEvent, getPassers, getPendingVoters, getPlayerVote, getVoteResult, isDefendersTurn, isGameOver, isSeersTurn, isVillagesTurn, isWerewolvesTurn,- isWitchsTurn, killPlayer)+ isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn,+ killPlayer, setPlayerAllegiance, setPlayerRole) import qualified Game.Werewolf.Game as Game import Game.Werewolf.Player hiding (doesPlayerExist) import qualified Game.Werewolf.Player as Player@@ -70,6 +77,8 @@ import Game.Werewolf.Role hiding (name) import qualified Game.Werewolf.Role as Role +import Prelude hiding (round)+ import System.Directory import System.FilePath import System.Random.Shuffle@@ -86,20 +95,48 @@ checkStage' = use stage >>= \stage' -> case stage' of GameOver -> return () - DefendersTurn -> whenJustM (use protect) $ const advanceStage+ DefendersTurn -> do+ whenM (isDead <$> findPlayerByRole_ defenderRole) advanceStage - SeersTurn -> whenJustM (use see) $ \targetName -> do- seer <- uses players (head . filterSeers)- target <- uses players (findByName_ targetName)+ whenJustM (use protect) $ const advanceStage - tell [playerSeenMessage (seer ^. name) target]+ SeersTurn -> do+ seer <- findPlayerByRole_ seerRole + when (isDead seer) advanceStage++ whenJustM (use see) $ \targetName -> do+ target <- findPlayerByName_ targetName++ tell [playerSeenMessage (seer ^. name) target]++ advanceStage++ Sunrise -> do+ round += 1++ whenJustM (findPlayerByRole angelRole) $ \angel ->+ when (isAlive angel) $ do+ tell [angelJoinedVillagersMessage]++ setPlayerRole (angel ^. name) simpleVillagerRole+ advanceStage - Sunrise -> advanceStage+ Sunset -> do+ whenJustM (use roleModel) $ \roleModelsName -> do+ wildChild <- findPlayerByRole_ wildChildRole - Sunset -> advanceStage+ whenM (isPlayerDead roleModelsName &&^ return (isVillager wildChild)) $ do+ aliveWerewolfNames <- uses players (map (view name) . filterAlive . filterWerewolves) + setPlayerAllegiance (wildChild ^. name) Werewolves++ tell [playerJoinedPackMessage (wildChild ^. name) aliveWerewolfNames]+ tell $ wildChildJoinedPackMessages aliveWerewolfNames (wildChild ^. name)++ advanceStage+ VillagesTurn -> do playersCount <- uses players (length . filterAlive) votes' <- use votes@@ -109,12 +146,12 @@ getVoteResult >>= \votees -> case votees of [votee] -> do- killPlayer votee+ killPlayer $ votee ^. name tell [playerLynchedMessage votee] _ ->- uses players (filterAlive . filterScapegoats) >>= \aliveScapegoats -> case aliveScapegoats of- [scapegoat] -> killPlayer scapegoat >> tell [scapegoatLynchedMessage (scapegoat ^. name)]- _ -> tell [noPlayerLynchedMessage]+ findPlayerByRole scapegoatRole >>= \mScapegoat -> case mScapegoat of+ Just scapegoat -> killPlayer (scapegoat ^. name) >> tell [scapegoatLynchedMessage (scapegoat ^. name)]+ _ -> tell [noPlayerLynchedMessage] advanceStage @@ -133,7 +170,14 @@ advanceStage + WildChildsTurn -> do+ whenM (isDead <$> findPlayerByRole_ wildChildRole) advanceStage++ whenJustM (use roleModel) $ const advanceStage+ WitchsTurn -> do+ whenM (isDead <$> findPlayerByRole_ witchRole) advanceStage+ whenJustM (use poison) $ \targetName -> do events %= (++ [PoisonEvent targetName]) poison .= Nothing@@ -144,18 +188,18 @@ events %= cons NoDevourEvent . delete devourEvent heal .= False - witch <- uses players (head . filterWitches)- whenM (use healUsed &&^ use poisonUsed) advanceStage- whenM (fmap (witch `elem`) getPassers) advanceStage+ whenM (any isWitch <$> getPassers) advanceStage + WolfHoundsTurn -> unlessM (uses players (any isWolfHound . filterAlive)) advanceStage+ advanceStage :: (MonadState Game m, MonadWriter [Message] m) => m () advanceStage = do- game <- get- stage' <- use stage- alivePlayers <- uses players filterAlive+ game <- get+ stage' <- use stage+ aliveAllegiances <- uses players (nub . map (view $ role . allegiance) . filterAlive) - let nextStage = if length (nub $ map (view $ role . allegiance) alivePlayers) <= 1+ let nextStage = if length aliveAllegiances <= 1 || any isAngel (filterDead $ game ^. players) then GameOver else head $ filter (stageAvailable game) (drop1 $ dropWhile (stage' /=) stageCycle) @@ -181,25 +225,27 @@ applyEvent :: (MonadState Game m, MonadWriter [Message] m) => Event -> m () applyEvent (DevourEvent targetName) = do- player <- uses players $ findByName_ targetName-- killPlayer player+ player <- findPlayerByName_ targetName + killPlayer targetName tell [playerDevouredMessage player] applyEvent NoDevourEvent = tell [noPlayerDevouredMessage] applyEvent (PoisonEvent name) = do- player <- uses players $ findByName_ name-- killPlayer player+ player <- findPlayerByName_ name + killPlayer name tell [playerPoisonedMessage player] checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do- aliveAllegiances <- uses players $ nub . map (view $ role . allegiance) . filterAlive+ aliveAllegiances <- uses players (nub . map (view $ role . allegiance) . filterAlive)+ deadPlayers <- uses players filterDead - when (length aliveAllegiances <= 1) $ stage .= GameOver >> get >>= tell . gameOverMessages+ when (length aliveAllegiances <= 1 || any isAngel deadPlayers) $ do+ stage .= GameOver + tell . gameOverMessages =<< get+ startGame :: (MonadError [Message] m, MonadWriter [Message] m) => Text -> [Player] -> m Game startGame callerName players = do when (playerNames /= nub playerNames) $ throwError [privateMessage callerName "Player names must be unique."]@@ -216,11 +262,25 @@ return game where playerNames = map (view name) players- restrictedRoles = [defenderRole, scapegoatRole, seerRole, villagerVillagerRole, witchRole] -killPlayer :: MonadState Game m => Player -> m ()-killPlayer player = players %= map (\player' -> if player' == player then player' & state .~ Dead else player')+killPlayer :: MonadState Game m => Text -> m ()+killPlayer name = modify $ Game.killPlayer name +setPlayerRole :: MonadState Game m => Text -> Role -> m ()+setPlayerRole name role = modify $ Game.setPlayerRole name role++setPlayerAllegiance :: MonadState Game m => Text -> Allegiance -> m ()+setPlayerAllegiance name allegiance = modify $ Game.setPlayerAllegiance name allegiance++findPlayerByName_ :: MonadState Game m => Text -> m Player+findPlayerByName_ name = uses players $ findByName_ name++findPlayerByRole :: MonadState Game m => Role -> m (Maybe Player)+findPlayerByRole role = uses players $ findByRole role++findPlayerByRole_ :: MonadState Game m => Role -> m Player+findPlayerByRole_ role = uses players $ findByRole_ role+ isDefendersTurn :: MonadState Game m => m Bool isDefendersTurn = gets Game.isDefendersTurn @@ -233,9 +293,15 @@ isWerewolvesTurn :: MonadState Game m => m Bool isWerewolvesTurn = gets Game.isWerewolvesTurn +isWildChildsTurn :: MonadState Game m => m Bool+isWildChildsTurn = gets Game.isWildChildsTurn+ isWitchsTurn :: MonadState Game m => m Bool isWitchsTurn = gets Game.isWitchsTurn +isWolfHoundsTurn :: MonadState Game m => m Bool+isWolfHoundsTurn = gets Game.isWolfHoundsTurn+ isGameOver :: MonadState Game m => m Bool isGameOver = gets Game.isGameOver @@ -279,28 +345,33 @@ doesPlayerExist name = uses players $ Player.doesPlayerExist name isPlayerDefender :: MonadState Game m => Text -> m Bool-isPlayerDefender name = uses players $ isDefender . findByName_ name+isPlayerDefender name = isDefender <$> findPlayerByName_ name isPlayerSeer :: MonadState Game m => Text -> m Bool-isPlayerSeer name = uses players $ isSeer . findByName_ name+isPlayerSeer name = isSeer <$> findPlayerByName_ name -isPlayerWerewolf :: MonadState Game m => Text -> m Bool-isPlayerWerewolf name = uses players $ isWerewolf . findByName_ name+isPlayerWildChild :: MonadState Game m => Text -> m Bool+isPlayerWildChild name = isWildChild <$> findPlayerByName_ name isPlayerWitch :: MonadState Game m => Text -> m Bool-isPlayerWitch name = uses players $ isWitch . findByName_ name+isPlayerWitch name = isWitch <$> findPlayerByName_ name +isPlayerWolfHound :: MonadState Game m => Text -> m Bool+isPlayerWolfHound name = isWolfHound <$> findPlayerByName_ name++isPlayerWerewolf :: MonadState Game m => Text -> m Bool+isPlayerWerewolf name = isWerewolf <$> findPlayerByName_ name+ isPlayerAlive :: MonadState Game m => Text -> m Bool-isPlayerAlive name = uses players $ isAlive . findByName_ name+isPlayerAlive name = isAlive <$> findPlayerByName_ name isPlayerDead :: MonadState Game m => Text -> m Bool-isPlayerDead name = uses players $ isDead . findByName_ name+isPlayerDead name = isDead <$> findPlayerByName_ name randomiseRoles :: MonadIO m => [Role] -> Int -> m [Role]-randomiseRoles extraRoles n = liftIO . evalRandIO . shuffleM $ extraRoles ++ werewolfRoles ++ villagerRoles+randomiseRoles extraRoles n = liftIO . evalRandIO . shuffleM $ extraRoles ++ simpleVillagerRoles ++ simpleWerewolfRoles where- extraWerewolfRoles = filter ((==) Role.Werewolves . view allegiance) extraRoles- extraVillagerRoles = filter ((==) Role.Villagers . view allegiance) extraRoles+ extraWerewolfRoles = filter ((Role.Werewolves ==) . view allegiance) extraRoles - werewolfRoles = replicate (n `quot` 6 + 1 - length extraWerewolfRoles) werewolfRole- villagerRoles = replicate (n - length (extraVillagerRoles ++ werewolfRoles)) villagerRole+ simpleWerewolfRoles = replicate (n `quot` 6 + 1 - length extraWerewolfRoles) simpleWerewolfRole+ simpleVillagerRoles = replicate (n - length extraRoles - length simpleWerewolfRoles) simpleVillagerRole
src/Game/Werewolf/Game.hs view
@@ -13,21 +13,26 @@ module Game.Werewolf.Game ( -- * Game- Game, stage, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect,- protect, see, votes,+ Game, stage, round, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect,+ protect, roleModel, see, votes, newGame, -- ** Manipulations- killPlayer,+ killPlayer, setPlayerRole, setPlayerAllegiance, -- ** Queries- isGameOver, isDefendersTurn, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn,- isWitchsTurn, getPassers, getPlayerVote, getPendingVoters, getVoteResult,+ isFirstRound,+ getPassers, getPlayerVote, getPendingVoters, getVoteResult, -- * Stage Stage(..),+ allStages, stageCycle, stageAvailable, + -- ** Queries+ isGameOver, isDefendersTurn, isSeersTurn, isSunrise, isSunset, isVillagesTurn, isWerewolvesTurn,+ isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn,+ -- * Event Event(..), @@ -44,9 +49,13 @@ import Data.Text (Text) import Game.Werewolf.Player+import Game.Werewolf.Role hiding (name) +import Prelude hiding (round)+ data Game = Game { _stage :: Stage+ , _round :: Int , _players :: [Player] , _events :: [Event] , _passes :: [Text]@@ -56,12 +65,13 @@ , _poisonUsed :: Bool , _priorProtect :: Maybe Text , _protect :: Maybe Text+ , _roleModel :: Maybe Text , _see :: Maybe Text , _votes :: Map Text Text } deriving (Eq, Read, Show) data Stage = GameOver | DefendersTurn | SeersTurn | Sunrise | Sunset | VillagesTurn- | WerewolvesTurn | WitchsTurn+ | WerewolvesTurn | WildChildsTurn | WitchsTurn | WolfHoundsTurn deriving (Eq, Read, Show) data Event = DevourEvent Text | NoDevourEvent | PoisonEvent Text@@ -76,6 +86,7 @@ where game = Game { _stage = Sunset+ , _round = 0 , _players = players , _events = [] , _passes = []@@ -85,36 +96,22 @@ , _poisonUsed = False , _priorProtect = Nothing , _protect = Nothing+ , _roleModel = Nothing , _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')--isGameOver :: Game -> Bool-isGameOver game = game ^. stage == GameOver--isDefendersTurn :: Game -> Bool-isDefendersTurn game = game ^. stage == DefendersTurn--isSeersTurn :: Game -> Bool-isSeersTurn game = game ^. stage == SeersTurn--isSunrise :: Game -> Bool-isSunrise game = game ^. stage == Sunrise--isSunset :: Game -> Bool-isSunset game = game ^. stage == Sunset+killPlayer :: Text -> Game -> Game+killPlayer name' game = game & players %~ map (\player -> if player ^. name == name' then player & state .~ Dead else player) -isVillagesTurn :: Game -> Bool-isVillagesTurn game = game ^. stage == VillagesTurn+setPlayerRole :: Text -> Role -> Game -> Game+setPlayerRole name' role' game = game & players %~ map (\player -> if player ^. name == name' then player & role .~ role' else player) -isWerewolvesTurn :: Game -> Bool-isWerewolvesTurn game = game ^. stage == WerewolvesTurn+setPlayerAllegiance :: Text -> Allegiance -> Game -> Game+setPlayerAllegiance name' allegiance' game = game & players %~ map (\player -> if player ^. name == name' then player & role . allegiance .~ allegiance' else player) -isWitchsTurn :: Game -> Bool-isWitchsTurn game = game ^. stage == WitchsTurn+isFirstRound :: Game -> Bool+isFirstRound game = game ^. round == 0 getPassers :: Game -> [Player] getPassers game = map (`findByName_` players') passes'@@ -138,9 +135,32 @@ votees = Map.elems $ game ^. votes result = last $ groupSortOn (\votee -> length $ elemIndices votee votees) (nub votees) +allStages :: [Stage]+allStages =+ [ GameOver+ , DefendersTurn+ , SeersTurn+ , Sunrise+ , Sunset+ , VillagesTurn+ , WerewolvesTurn+ , WildChildsTurn+ , WitchsTurn+ , WolfHoundsTurn+ ]+ stageCycle :: [Stage] stageCycle = cycle- [Sunset, SeersTurn, DefendersTurn, WerewolvesTurn, WitchsTurn, Sunrise, VillagesTurn]+ [ VillagesTurn+ , Sunset+ , SeersTurn+ , WildChildsTurn+ , DefendersTurn+ , WolfHoundsTurn+ , WerewolvesTurn+ , WitchsTurn+ , Sunrise+ ] stageAvailable :: Game -> Stage -> Bool stageAvailable _ GameOver = False@@ -148,11 +168,47 @@ stageAvailable game SeersTurn = any isSeer (filterAlive $ game ^. players) stageAvailable _ Sunrise = True stageAvailable _ Sunset = True-stageAvailable _ VillagesTurn = True+stageAvailable game VillagesTurn =+ any isAngel (filterAlive $ game ^. players)+ || not (isFirstRound game) stageAvailable game WerewolvesTurn = any isWerewolf (filterAlive $ game ^. players)+stageAvailable game WildChildsTurn =+ any isWildChild (filterAlive $ game ^. players)+ && isNothing (game ^. roleModel) stageAvailable game WitchsTurn = any isWitch (filterAlive $ game ^. players) && (not (game ^. healUsed) || not (game ^. poisonUsed))+stageAvailable game WolfHoundsTurn = any isWolfHound (filterAlive $ game ^. players)++isGameOver :: Game -> Bool+isGameOver game = game ^. stage == GameOver++isDefendersTurn :: Game -> Bool+isDefendersTurn game = game ^. stage == DefendersTurn++isSeersTurn :: Game -> Bool+isSeersTurn game = game ^. stage == SeersTurn++isSunrise :: Game -> Bool+isSunrise game = game ^. stage == Sunrise++isSunset :: Game -> Bool+isSunset game = game ^. stage == Sunset++isVillagesTurn :: Game -> Bool+isVillagesTurn game = game ^. stage == VillagesTurn++isWerewolvesTurn :: Game -> Bool+isWerewolvesTurn game = game ^. stage == WerewolvesTurn++isWildChildsTurn :: Game -> Bool+isWildChildsTurn game = game ^. stage == WildChildsTurn++isWitchsTurn :: Game -> Bool+isWitchsTurn game = game ^. stage == WitchsTurn++isWolfHoundsTurn :: Game -> Bool+isWolfHoundsTurn game = game ^. stage == WolfHoundsTurn getDevourEvent :: Game -> Maybe Event getDevourEvent game = listToMaybe [event | event@(DevourEvent _) <- game ^. events]
src/Game/Werewolf/Player.hs view
@@ -17,15 +17,18 @@ newPlayer, -- ** Searches- findByName, findByName_,+ findByName, findByName_, findByRole, findByRole_, -- ** Filters- filterDefenders, filterScapegoats, filterSeers, filterVillagers, filterVillagerVillagers,- filterWerewolves, filterWitches,+ filterByRole,+ filterWerewolves, -- ** Queries- doesPlayerExist, isDefender, isScapegoat, isSeer, isVillager, isWerewolf, isWitch, isAlive,- isDead,+ doesPlayerExist,+ isAngel, isDefender, isScapegoat, isSeer, isSimpleVillager, isSimpleWerewolf,+ isVillagerVillager, isWildChild, isWitch, isWolfHound,+ isVillager, isWerewolf,+ isAlive, isDead, -- * State State(..),@@ -62,30 +65,24 @@ findByName_ :: Text -> [Player] -> Player findByName_ name = fromJust . findByName name -filterDefenders :: [Player] -> [Player]-filterDefenders = filter isDefender--filterScapegoats :: [Player] -> [Player]-filterScapegoats = filter isScapegoat--filterSeers :: [Player] -> [Player]-filterSeers = filter isSeer+findByRole :: Role -> [Player] -> Maybe Player+findByRole role' = find ((role' ==) . view role) -filterVillagers :: [Player] -> [Player]-filterVillagers = filter isVillager+findByRole_ :: Role -> [Player] -> Player+findByRole_ role = fromJust . findByRole role -filterVillagerVillagers :: [Player] -> [Player]-filterVillagerVillagers = filter isVillagerVillager+filterByRole :: Role -> [Player] -> [Player]+filterByRole role' = filter ((role' ==) . view role) filterWerewolves :: [Player] -> [Player] filterWerewolves = filter isWerewolf -filterWitches :: [Player] -> [Player]-filterWitches = filter isWitch- doesPlayerExist :: Text -> [Player] -> Bool doesPlayerExist name = isJust . findByName name +isAngel :: Player -> Bool+isAngel player = player ^. role == angelRole+ isDefender :: Player -> Bool isDefender player = player ^. role == defenderRole @@ -95,17 +92,29 @@ isSeer :: Player -> Bool isSeer player = player ^. role == seerRole -isVillager :: Player -> Bool-isVillager player = player ^. role == villagerRole+isSimpleVillager :: Player -> Bool+isSimpleVillager player = player ^. role == simpleVillagerRole +isSimpleWerewolf :: Player -> Bool+isSimpleWerewolf player = player ^. role == simpleWerewolfRole+ isVillagerVillager :: Player -> Bool isVillagerVillager player = player ^. role == villagerVillagerRole -isWerewolf :: Player -> Bool-isWerewolf player = player ^. role == werewolfRole+isWildChild :: Player -> Bool+isWildChild player = player ^. role == wildChildRole isWitch :: Player -> Bool isWitch player = player ^. role == witchRole++isWolfHound :: Player -> Bool+isWolfHound player = player ^. role == wolfHoundRole++isVillager :: Player -> Bool+isVillager player = player ^. role . allegiance == Villagers++isWerewolf :: Player -> Bool+isWerewolf player = player ^. role . allegiance == Werewolves isAlive :: Player -> Bool isAlive player = player ^. state == Alive
src/Game/Werewolf/Response.hs view
@@ -28,18 +28,20 @@ publicMessage, privateMessage, groupMessages, -- ** Binary messages- noGameRunningMessage, gameAlreadyRunningMessage,+ noGameRunningMessage, gameAlreadyRunningMessage, engineVersionMessage, -- ** Generic messages newGameMessages, stageMessages, gameOverMessages, playerQuitMessage, -- ** Ping messages- pingPlayerMessage, pingDefenderMessage, pingSeerMessage, pingWerewolvesMessage,- pingWitchMessage,+ pingPlayerMessage, pingRoleMessage, -- ** Status messages- currentStageMessages, rolesInGameMessage, playersInGameMessage, waitingOnMessage,+ currentStageMessages, playersInGameMessage, waitingOnMessage, + -- ** Angel's turn messages+ angelJoinedVillagersMessage,+ -- ** Seer's turn messages playerSeenMessage, @@ -50,14 +52,18 @@ -- ** Werewolves' turn messages playerMadeDevourVoteMessage, playerDevouredMessage, noPlayerDevouredMessage, + -- ** Wild-child's turn messages+ playerJoinedPackMessage, wildChildJoinedPackMessages,+ -- ** Witch's turn messages playerPoisonedMessage, -- ** Generic error messages gameIsOverMessage, playerDoesNotExistMessage, playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, playerIsDeadMessage, roleDoesNotExistMessage,+ allegianceDoesNotExistMessage, - -- ** Seer's turn error messages+ -- ** Defender's turn error messages playerCannotProtectSelfMessage, playerCannotProtectSamePlayerTwiceInARowMessage, -- ** Voting turn error messages@@ -66,6 +72,9 @@ -- ** Werewolves' turn error messages playerCannotDevourAnotherWerewolfMessage, + -- ** Wild-child's turn error messages+ playerCannotChooseSelfMessage,+ -- ** Witch's turn error messages playerHasAlreadyHealedMessage, playerHasAlreadyPoisonedMessage, ) where@@ -83,10 +92,11 @@ import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as T import qualified Data.Text.Lazy.IO as T+import Data.Version import Game.Werewolf.Game import Game.Werewolf.Player-import Game.Werewolf.Role (Allegiance (..), Role, allegiance, description)+import Game.Werewolf.Role hiding (name) import qualified Game.Werewolf.Role as Role import GHC.Generics @@ -134,7 +144,7 @@ privateMessage to = Message (Just to) groupMessages :: [Text] -> Text -> [Message]-groupMessages tos message = map (\to -> privateMessage to message) tos+groupMessages tos message = map (`privateMessage` message) tos noGameRunningMessage :: Text -> Message noGameRunningMessage to = privateMessage to "No game is running."@@ -142,65 +152,81 @@ gameAlreadyRunningMessage :: Text -> Message gameAlreadyRunningMessage to = privateMessage to "A game is already running." +engineVersionMessage :: Text -> Version -> Message+engineVersionMessage to version = privateMessage to $ T.unwords ["Version", T.pack $ showVersion version]+ newGameMessages :: Game -> [Message]-newGameMessages game = [- newPlayersInGameMessage players',- rolesInGameMessage Nothing $ map (view role) players'- ] ++ map (newPlayerMessage players') players'- ++ villagerVillagerMessages- ++ stageMessages game+newGameMessages game = concat+ [ [newPlayersInGameMessage players', rolesInGameMessage $ map (view role) players']+ , map newPlayerMessage players'+ , villagerVillagerMessages+ , stageMessages game+ ] where players' = game ^. players villagerVillagerMessages =- case filterVillagerVillagers (game ^. players) of- [villagerVillager] -> [villagerVillagerMessage $ villagerVillager ^. name]- _ -> []+ case findByRole villagerVillagerRole players' of+ Just villagerVillager -> [villagerVillagerMessage $ villagerVillager ^. name]+ _ -> [] newPlayersInGameMessage :: [Player] -> Message-newPlayersInGameMessage players = publicMessage $ T.concat [- "A new game of werewolf is starting with ",- T.intercalate ", " (map (view name) players), "!"+newPlayersInGameMessage players = publicMessage $ T.concat+ [ "A new game of werewolf is starting with "+ , T.intercalate ", " playerNames, "!" ]+ where+ playerNames = map (view name) players -newPlayerMessage :: [Player] -> Player -> Message-newPlayerMessage players player- | isWerewolf player = privateMessage (player ^. name) $ T.intercalate "\n" [T.concat ["You're a Werewolf", packMessage], player ^. role . description]- | isVillager player = privateMessage (player ^. name) $ T.intercalate "\n" ["You're a Villager.", player ^. role . description]- | otherwise = privateMessage (player ^. name) $ T.intercalate "\n" [T.concat ["You're the ", player ^. role . Role.name, "."], player ^. role . description]+newPlayerMessage :: Player -> Message+newPlayerMessage player = privateMessage (player ^. name) $ T.intercalate "\n"+ [ T.concat ["You're ", article playerRole, " ", playerRole ^. Role.name, "."]+ , playerRole ^. description+ ] where- packMessage- | length (filterWerewolves players) <= 1 = "."- | otherwise = T.concat [", along with ", T.intercalate ", " (map (view name) $ filterWerewolves players \\ [player]), "."]+ playerRole = player ^. role villagerVillagerMessage :: Text -> Message-villagerVillagerMessage name = publicMessage $ T.unwords [- "Unguarded advice is seldom given, for advice is a dangerous gift,",- "even from the wise to the wise, and all courses may run ill.",- "Yet as you feel like you need help, I will begrudgingly leave you with this:",- name, "is the Villager-Villager."+villagerVillagerMessage name = publicMessage $ T.unwords+ [ "Unguarded advice is seldom given, for advice is a dangerous gift,"+ , "even from the wise to the wise, and all courses may run ill."+ , "Yet as you feel like you need help, I begrudgingly leave you with this:"+ , name, "is the Villager-Villager." ] stageMessages :: Game -> [Message] stageMessages game = case game ^. stage of GameOver -> []- DefendersTurn -> defendersTurnMessages (view name . head . filterDefenders $ game ^. players)- SeersTurn -> seersTurnMessages (view name . head . filterSeers $ game ^. players)+ DefendersTurn -> defendersTurnMessages defendersName+ SeersTurn -> seersTurnMessages seersName Sunrise -> [sunriseMessage] Sunset -> [nightFallsMessage]- VillagesTurn -> villagesTurnMessages- WerewolvesTurn -> werewolvesTurnMessages (map (view name) . filterAlive . filterWerewolves $ game ^. players)+ VillagesTurn -> if isFirstRound game+ then firstVillagesTurnMessages+ else villagesTurnMessages+ WerewolvesTurn -> if isFirstRound game+ then firstWerewolvesTurnMessages aliveWerewolfNames+ else werewolvesTurnMessages aliveWerewolfNames+ WildChildsTurn -> wildChildsTurnMessages wildChildsName WitchsTurn -> witchsTurnMessages game+ WolfHoundsTurn -> wolfHoundsTurnMessages wolfHoundsName+ where+ players' = game ^. players+ defendersName = findByRole_ defenderRole players' ^. name+ seersName = findByRole_ seerRole players' ^. name+ aliveWerewolfNames = map (view name) . filterAlive $ filterWerewolves players'+ wildChildsName = findByRole_ wildChildRole players' ^. name+ wolfHoundsName = findByRole_ wolfHoundRole players' ^. name defendersTurnMessages :: Text -> [Message]-defendersTurnMessages defenderName = [- publicMessage "The Defender wakes up.",- privateMessage defenderName "Whom would you like to protect?"+defendersTurnMessages to =+ [ publicMessage "The Defender wakes up."+ , privateMessage to "Whom would you like to `protect`?" ] seersTurnMessages :: Text -> [Message]-seersTurnMessages seerName = [- publicMessage "The Seer wakes up.",- privateMessage seerName "Whose allegiance would you like to see?"+seersTurnMessages to =+ [ publicMessage "The Seer wakes up."+ , privateMessage to "Whose allegiance would you like to `see`?" ] sunriseMessage :: Message@@ -209,47 +235,99 @@ nightFallsMessage :: Message nightFallsMessage = publicMessage "Night falls, the village is asleep." +firstVillagesTurnMessages :: [Message]+firstVillagesTurnMessages =+ ( publicMessage $ T.unwords+ [ "Alas, again I regrettably yield advice: an angelic menace walks among you."+ , "Do not cast your votes lightly,"+ , "for he will relish in this opportunity to be free from his terrible nightmare."+ ]+ ) : villagesTurnMessages+ villagesTurnMessages :: [Message]-villagesTurnMessages = [- publicMessage "As the village gathers in the square the town clerk calls for a vote.",- publicMessage "Whom would you like to lynch?"+villagesTurnMessages =+ [ publicMessage "As the village gathers in the square the town clerk calls for a vote."+ , publicMessage "Whom would you like to `vote` to lynch?" ] +firstWerewolvesTurnMessages :: [Text] -> [Message]+firstWerewolvesTurnMessages tos = concat+ [ map (\to -> privateMessage to $ packMessage to) tos+ , werewolvesTurnMessages tos+ ]+ where+ packMessage werewolfName = T.unwords+ [ "You feel restless, like an old curse is keeping you from sleep."+ , "It seems you're not the only one..."+ , packNames werewolfName+ , "are also emerging from their homes."+ ]+ packNames werewolfName = T.intercalate ", " (tos \\ [werewolfName])+ werewolvesTurnMessages :: [Text] -> [Message]-werewolvesTurnMessages werewolfNames = [- publicMessage "The Werewolves wake up, recognise one another and choose a new victim."- ] ++ groupMessages werewolfNames "Whom would you like to devour?"+werewolvesTurnMessages tos =+ [ publicMessage "The Werewolves wake up, recognise one another and choose a new victim."+ ] ++ groupMessages tos "Whom would you like to `vote` to devour?" +wildChildsTurnMessages :: Text -> [Message]+wildChildsTurnMessages to =+ [ publicMessage "The Wild-child wakes up."+ , privateMessage to "Whom do you `choose` to be your role model?"+ ]+ witchsTurnMessages :: Game -> [Message]-witchsTurnMessages game = wakeUpMessage:devourMessages ++ healMessages ++ poisonMessages ++ [passMessage]+witchsTurnMessages game = concat+ [ [wakeUpMessage]+ , devourMessages+ , healMessages+ , poisonMessages+ , [passMessage]+ ] where- witchName = (head . filterWitches $ game ^. players) ^. name+ witchsName = findByRole_ witchRole (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)+ passMessage = privateMessage witchsName "Type `pass` to end your turn."+ devourMessages = case getDevourEvent game of+ Just (DevourEvent targetName) ->+ [ privateMessage witchsName $+ T.unwords ["You see", targetName, "sprawled outside bleeding uncontrollably."]+ ]+ _ -> [] healMessages | not (game ^. healUsed)- && isJust (getDevourEvent game) = [privateMessage witchName "Would you like to heal them?"]+ && isJust (getDevourEvent game) = [privateMessage witchsName "Would you like to `heal` them?"] | otherwise = [] poisonMessages- | not (game ^. poisonUsed) = [privateMessage witchName "Whom would you like to poison?"]+ | not (game ^. poisonUsed) = [privateMessage witchsName "Would you like to `poison` anyone?"] | otherwise = [] +wolfHoundsTurnMessages :: Text -> [Message]+wolfHoundsTurnMessages to =+ [ publicMessage "The Wolf-hound wakes up."+ , privateMessage to "Which allegiance do you `choose` to be aligned with?"+ ]+ gameOverMessages :: Game -> [Message]-gameOverMessages game = case aliveAllegiances of- [allegiance'] -> concat [- [publicMessage $ T.unwords ["The game is over! The", T.pack $ show allegiance', "have won."]],- map (playerWonMessage . view name) (filter ((allegiance' ==) . view (role . allegiance)) players'),- map (playerLostMessage . view name) (filter ((allegiance' /=) . view (role . allegiance)) players')- ]- _ -> publicMessage "The game is over! Everyone died...":map (playerLostMessage . view name) players'+gameOverMessages game+ | any isAngel (filterDead $ game ^. players) =+ concat+ [ [publicMessage "You should have heeded my warning, for now the Angel has been set free!"]+ , [publicMessage "The game is over! The Angel has won."]+ , [playerWonMessage $ angel ^. name]+ , map (playerLostMessage . view name) (players' \\ [angel])+ ]+ | length aliveAllegiances == 1 = do+ let allegiance' = head aliveAllegiances++ concat+ [ [publicMessage $ T.unwords ["The game is over! The", T.pack $ show allegiance', "have won."]]+ , map (playerWonMessage . view name) (filter ((allegiance' ==) . view (role . allegiance)) players')+ , map (playerLostMessage . view name) (filter ((allegiance' /=) . view (role . allegiance)) players')+ ]+ | otherwise = publicMessage "The game is over! Everyone died...":map (playerLostMessage . view name) players' where players' = game ^. players+ angel = findByRole_ angelRole players' aliveAllegiances = nub $ map (view $ role . allegiance) (filterAlive players') playerWonMessage :: Text -> Message@@ -264,24 +342,15 @@ pingPlayerMessage :: Text -> Message pingPlayerMessage to = privateMessage to "Waiting on you..." -pingDefenderMessage :: Message-pingDefenderMessage = publicMessage "Waiting on the Defender..."--pingSeerMessage :: Message-pingSeerMessage = publicMessage "Waiting on the Seer..."--pingWerewolvesMessage :: Message-pingWerewolvesMessage = publicMessage "Waiting on the Werewolves..."--pingWitchMessage :: Message-pingWitchMessage = publicMessage "Waiting on the Witch..."+pingRoleMessage :: Text -> Message+pingRoleMessage roleName = publicMessage $ T.concat ["Waiting on the ", roleName, "..."] currentStageMessages :: Text -> Stage -> [Message] currentStageMessages to GameOver = [gameIsOverMessage to] currentStageMessages _ Sunrise = [] currentStageMessages _ Sunset = []-currentStageMessages to turn = [privateMessage to $ T.concat [- "It's currently the ", showTurn turn, " turn."+currentStageMessages to turn = [privateMessage to $ T.concat+ [ "It's currently the ", showTurn turn, " turn." ]] where showTurn :: Stage -> Text@@ -292,110 +361,145 @@ showTurn Sunset = undefined showTurn VillagesTurn = "Village's" showTurn WerewolvesTurn = "Werewolves'"+ showTurn WildChildsTurn = "Wild-child's" showTurn WitchsTurn = "Witch's"+ showTurn WolfHoundsTurn = "Wolf-hound's" -rolesInGameMessage :: Maybe Text -> [Role] -> Message-rolesInGameMessage mTo roles = Message mTo $ T.concat [- "The roles in play are ",- T.intercalate ", " $ map (\(role, count) ->+rolesInGameMessage :: [Role] -> Message+rolesInGameMessage roles = publicMessage $ T.concat+ [ "The roles in play are "+ , T.intercalate ", " $ map (\(role, count) -> T.concat [role ^. Role.name, " (", T.pack $ show count, ")"])- roleCounts,- "."+ roleCounts+ , "." ] where roleCounts = map (\list -> (head list, length list)) (groupSortOn (view Role.name) roles) playersInGameMessage :: Text -> [Player] -> Message-playersInGameMessage to players = privateMessage to . T.intercalate "\n" $ [- alivePlayersText+playersInGameMessage to players = privateMessage to . T.intercalate "\n" $+ [ alivePlayersText ] ++ if (null $ filterDead players) then [] else [deadPlayersText] where- alivePlayersText = T.concat [- "The following players are still alive: ",- T.intercalate ", " (map (view name) $ filterAlive players), "."+ alivePlayersText = T.concat+ [ "The following players are still alive: "+ , T.intercalate ", " (map (view name) $ filterAlive players), "." ]- deadPlayersText = T.concat [- "The following players are dead: ",- T.intercalate ", " (map (\player -> T.concat [player ^. name, " (", player ^. role . Role.name, ")"]) $ filterDead players), "."+ deadPlayersText = T.concat+ [ "The following players are dead: "+ , T.intercalate ", " (map (\player -> T.concat [player ^. name, " (", player ^. role . Role.name, ")"]) $ filterDead players), "." ] waitingOnMessage :: Maybe Text -> [Player] -> Message-waitingOnMessage mTo players = Message mTo $ T.concat [- "Waiting on ", T.intercalate ", " playerNames, "..."+waitingOnMessage mTo players = Message mTo $ T.concat+ [ "Waiting on ", T.intercalate ", " playerNames, "..." ] where playerNames = map (view name) players +angelJoinedVillagersMessage :: Message+angelJoinedVillagersMessage = publicMessage $ T.unwords+ [ "You hear the Angel wrought with anger off in the distance."+ , "He failed to attract the discriminatory vote of the village"+ , "or the devouring vindictiveness of the lycanthropes."+ , "Now he is stuck here, doomed forever to live out a mortal life as a Simple Villager."+ ]+ playerSeenMessage :: Text -> Player -> Message-playerSeenMessage to target = privateMessage to $ T.concat [- target ^. name, " is aligned with the ", T.pack . show $ target ^. role . allegiance, "."+playerSeenMessage to target = privateMessage to $ T.concat+ [ targetName, " is aligned with the ", T.pack $ show allegiance', "." ]+ where+ targetName = target ^. name+ allegiance' = target ^. role . allegiance playerMadeLynchVoteMessage :: Text -> Text -> Message-playerMadeLynchVoteMessage voterName targetName = publicMessage $ T.concat [- voterName, " voted to lynch ", targetName, "."+playerMadeLynchVoteMessage voterName targetName = publicMessage $ T.concat+ [ voterName, " voted to lynch ", targetName, "." ] playerLynchedMessage :: Player -> Message playerLynchedMessage player- | isWerewolf player = publicMessage $ T.unwords [- player ^. name, "is tied up to a pyre and set alight.",- "As they scream their body starts to contort and writhe, transforming into a Werewolf.",- "Thankfully they go limp before breaking free of their restraints."+ | isWerewolf player+ && not (isWildChild player) = publicMessage $ T.concat+ [ playerName, " is tied up to a pyre and set alight."+ , " As they scream their body starts to contort and writhe, transforming into "+ , article playerRole, " ", playerRole ^. Role.name, "."+ , " Thankfully they go limp before breaking free of their restraints." ]- | otherwise = publicMessage $ T.concat [- player ^. name, " is tied up to a pyre and set alight.",- " Eventually the screams start to die and with their last breath,",- " they reveal themselves as a ", player ^. role . Role.name, "."+ | otherwise = publicMessage $ T.concat+ [ playerName, " is tied up to a pyre and set alight."+ , " Eventually the screams start to die and with their last breath,"+ , " they reveal themselves as "+ , article playerRole, " ", playerRole ^. Role.name, "." ]+ where+ playerName = player ^. name+ playerRole = player ^. role noPlayerLynchedMessage :: Message-noPlayerLynchedMessage = publicMessage $ T.unwords [- "Daylight is wasted as the townsfolk squabble over whom to tie up.",- "Looks like no one is being burned this day."+noPlayerLynchedMessage = publicMessage $ T.unwords+ [ "Daylight is wasted as the townsfolk squabble over whom to tie up."+ , "Looks like no one is being burned this day." ] scapegoatLynchedMessage :: Text -> Message-scapegoatLynchedMessage name = publicMessage $ T.unwords [- "The townsfolk squabble over whom to tie up. Just as they are about to call it a day",- "they notice that", name, "has been acting awfully suspicious.",- "Not wanting to take any chances,", name, "is promptly tied to a pyre and burned alive."+scapegoatLynchedMessage name = publicMessage $ T.unwords+ [ "The townsfolk squabble over whom to tie up. Just as they are about to call it a day"+ , "they notice that", name, "has been acting awfully suspicious."+ , "Not wanting to take any chances,", name, "is promptly tied to a pyre and burned alive." ] playerMadeDevourVoteMessage :: Text -> Text -> Text -> Message-playerMadeDevourVoteMessage to voterName targetName = privateMessage to $ T.concat [- voterName, " voted to devour ", targetName, "."+playerMadeDevourVoteMessage to voterName targetName = privateMessage to $ T.concat+ [ voterName, " voted to devour ", targetName, "." ] playerDevouredMessage :: Player -> Message-playerDevouredMessage player = publicMessage $ T.concat [- "As you open them you notice a door broken down and ",- player ^. name, "'s guts half devoured and spilling out over the cobblestones.",- " From the look of their personal effects, you deduce they were a ",- player ^. role . Role.name, "."+playerDevouredMessage player = publicMessage $ T.concat+ [ "As you open them you notice a door broken down and "+ , playerName, "'s guts half devoured and spilling out over the cobblestones."+ , " From the look of their personal effects, you deduce they were "+ , article playerRole, " ", playerRole ^. Role.name, "." ]+ where+ playerName = player ^. name+ playerRole = player ^. role noPlayerDevouredMessage :: Message-noPlayerDevouredMessage = publicMessage $ T.unwords [- "Surprisingly you see everyone present at the town square.",- "Perhaps the Werewolves have left Miller's Hollow?"+noPlayerDevouredMessage = publicMessage $ T.unwords+ [ "Surprisingly you see everyone present at the town square."+ , "Perhaps the Werewolves have left Miller's Hollow?" ] +playerJoinedPackMessage :: Text -> [Text] -> Message+playerJoinedPackMessage to werewolfNames = privateMessage to $ T.unwords+ [ "The death of your role model is distressing."+ , "Without second thought you abandon the Villagers and run off into the woods,"+ , "towards your old home."+ , "As you arrive you see the familiar faces of", T.intercalate ", " werewolfNames+ , "waiting and happy to have you back."+ ]++wildChildJoinedPackMessages :: [Text] -> Text -> [Message]+wildChildJoinedPackMessages tos wildChildsName = groupMessages tos $ T.unwords+ [ wildChildsName, "the Wild-child scampers off into the woods."+ , "Without his role model nothing is holding back his true, wolfish, nature."+ ]+ 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."+playerPoisonedMessage player = publicMessage $ T.unwords+ [ "Upon further discovery, it looks like the Witch struck in the night."+ , 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!" playerDoesNotExistMessage :: Text -> Text -> Message-playerDoesNotExistMessage to name = privateMessage to $ T.unwords [- "Player", name, "does not exist."+playerDoesNotExistMessage to name = privateMessage to $ T.unwords+ [ "Player", name, "does not exist." ] playerCannotDoThatMessage :: Text -> Message@@ -410,6 +514,11 @@ roleDoesNotExistMessage :: Text -> Text -> Message roleDoesNotExistMessage to name = privateMessage to $ T.unwords ["Role", name, "does not exist."] +allegianceDoesNotExistMessage :: Text -> Text -> Message+allegianceDoesNotExistMessage to name = privateMessage to $ T.unwords+ [ "Allegiance", name, "does not exist."+ ]+ playerCannotProtectSelfMessage :: Text -> Message playerCannotProtectSelfMessage to = privateMessage to "You cannot protect yourself!" @@ -421,15 +530,24 @@ playerHasAlreadyVotedMessage to = privateMessage to "You've already voted!" targetIsDeadMessage :: Text -> Text -> Message-targetIsDeadMessage to targetName = privateMessage to $ T.unwords [- targetName, "is already dead!"+targetIsDeadMessage to targetName = privateMessage to $ T.unwords+ [ targetName, "is already dead!" ] playerCannotDevourAnotherWerewolfMessage :: Text -> Message-playerCannotDevourAnotherWerewolfMessage to = privateMessage to "You cannot devour another Werewolf!"+playerCannotDevourAnotherWerewolfMessage to =+ privateMessage to "You cannot devour another Werewolf!" +playerCannotChooseSelfMessage :: Text -> Message+playerCannotChooseSelfMessage to = privateMessage to "You cannot choose yourself!"+ playerHasAlreadyHealedMessage :: Text -> Message playerHasAlreadyHealedMessage to = privateMessage to "You've already healed someone!" playerHasAlreadyPoisonedMessage :: Text -> Message playerHasAlreadyPoisonedMessage to = privateMessage to "You've already poisoned someone!"++article :: Role -> Text+article role+ | role `elem` restrictedRoles = "the"+ | otherwise = "a"
src/Game/Werewolf/Role.hs view
@@ -17,17 +17,23 @@ Role, name, allegiance, description, advice, -- ** Instances- allRoles, defenderRole, scapegoatRole, seerRole, villagerRole, villagerVillagerRole,- werewolfRole, witchRole,+ allRoles, restrictedRoles,+ angelRole, defenderRole, scapegoatRole, seerRole, simpleVillagerRole, simpleWerewolfRole,+ villagerVillagerRole, wildChildRole, witchRole, wolfHoundRole, -- * Allegiance Allegiance(..),++ -- ** Instances+ allAllegiances, ) where import Control.Lens -import Data.Text (Text)-import qualified Data.Text as T+import Data.Function+import Data.List+import Data.Text (Text)+import qualified Data.Text as T import Prelude hiding (all) @@ -36,18 +42,56 @@ , _allegiance :: Allegiance , _description :: Text , _advice :: Text- } deriving (Eq, Read, Show)+ } deriving (Read, Show) +data Allegiance = Angel | Villagers | Werewolves+ deriving (Eq, Read, Show)++makeLenses ''Role++instance Eq Role where+ (==) = (==) `on` view name+ allRoles :: [Role]-allRoles = [defenderRole, scapegoatRole, seerRole, villagerRole, villagerVillagerRole, werewolfRole, witchRole]+allRoles =+ [ angelRole+ , defenderRole+ , scapegoatRole+ , seerRole+ , simpleVillagerRole+ , simpleWerewolfRole+ , villagerVillagerRole+ , wildChildRole+ , witchRole+ , wolfHoundRole+ ] +restrictedRoles :: [Role]+restrictedRoles = allRoles \\ [simpleVillagerRole, simpleWerewolfRole]++angelRole :: Role+angelRole = Role+ { _name = "Angel"+ , _allegiance = Angel+ , _description = T.unwords+ [ "The muddy life of a village infested with evil creatures repulses him;"+ , "he wishes to believe he's the victim of a terrible nightmare,"+ , "in order to finally wake up in his comfortable bed."+ ]+ , _advice = T.unwords+ [ "It's going to take all your guile and wits to con the village into eliminating you."+ , "Pretending to be a Werewolf is one tactic, but if it doesn't work then you may have just"+ , "dug yourself a hole for the rest of the game..."+ ]+ }+ defenderRole :: Role defenderRole = Role { _name = "Defender" , _allegiance = Villagers , _description = T.unwords [ "A knight living in Miller's Hollow."- , "The Defender has the ability to protect one player, except themself, each night."+ , "The Defender can save the Villagers (bar himself!) from the bite of the Werewolves." ] , _advice = "Be careful when you choose to protect someone, you cannot protect them 2 nights in a row."@@ -57,7 +101,10 @@ scapegoatRole = Role { _name = "Scapegoat" , _allegiance = Villagers- , _description = "That one person everyone loves to blame."+ , _description = T.unwords+ [ "It's sad to say, but in Miller's Hollow, when something doesn't go right"+ , "it's always him who unjustly suffers the consequences."+ ] , _advice = "Cross your fingers that the votes don't end up tied." } @@ -76,31 +123,66 @@ ] } -villagerRole :: Role-villagerRole = Role- { _name = "Villager"+simpleVillagerRole :: Role+simpleVillagerRole = Role+ { _name = "Simple Villager" , _allegiance = Villagers- , _description = "An ordinary townsperson humbly living in Millers Hollow."+ , _description = T.unwords+ [ "A simple, ordinary townsperson in every way."+ , "Their only weapons are the ability to analyze behaviour to identify Werewolves,"+ , "and the strength of their conviction to prevent"+ , "the execution of the innocents like themselves."+ ] , _advice = "Bluffing can be a good technique, but you had better be convincing about what you say." } +simpleWerewolfRole :: Role+simpleWerewolfRole = Role+ { _name = "Simple Werewolf"+ , _allegiance = Werewolves+ , _description = T.unwords+ [ "Each night they devour a Villager."+ , "During the day they try to hide their nocturnal identity to avoid mob justice."+ ]+ , _advice =+ "Voting to lynch your partner can be a good way to deflect suspicion from yourself."+ }+ villagerVillagerRole :: Role villagerVillagerRole = Role { _name = "Villager-Villager" , _allegiance = Villagers- , _description = "An honest townsperson humbly living in Millers Hollow."+ , _description = T.unwords+ [ "This person has a soul as clear and transparent as the water from a mountain stream."+ , "They will deserve the attentive ear of their peers"+ , "and will make their word decisive in crucial moments."+ ] , _advice = "You'll make friends quickly, but be wary about whom you trust." } -werewolfRole :: Role-werewolfRole = Role- { _name = "Werewolf"- , _allegiance = Werewolves- , _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."+wildChildRole :: Role+wildChildRole = Role+ { _name = "Wild-child"+ , _allegiance = Villagers+ , _description = T.unwords+ [ "Abandoned in the woods by his parents at a young age, he was raised by wolves."+ , "As soon as he learned how to walk on all fours,"+ , "the Wild-child began to wander around Miller's Hollow."+ , "One day, fascinated by an inhabitant of the village who was walking upright"+ , "with grace and presence, he made them his secret role model."+ , "He then decided to integrate himself into the community of Miller's Hollow and entered,"+ , "worried, in the village."+ , "The community was moved by his frailty, adopted him, and welcomed him in their fold."+ , "What will become of him: honest Villager or terrible Werewolf?"+ , "For all of his life,"+ , "the heart of the Wild-child will swing between these two alternatives."+ , "May his model confirm him in his newfound humanity."+ ]+ , _advice = T.unwords+ [ "Nothing is keeping you from taking part in the elimination of your role model,"+ , "if you so wish..."+ ] } witchRole :: Role@@ -108,8 +190,7 @@ { _name = "Witch" , _allegiance = Villagers , _description = T.unwords- [ "A conniving townsperson."- , "She knows how to make up 2 extremely powerful potions;"+ [ "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 can kill a player." ]@@ -119,7 +200,20 @@ ] } -data Allegiance = Villagers | Werewolves- deriving (Eq, Read, Show)+wolfHoundRole :: Role+wolfHoundRole = Role+ { _name = "Wolf-hound"+ , _allegiance = Villagers+ , _description = T.unwords+ [ "All dogs know in the depths of their soul that their ancestors were wolves"+ , "and that it's mankind who has kept them in the state of childishness and fear,"+ , "the faithful and generous companions."+ , "In any case, only the Wolf-hound can decide if he'll obey his human and civilized master"+ , "or if he'll listen to the call of wild nature buried within him."+ ]+ , _advice =+ "The choice of being a Simple Villager or Werewolf is final, so decide carefully!"+ } -makeLenses ''Role+allAllegiances :: [Allegiance]+allAllegiances = [Angel, Villagers, Werewolves]
test/app/Main.hs view
@@ -11,192 +11,16 @@ main ) where -import Game.Werewolf.Test.Arbitrary () import Game.Werewolf.Test.Command import Game.Werewolf.Test.Engine import Game.Werewolf.Test.Game import Game.Werewolf.Test.Player import Test.Tasty-import Test.Tasty.QuickCheck main :: IO () main = defaultMain =<< tests tests :: IO TestTree-tests = return $ testGroup "Tests" (concat+tests = return . testGroup "Tests" $ concat [allCommandTests, allEngineTests, allGameTests, allPlayerTests]- )--allCommandTests :: [TestTree]-allCommandTests =- [ testProperty "devour vote command errors when game is over" prop_devourVoteCommandErrorsWhenGameIsOver- , testProperty "devour vote command errors when caller does not exist" prop_devourVoteCommandErrorsWhenCallerDoesNotExist- , testProperty "devour vote command errors when target does not exist" prop_devourVoteCommandErrorsWhenTargetDoesNotExist- , testProperty "devour vote command errors when caller is dead" prop_devourVoteCommandErrorsWhenCallerIsDead- , testProperty "devour vote command errors when target is dead" prop_devourVoteCommandErrorsWhenTargetIsDead- , testProperty "devour vote command errors when not werewolves turn" prop_devourVoteCommandErrorsWhenNotWerewolvesTurn- , testProperty "devour vote command errors when caller not werewolf" prop_devourVoteCommandErrorsWhenCallerNotWerewolf- , testProperty "devour vote command errors when caller has voted" prop_devourVoteCommandErrorsWhenCallerHasVoted- , testProperty "devour vote command errors when target werewolf" prop_devourVoteCommandErrorsWhenTargetWerewolf- , testProperty "devour vote command updates votes" prop_devourVoteCommandUpdatesVotes-- , testProperty "heal command errors when game is over" prop_healCommandErrorsWhenGameIsOver- , testProperty "heal command errors when caller does not exist" prop_healCommandErrorsWhenCallerDoesNotExist- , testProperty "heal command errors when caller is dead" prop_healCommandErrorsWhenCallerIsDead- , testProperty "heal command errors when no target is devoured" prop_healCommandErrorsWhenNoTargetIsDevoured- , testProperty "heal command errors when not witch's turn" prop_healCommandErrorsWhenNotWitchsTurn- , testProperty "heal command errors when caller has healed" prop_healCommandErrorsWhenCallerHasHealed- , testProperty "heal command errors when caller not witch" prop_healCommandErrorsWhenCallerNotWitch- , testProperty "heal command sets heal" prop_healCommandSetsHeal- , testProperty "heal command sets heal used" prop_healCommandSetsHealUsed-- , testProperty "lynch vote command errors when game is over" prop_lynchVoteCommandErrorsWhenGameIsOver- , testProperty "lynch vote command errors when caller does not exist" prop_lynchVoteCommandErrorsWhenCallerDoesNotExist- , testProperty "lynch vote command errors when target does not exist" prop_lynchVoteCommandErrorsWhenTargetDoesNotExist- , testProperty "lynch vote command errors when caller is dead" prop_lynchVoteCommandErrorsWhenCallerIsDead- , testProperty "lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead- , testProperty "lynch vote command errors when not villages turn" prop_lynchVoteCommandErrorsWhenNotVillagesTurn- , testProperty "lynch vote command errors when caller has voted" prop_lynchVoteCommandErrorsWhenCallerHasVoted- , testProperty "lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes-- , testProperty "pass command errors when game is over" prop_passCommandErrorsWhenGameIsOver- , testProperty "pass command errors when caller does not exist" prop_passCommandErrorsWhenCallerDoesNotExist- , testProperty "pass command errors when caller is dead" prop_passCommandErrorsWhenCallerIsDead- , testProperty "pass command errors when not witch's turn" prop_passCommandErrorsWhenNotWitchsTurn- , testProperty "pass command updates passes" prop_passCommandUpdatesPasses-- , testProperty "poison command errors when game is over" prop_poisonCommandErrorsWhenGameIsOver- , testProperty "poison command errors when caller does not exist" prop_poisonCommandErrorsWhenCallerDoesNotExist- , testProperty "poison command errors when target does not exist" prop_poisonCommandErrorsWhenTargetDoesNotExist- , testProperty "poison command errors when caller is dead" prop_poisonCommandErrorsWhenCallerIsDead- , testProperty "poison command errors when target is dead" prop_poisonCommandErrorsWhenTargetIsDead- , testProperty "poison command errors when target is devoured" prop_poisonCommandErrorsWhenTargetIsDevoured- , testProperty "poison command errors when not witch's turn" prop_poisonCommandErrorsWhenNotWitchsTurn- , testProperty "poison command errors when caller has poisoned" prop_poisonCommandErrorsWhenCallerHasPoisoned- , testProperty "poison command errors when caller not witch" prop_poisonCommandErrorsWhenCallerNotWitch- -- TODO (hjw)- --, testProperty "poison command errors when caller devoured and not healed" prop_poisonCommandErrorsWhenCallerDevouredAndNotHealed- , testProperty "poison command sets poison" prop_poisonCommandSetsPoison- , testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed-- , testProperty "protect command errors when game is over" prop_protectCommandErrorsWhenGameIsOver- , testProperty "protect command errors when caller does not exist" prop_protectCommandErrorsWhenCallerDoesNotExist- , testProperty "protect command errors when target does not exist" prop_protectCommandErrorsWhenTargetDoesNotExist- , testProperty "protect command errors when caller is dead" prop_protectCommandErrorsWhenCallerIsDead- , testProperty "protect command errors when target is dead" prop_protectCommandErrorsWhenTargetIsDead- , testProperty "protect command errors when not defender's turn" prop_protectCommandErrorsWhenNotDefendersTurn- , testProperty "protect command errors when caller not defender" prop_protectCommandErrorsWhenCallerNotDefender- , testProperty "protect command errors when target is caller" prop_protectCommandErrorsWhenTargetIsCaller- , testProperty "protect command errors when target is prior protect" prop_protectCommandErrorsWhenTargetIsPriorProtect- , testProperty "protect command sets prior protect" prop_protectCommandSetsPriorProtect- , testProperty "protect command sets protect" prop_protectCommandSetsProtect-- , testProperty "quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver- , testProperty "quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist- , testProperty "quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead- , testProperty "quit command kills player" prop_quitCommandKillsPlayer- , testProperty "quit command clears heal when caller is witch" prop_quitCommandClearsHealWhenCallerIsWitch- , testProperty "quit command clears heal used when caller is witch" prop_quitCommandClearsHealUsedWhenCallerIsWitch- , testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonWhenCallerIsWitch- , testProperty "quit command clears poison used when caller is witch" prop_quitCommandClearsPoisonUsedWhenCallerIsWitch- , testProperty "quit command clears prior protect when caller is defender" prop_quitCommandClearsPriorProtectWhenCallerIsDefender- , testProperty "quit command clears protect when caller is defender" prop_quitCommandClearsProtectWhenCallerIsDefender- , testProperty "quit command clears player's devour vote" prop_quitCommandClearsPlayersDevourVote- , testProperty "quit command clears player's lynch vote" prop_quitCommandClearsPlayersLynchVote-- , testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver- , testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist- , testProperty "see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist- , testProperty "see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead- , testProperty "see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead- , testProperty "see command errors when not seer's turn" prop_seeCommandErrorsWhenNotSeersTurn- , testProperty "see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer- , testProperty "see command sets see" prop_seeCommandSetsSee- ]--allEngineTests :: [TestTree]-allEngineTests =- [ testProperty "check stage skips defender's turn when no defender" prop_checkStageSkipsDefendersTurnWhenNoDefender- , testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer- , testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch- , testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver-- , testProperty "check defender's turn advances to werewolves' turn" prop_checkDefendersTurnAdvancesToWerewolvesTurn- -- TODO (hjw)- --, testProperty "check defender's turn advances when no defender" prop_checkDefendersTurnAdvancesWhenNoDefender-- , testProperty "check seer's turn advances to defender's turn" prop_checkSeersTurnAdvancesToDefendersTurn- -- TODO (hjw)- --, testProperty "check seer's turn advances when no seer" prop_checkSeersTurnAdvancesWhenNoSeer- , testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee- , testProperty "check seer's turn does nothing unless seen" prop_checkSeersTurnDoesNothingUnlessSeen-- , testProperty "check villages' turn advances to seer's turn" prop_checkVillagesTurnAdvancesToSeersTurn- , testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus- , testProperty "check villages' turn lynches no one when conflicted and no scapegoats" prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats- , testProperty "check villages' turn lynches scapegoat when conflicted" prop_checkVillagesTurnLynchesScapegoatWhenConflicted- , testProperty "check villages' turn resets votes" prop_checkVillagesTurnResetsVotes- , testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted-- , testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn- , testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned- , testProperty "check werewolves' turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus- , testProperty "check werewolves' turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted- , testProperty "check werewolves' turn kills no one when target defended" prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended- , testProperty "check werewolves' turn resets protect" prop_checkWerewolvesTurnResetsProtect- , testProperty "check werewolves' turn resets votes" prop_checkWerewolvesTurnResetsVotes- , testProperty "check werewolves' turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted-- , testProperty "check witch's turn advances to villages' turn" prop_checkWitchsTurnAdvancesToVillagesTurn- -- TODO (hjw)- --, testProperty "check witch's turn advances when no witch" prop_checkWitchsTurnAdvancesWhenNoWitch- , testProperty "check witch's turn heals devouree when healed" prop_checkWitchsTurnHealsDevoureeWhenHealed- , testProperty "check witch's turn kills one player when poisoned" prop_checkWitchsTurnKillsOnePlayerWhenPoisoned- , testProperty "check witch's turn does nothing when passed" prop_checkWitchsTurnDoesNothingWhenPassed- , testProperty "check witch's turn resets heal" prop_checkWitchsTurnResetsHeal- , testProperty "check witch's turn resets poison" prop_checkWitchsTurnResetsPoison-- , testProperty "check game over advances stage" prop_checkGameOverAdvancesStage- , testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive-- , testProperty "start game starts with sunset stage" prop_startGameStartsWithSunsetStage- , testProperty "start game uses given players" prop_startGameUsesGivenPlayers- , testProperty "start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames- , testProperty "start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players- , testProperty "start game errors when more than 24 players" prop_startGameErrorsWhenMoreThan24Players- , testProperty "start game errors when more than 1 defender" prop_startGameErrorsWhenMoreThan1Defender- , testProperty "start game errors when more than 1 scapegoat" prop_startGameErrorsWhenMoreThan1Scapegoat- , testProperty "start game errors when more than 1 seer" prop_startGameErrorsWhenMoreThan1Seer- , testProperty "start game errors when more than 1 villager-villager" prop_startGameErrorsWhenMoreThan1VillagerVillager- , testProperty "start game errors when more than 1 witch" prop_startGameErrorsWhenMoreThan1Witch-- , testProperty "create players uses given player names" prop_createPlayersUsesGivenPlayerNames- , testProperty "create players uses given roles" prop_createPlayersUsesGivenRoles- , testProperty "create players creates alive players" prop_createPlayersCreatesAlivePlayers-- , testProperty "randomise roles returns n roles" prop_randomiseRolesReturnsNRoles- , testProperty "randomise roles uses given roles" prop_randomiseRolesUsesGivenRoles- , testProperty "randomise roles proportions allegiances" prop_randomiseRolesProportionsAllegiances- ]--allGameTests :: [TestTree]-allGameTests =- [ testProperty "new game starts with sunset stage" prop_newGameStartsWithSunsetStage- , testProperty "new game starts with events empty" prop_newGameStartsWithEventsEmpty- , testProperty "new game starts with passes empty" prop_newGameStartsWithPassesEmpty- , testProperty "new game starts with no heal" prop_newGameStartsWithNoHeal- , testProperty "new game starts with no heal used" prop_newGameStartsWithNoHealUsed- , testProperty "new game starts with no poison" prop_newGameStartsWithNoPoison- , testProperty "new game starts with no poison used" prop_newGameStartsWithNoPoisonUsed- , testProperty "new game starts with no prior protect" prop_newGameStartsWithNoPriorProtect- , testProperty "new game starts with no protect" prop_newGameStartsWithNoProtect- , testProperty "new game starts with no see" prop_newGameStartsWithNoSee- , testProperty "new game starts with votes empty" prop_newGameStartsWithVotesEmpty- , testProperty "new game uses given players" prop_newGameUsesGivenPlayers- ]--allPlayerTests :: [TestTree]-allPlayerTests =- [ testProperty "new player is alive" prop_newPlayerIsAlive- ]
test/src/Game/Werewolf/Test/Arbitrary.hs view
@@ -12,10 +12,15 @@ -- * Initial arbitraries -- ** Game- GameAtDefendersTurn(..), GameAtGameOver(..), GameAtVillagesTurn(..), GameAtWerewolvesTurn(..),- GameAtWitchsTurn(..), GameAtSeersTurn(..),- GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..), GameWithLynchVotes(..),- GameWithPoison(..), GameWithProtect(..), GameWithProtectAndDevourVotes(..), GameWithSee(..),+ NewGame(..),+ GameAtDefendersTurn(..), GameAtGameOver(..), GameAtSeersTurn(..), GameAtSunrise(..),+ GameAtVillagesTurn(..), GameAtWerewolvesTurn(..), GameAtWildChildsTurn(..),+ GameAtWitchsTurn(..), GameAtWolfHoundsTurn(..),+ GameOnSecondRound(..),+ GameWithDeadPlayers(..), GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..),+ GameWithLynchVotes(..), GameWithOneAllegianceAlive(..), GameWithPoison(..),+ GameWithProtect(..), GameWithProtectAndDevourVotes(..), GameWithRoleModel(..),+ GameWithRoleModelAtVillagesTurn(..), GameWithSee(..), GameWithZeroAllegiancesAlive(..), -- ** Player arbitraryPlayerSet,@@ -23,9 +28,11 @@ -- * Contextual arbitraries -- ** Command- arbitraryCommand, arbitraryDevourVoteCommand, arbitraryHealCommand, arbitraryLynchVoteCommand,- arbitraryPassCommand, arbitraryPoisonCommand, arbitraryProtectCommand, arbitraryQuitCommand,- arbitrarySeeCommand, runArbitraryCommands,+ arbitraryCommand, arbitraryChooseAllegianceCommand, arbitraryChoosePlayerCommand,+ arbitraryHealCommand, arbitraryPassCommand, arbitraryPoisonCommand, arbitraryProtectCommand,+ arbitraryQuitCommand, arbitrarySeeCommand, arbitraryVoteDevourCommand,+ arbitraryVoteLynchCommand,+ runArbitraryCommands, -- ** Player arbitraryPlayer, arbitraryWerewolf,@@ -45,18 +52,19 @@ import Game.Werewolf.Role hiding (name) import Game.Werewolf.Test.Util +import Prelude hiding (round)+ import Test.QuickCheck instance Arbitrary Game where arbitrary = do- game <- newGame <$> arbitraryPlayerSet- stage' <- arbitrary+ (NewGame game) <- arbitrary+ stage' <- arbitrary return $ game & stage .~ stage' instance Arbitrary Stage where- arbitrary = elements- [GameOver, DefendersTurn, SeersTurn, VillagesTurn, WerewolvesTurn, WitchsTurn]+ arbitrary = elements $ allStages \\ [GameOver, Sunrise, Sunset] instance Arbitrary Player where arbitrary = newPlayer <$> arbitrary <*> arbitrary@@ -67,9 +75,18 @@ instance Arbitrary Role where arbitrary = elements allRoles +instance Arbitrary Allegiance where+ arbitrary = elements allAllegiances+ instance Arbitrary Text where arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) +newtype NewGame = NewGame Game+ deriving (Eq, Show)++instance Arbitrary NewGame where+ arbitrary = NewGame . newGame <$> arbitraryPlayerSet+ newtype GameAtDefendersTurn = GameAtDefendersTurn Game deriving (Eq, Show) @@ -88,6 +105,24 @@ return $ GameAtGameOver (game & stage .~ GameOver) +newtype GameAtSeersTurn = GameAtSeersTurn Game+ deriving (Eq, Show)++instance Arbitrary GameAtSeersTurn where+ arbitrary = do+ game <- arbitrary++ return $ GameAtSeersTurn (game & stage .~ SeersTurn)++newtype GameAtSunrise = GameAtSunrise Game+ deriving (Eq, Show)++instance Arbitrary GameAtSunrise where+ arbitrary = do+ game <- arbitrary++ return $ GameAtSunrise (game & stage .~ Sunrise)+ newtype GameAtVillagesTurn = GameAtVillagesTurn Game deriving (Eq, Show) @@ -106,6 +141,15 @@ return $ GameAtWerewolvesTurn (game & stage .~ WerewolvesTurn) +newtype GameAtWildChildsTurn = GameAtWildChildsTurn Game+ deriving (Eq, Show)++instance Arbitrary GameAtWildChildsTurn where+ arbitrary = do+ game <- arbitrary++ return $ GameAtWildChildsTurn (game & stage .~ WildChildsTurn)+ newtype GameAtWitchsTurn = GameAtWitchsTurn Game deriving (Eq, Show) @@ -115,15 +159,35 @@ return $ GameAtWitchsTurn (game & stage .~ WitchsTurn) -newtype GameAtSeersTurn = GameAtSeersTurn Game+newtype GameAtWolfHoundsTurn = GameAtWolfHoundsTurn Game deriving (Eq, Show) -instance Arbitrary GameAtSeersTurn where+instance Arbitrary GameAtWolfHoundsTurn where arbitrary = do game <- arbitrary - return $ GameAtSeersTurn (game & stage .~ SeersTurn)+ return $ GameAtWolfHoundsTurn (game & stage .~ WolfHoundsTurn) +newtype GameOnSecondRound = GameOnSecondRound Game+ deriving (Eq, Show)++instance Arbitrary GameOnSecondRound where+ arbitrary = do+ game <- arbitrary++ return $ GameOnSecondRound (game & round .~ 1)++newtype GameWithDeadPlayers = GameWithDeadPlayers Game+ deriving (Eq, Show)++instance Arbitrary GameWithDeadPlayers where+ arbitrary = do+ game <- arbitrary+ players' <- sublistOf $ game ^. players+ let game' = foldr killPlayer game (map (view name) players')++ return $ GameWithDeadPlayers (run_ checkStage game')+ newtype GameWithDevourEvent = GameWithDevourEvent Game deriving (Eq, Show) @@ -162,6 +226,29 @@ GameWithLynchVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ VillagesTurn) +newtype GameWithOneAllegianceAlive = GameWithOneAllegianceAlive Game+ deriving (Eq, Show)++instance Arbitrary GameWithOneAllegianceAlive where+ arbitrary = do+ game <- arbitrary+ allegiance' <- arbitrary+ let players' = filter ((allegiance' /=) . view (role . allegiance)) (game ^. players)+ let game' = foldr killPlayer game (map (view name) players')++ return $ GameWithOneAllegianceAlive game'++newtype GameWithPass = GameWithPass Game+ deriving (Eq, Show)++instance Arbitrary GameWithPass where+ arbitrary = do+ game <- arbitrary+ let game' = game & stage .~ WitchsTurn+ (Blind command) <- arbitraryPassCommand game'++ return $ GameWithPass (run_ (apply command) game')+ newtype GameWithPoison = GameWithPoison Game deriving (Eq, Show) @@ -189,11 +276,42 @@ instance Arbitrary GameWithProtectAndDevourVotes where arbitrary = do+ (GameWithProtectAndWolfHoundChoice game) <- arbitrary+ let game' = run_ checkStage game++ GameWithProtectAndDevourVotes <$> runArbitraryCommands (length $ game' ^. players) game'++newtype GameWithProtectAndWolfHoundChoice = GameWithProtectAndWolfHoundChoice Game+ deriving (Eq, Show)++instance Arbitrary GameWithProtectAndWolfHoundChoice where+ arbitrary = do (GameWithProtect game) <- arbitrary let game' = run_ checkStage game+ (Blind command) <- arbitraryChooseAllegianceCommand game' - GameWithProtectAndDevourVotes <$> runArbitraryCommands (length $ game' ^. players) game'+ return $ GameWithProtectAndWolfHoundChoice (run_ (apply command) game') +newtype GameWithRoleModel = GameWithRoleModel Game+ deriving (Eq, Show)++instance Arbitrary GameWithRoleModel where+ arbitrary = do+ (GameAtWildChildsTurn game) <- arbitrary+ (Blind command) <- arbitraryChoosePlayerCommand game+ let game' = run_ (apply command) game++ return $ GameWithRoleModel game'++newtype GameWithRoleModelAtVillagesTurn = GameWithRoleModelAtVillagesTurn Game+ deriving (Eq, Show)++instance Arbitrary GameWithRoleModelAtVillagesTurn where+ arbitrary = do+ (GameWithRoleModel game) <- arbitrary++ return $ GameWithRoleModelAtVillagesTurn (game & stage .~ VillagesTurn)+ newtype GameWithSee = GameWithSee Game deriving (Eq, Show) @@ -205,21 +323,27 @@ return $ GameWithSee (run_ (apply command) game') +newtype GameWithZeroAllegiancesAlive = GameWithZeroAllegiancesAlive Game+ deriving (Eq, Show)++instance Arbitrary GameWithZeroAllegiancesAlive where+ arbitrary = do+ game <- arbitrary+ let game' = foldr killPlayer game (map (view name) (game ^. players))++ return $ GameWithZeroAllegiancesAlive game'+ arbitraryPlayerSet :: Gen [Player] arbitraryPlayerSet = do- n <- choose (10, 24)+ n <- choose (14, 24) players <- nubOn (view name) <$> infiniteList - let defender = head $ filterDefenders players- let scapegoat = head $ filterScapegoats players- let seer = head $ filterSeers players- let villagerVillager = head $ filterVillagerVillagers players- let witch = head $ filterWitches players+ let playersWithRestrictedRole = map (\role -> head $ filterByRole role players) restrictedRoles - let werewolves = take (n `quot` 6 + 1) $ filterWerewolves players- let villagers = take (n - 5 - (length werewolves)) $ filterVillagers players+ let simpleWerewolves = take (n `quot` 6 + 1) $ filter isSimpleWerewolf players+ let simpleVillagers = take (n - length restrictedRoles - length simpleWerewolves) $ filter isSimpleVillager players - return $ defender:scapegoat:seer:villagerVillager:witch:werewolves ++ villagers+ return $ playersWithRestrictedRole ++ simpleVillagers ++ simpleWerewolves arbitraryCommand :: Game -> Gen (Blind Command) arbitraryCommand game = case game ^. stage of@@ -228,37 +352,33 @@ Sunrise -> return $ Blind noopCommand Sunset -> return $ Blind noopCommand SeersTurn -> arbitrarySeeCommand game- VillagesTurn -> arbitraryLynchVoteCommand game- WerewolvesTurn -> arbitraryDevourVoteCommand game+ VillagesTurn -> arbitraryVoteLynchCommand game+ WerewolvesTurn -> arbitraryVoteDevourCommand game+ WildChildsTurn -> arbitraryChoosePlayerCommand game WitchsTurn -> oneof [ arbitraryHealCommand game, arbitraryPassCommand game, arbitraryPoisonCommand game ]+ WolfHoundsTurn -> arbitraryChooseAllegianceCommand game -arbitraryDevourVoteCommand :: Game -> Gen (Blind Command)-arbitraryDevourVoteCommand game = do- let applicableCallers = filterWerewolves $ getPendingVoters game- target <- suchThat (arbitraryPlayer game) $ not . isWerewolf+arbitraryChooseAllegianceCommand :: Game -> Gen (Blind Command)+arbitraryChooseAllegianceCommand game = do+ let wolfHound = findByRole_ wolfHoundRole (game ^. players)+ allegianceName <- elements $ map (T.pack . show) [Villagers, Werewolves] - if null applicableCallers- then return $ Blind noopCommand- else elements applicableCallers >>= \caller ->- return . Blind $ devourVoteCommand (caller ^. name) (target ^. name)+ return . Blind $ chooseAllegianceCommand (wolfHound ^. name) allegianceName -arbitraryLynchVoteCommand :: Game -> Gen (Blind Command)-arbitraryLynchVoteCommand game = do- let applicableCallers = getPendingVoters game- target <- arbitraryPlayer game+arbitraryChoosePlayerCommand :: Game -> Gen (Blind Command)+arbitraryChoosePlayerCommand game = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ target <- suchThat (arbitraryPlayer game) (wildChild /=) - if null applicableCallers- then return $ Blind noopCommand- else elements applicableCallers >>= \caller ->- return . Blind $ lynchVoteCommand (caller ^. name) (target ^. name)+ return . Blind $ choosePlayerCommand (wildChild ^. name) (target ^. name) arbitraryHealCommand :: Game -> Gen (Blind Command) arbitraryHealCommand game = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) return $ if game ^. healUsed then Blind noopCommand@@ -266,13 +386,13 @@ arbitraryPassCommand :: Game -> Gen (Blind Command) arbitraryPassCommand game = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) return . Blind $ passCommand (witch ^. name) arbitraryPoisonCommand :: Game -> Gen (Blind Command) arbitraryPoisonCommand game = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) target <- arbitraryPlayer game return $ if isJust (game ^. poison)@@ -281,8 +401,8 @@ arbitraryProtectCommand :: Game -> Gen (Blind Command) arbitraryProtectCommand game = do- let defender = head . filterDefenders $ game ^. players- -- TODO (hjw): suchThat (/= priorProtect)+ let defender = findByRole_ defenderRole (game ^. players)+ -- TODO (hjw): add suchThat (/= priorProtect) target <- suchThat (arbitraryPlayer game) (defender /=) return $ if isJust (game ^. protect)@@ -300,12 +420,32 @@ arbitrarySeeCommand :: Game -> Gen (Blind Command) arbitrarySeeCommand game = do- let seer = head . filterSeers $ game ^. players+ let seer = findByRole_ seerRole (game ^. players) target <- arbitraryPlayer game return $ if isJust (game ^. see) then Blind noopCommand else Blind $ seeCommand (seer ^. name) (target ^. name)++arbitraryVoteDevourCommand :: Game -> Gen (Blind Command)+arbitraryVoteDevourCommand game = do+ let applicableCallers = filterWerewolves $ getPendingVoters game+ target <- suchThat (arbitraryPlayer game) $ not . isWerewolf++ if null applicableCallers+ then return $ Blind noopCommand+ else elements applicableCallers >>= \caller ->+ return . Blind $ voteDevourCommand (caller ^. name) (target ^. name)++arbitraryVoteLynchCommand :: Game -> Gen (Blind Command)+arbitraryVoteLynchCommand game = do+ let applicableCallers = getPendingVoters game+ target <- arbitraryPlayer game++ if null applicableCallers+ then return $ Blind noopCommand+ else elements applicableCallers >>= \caller ->+ return . Blind $ voteLynchCommand (caller ^. name) (target ^. name) runArbitraryCommands :: Int -> Game -> Gen Game runArbitraryCommands n = iterateM n $ \game -> do
test/src/Game/Werewolf/Test/Command.hs view
@@ -6,66 +6,11 @@ -} {-# OPTIONS_HADDOCK hide, prune #-}+{-# LANGUAGE OverloadedStrings #-} module Game.Werewolf.Test.Command (- -- * devourVoteCommand- prop_devourVoteCommandErrorsWhenGameIsOver, prop_devourVoteCommandErrorsWhenCallerDoesNotExist,- prop_devourVoteCommandErrorsWhenTargetDoesNotExist,- prop_devourVoteCommandErrorsWhenCallerIsDead, prop_devourVoteCommandErrorsWhenTargetIsDead,- prop_devourVoteCommandErrorsWhenNotWerewolvesTurn,- prop_devourVoteCommandErrorsWhenCallerNotWerewolf,- 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,-- -- * protectCommand- prop_protectCommandErrorsWhenGameIsOver, prop_protectCommandErrorsWhenCallerDoesNotExist,- prop_protectCommandErrorsWhenTargetDoesNotExist, prop_protectCommandErrorsWhenCallerIsDead,- prop_protectCommandErrorsWhenTargetIsDead, prop_protectCommandErrorsWhenNotDefendersTurn,- prop_protectCommandErrorsWhenCallerNotDefender, prop_protectCommandErrorsWhenTargetIsCaller,- prop_protectCommandErrorsWhenTargetIsPriorProtect, prop_protectCommandSetsPriorProtect,- prop_protectCommandSetsProtect,-- -- * quitCommand- prop_quitCommandErrorsWhenGameIsOver, prop_quitCommandErrorsWhenCallerDoesNotExist,- prop_quitCommandErrorsWhenCallerIsDead, prop_quitCommandKillsPlayer,- prop_quitCommandClearsHealWhenCallerIsWitch, prop_quitCommandClearsHealUsedWhenCallerIsWitch,- prop_quitCommandClearsPoisonWhenCallerIsWitch,- prop_quitCommandClearsPoisonUsedWhenCallerIsWitch,- prop_quitCommandClearsPriorProtectWhenCallerIsDefender,- prop_quitCommandClearsProtectWhenCallerIsDefender, prop_quitCommandClearsPlayersDevourVote,- prop_quitCommandClearsPlayersLynchVote,-- -- * seeCommand- prop_seeCommandErrorsWhenGameIsOver, prop_seeCommandErrorsWhenCallerDoesNotExist,- prop_seeCommandErrorsWhenTargetDoesNotExist, prop_seeCommandErrorsWhenCallerIsDead,- prop_seeCommandErrorsWhenTargetIsDead, prop_seeCommandErrorsWhenNotSeersTurn,- prop_seeCommandErrorsWhenCallerNotSeer, prop_seeCommandSetsSee,+ -- * Tests+ allCommandTests, ) where import Control.Lens hiding (elements)@@ -73,90 +18,253 @@ import Data.Either.Extra import qualified Data.Map as Map import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T import Game.Werewolf.Command import Game.Werewolf.Game import Game.Werewolf.Player+import Game.Werewolf.Role hiding (name) import Game.Werewolf.Test.Arbitrary import Game.Werewolf.Test.Util -import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck -prop_devourVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_devourVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game . getBlind+allCommandTests :: [TestTree]+allCommandTests =+ [ testProperty "choose allegiance command errors when game is over" prop_chooseAllegianceCommandErrorsWhenGameIsOver+ , testProperty "choose allegiance command errors when caller does not exist" prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist+ , testProperty "choose allegiance command errors when caller is dead" prop_chooseAllegianceCommandErrorsWhenCallerIsDead+ , testProperty "choose allegiance command errors when not wolf-hound's turn" prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn+ , testProperty "choose allegiance command errors when caller not wolf-hound" prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound+ , testProperty "choose allegiance command errors when allegiance does not exist" prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist+ , testProperty "choose allegiance command sets caller's role" prop_chooseAllegianceCommandSetsCallersRole -prop_devourVoteCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property-prop_devourVoteCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller =+ , testProperty "choose player command errors when game is over" prop_choosePlayerCommandErrorsWhenGameIsOver+ , testProperty "choose player command errors when caller does not exist" prop_choosePlayerCommandErrorsWhenCallerDoesNotExist+ , testProperty "choose player command errors when target does not exist" prop_choosePlayerCommandErrorsWhenTargetDoesNotExist+ , testProperty "choose player command errors when caller is dead" prop_choosePlayerCommandErrorsWhenCallerIsDead+ , testProperty "choose player command errors when target is dead" prop_choosePlayerCommandErrorsWhenTargetIsDead+ , testProperty "choose player command errors when target is caller" prop_choosePlayerCommandErrorsWhenTargetIsCaller+ , testProperty "choose player command errors when not wild-child's turn" prop_choosePlayerCommandErrorsWhenNotWildChildsTurn+ , testProperty "choose player command errors when caller not wild-child" prop_choosePlayerCommandErrorsWhenCallerNotWildChild+ , testProperty "choose player command sets role model" prop_choosePlayerCommandSetsRoleModel++ , testProperty "heal command errors when game is over" prop_healCommandErrorsWhenGameIsOver+ , testProperty "heal command errors when caller does not exist" prop_healCommandErrorsWhenCallerDoesNotExist+ , testProperty "heal command errors when caller is dead" prop_healCommandErrorsWhenCallerIsDead+ , testProperty "heal command errors when no target is devoured" prop_healCommandErrorsWhenNoTargetIsDevoured+ , testProperty "heal command errors when not witch's turn" prop_healCommandErrorsWhenNotWitchsTurn+ , testProperty "heal command errors when caller has healed" prop_healCommandErrorsWhenCallerHasHealed+ , testProperty "heal command errors when caller not witch" prop_healCommandErrorsWhenCallerNotWitch+ , testProperty "heal command sets heal" prop_healCommandSetsHeal+ , testProperty "heal command sets heal used" prop_healCommandSetsHealUsed++ , testProperty "pass command errors when game is over" prop_passCommandErrorsWhenGameIsOver+ , testProperty "pass command errors when caller does not exist" prop_passCommandErrorsWhenCallerDoesNotExist+ , testProperty "pass command errors when caller is dead" prop_passCommandErrorsWhenCallerIsDead+ , testProperty "pass command errors when not witch's turn" prop_passCommandErrorsWhenNotWitchsTurn+ , testProperty "pass command updates passes" prop_passCommandUpdatesPasses++ , testProperty "poison command errors when game is over" prop_poisonCommandErrorsWhenGameIsOver+ , testProperty "poison command errors when caller does not exist" prop_poisonCommandErrorsWhenCallerDoesNotExist+ , testProperty "poison command errors when target does not exist" prop_poisonCommandErrorsWhenTargetDoesNotExist+ , testProperty "poison command errors when caller is dead" prop_poisonCommandErrorsWhenCallerIsDead+ , testProperty "poison command errors when target is dead" prop_poisonCommandErrorsWhenTargetIsDead+ , testProperty "poison command errors when target is devoured" prop_poisonCommandErrorsWhenTargetIsDevoured+ , testProperty "poison command errors when not witch's turn" prop_poisonCommandErrorsWhenNotWitchsTurn+ , testProperty "poison command errors when caller has poisoned" prop_poisonCommandErrorsWhenCallerHasPoisoned+ , testProperty "poison command errors when caller not witch" prop_poisonCommandErrorsWhenCallerNotWitch+ -- TODO (hjw): implement this test case+ --, testProperty "poison command errors when caller devoured and not healed" prop_poisonCommandErrorsWhenCallerDevouredAndNotHealed+ , testProperty "poison command sets poison" prop_poisonCommandSetsPoison+ , testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed++ , testProperty "protect command errors when game is over" prop_protectCommandErrorsWhenGameIsOver+ , testProperty "protect command errors when caller does not exist" prop_protectCommandErrorsWhenCallerDoesNotExist+ , testProperty "protect command errors when target does not exist" prop_protectCommandErrorsWhenTargetDoesNotExist+ , testProperty "protect command errors when caller is dead" prop_protectCommandErrorsWhenCallerIsDead+ , testProperty "protect command errors when target is dead" prop_protectCommandErrorsWhenTargetIsDead+ , testProperty "protect command errors when not defender's turn" prop_protectCommandErrorsWhenNotDefendersTurn+ , testProperty "protect command errors when caller not defender" prop_protectCommandErrorsWhenCallerNotDefender+ , testProperty "protect command errors when target is caller" prop_protectCommandErrorsWhenTargetIsCaller+ , testProperty "protect command errors when target is prior protect" prop_protectCommandErrorsWhenTargetIsPriorProtect+ , testProperty "protect command sets prior protect" prop_protectCommandSetsPriorProtect+ , testProperty "protect command sets protect" prop_protectCommandSetsProtect++ , testProperty "quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver+ , testProperty "quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist+ , testProperty "quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead+ , testProperty "quit command kills player" prop_quitCommandKillsPlayer+ , testProperty "quit command clears heal when caller is witch" prop_quitCommandClearsHealWhenCallerIsWitch+ , testProperty "quit command clears heal used when caller is witch" prop_quitCommandClearsHealUsedWhenCallerIsWitch+ , testProperty "quit command clears poison when caller is witch" prop_quitCommandClearsPoisonWhenCallerIsWitch+ , testProperty "quit command clears poison used when caller is witch" prop_quitCommandClearsPoisonUsedWhenCallerIsWitch+ , testProperty "quit command clears prior protect when caller is defender" prop_quitCommandClearsPriorProtectWhenCallerIsDefender+ , testProperty "quit command clears protect when caller is defender" prop_quitCommandClearsProtectWhenCallerIsDefender+ , testProperty "quit command clears player's devour vote" prop_quitCommandClearsPlayersDevourVote+ , testProperty "quit command clears player's lynch vote" prop_quitCommandClearsPlayersLynchVote+ , testProperty "quit command clears role model when caller is wild-child" prop_quitCommandClearsRoleModelWhenCallerIsWildChild+ , testProperty "quit command sets angel's role when caller is angel" prop_quitCommandSetsAngelsRoleWhenCallerIsAngel++ , testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver+ , testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist+ , testProperty "see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist+ , testProperty "see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead+ , testProperty "see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead+ , testProperty "see command errors when not seer's turn" prop_seeCommandErrorsWhenNotSeersTurn+ , testProperty "see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer+ , testProperty "see command sets see" prop_seeCommandSetsSee++ , testProperty "vote devour command errors when game is over" prop_voteDevourCommandErrorsWhenGameIsOver+ , testProperty "vote devour command errors when caller does not exist" prop_voteDevourCommandErrorsWhenCallerDoesNotExist+ , testProperty "vote devour command errors when target does not exist" prop_voteDevourCommandErrorsWhenTargetDoesNotExist+ , testProperty "vote devour command errors when caller is dead" prop_voteDevourCommandErrorsWhenCallerIsDead+ , testProperty "vote devour command errors when target is dead" prop_voteDevourCommandErrorsWhenTargetIsDead+ , testProperty "vote devour command errors when not werewolves turn" prop_voteDevourCommandErrorsWhenNotWerewolvesTurn+ , testProperty "vote devour command errors when caller not werewolf" prop_voteDevourCommandErrorsWhenCallerNotWerewolf+ , testProperty "vote devour command errors when caller has voted" prop_voteDevourCommandErrorsWhenCallerHasVoted+ , testProperty "vote devour command errors when target werewolf" prop_voteDevourCommandErrorsWhenTargetWerewolf+ , testProperty "vote devour command updates votes" prop_voteDevourCommandUpdatesVotes++ , testProperty "vote lynch command errors when game is over" prop_voteLynchCommandErrorsWhenGameIsOver+ , testProperty "vote lynch command errors when caller does not exist" prop_voteLynchCommandErrorsWhenCallerDoesNotExist+ , testProperty "vote lynch command errors when target does not exist" prop_voteLynchCommandErrorsWhenTargetDoesNotExist+ , testProperty "vote lynch command errors when caller is dead" prop_voteLynchCommandErrorsWhenCallerIsDead+ , testProperty "vote lynch command errors when target is dead" prop_voteLynchCommandErrorsWhenTargetIsDead+ , testProperty "vote lynch command errors when not villages turn" prop_voteLynchCommandErrorsWhenNotVillagesTurn+ , testProperty "vote lynch command errors when caller has voted" prop_voteLynchCommandErrorsWhenCallerHasVoted+ , testProperty "vote lynch command updates votes" prop_voteLynchCommandUpdatesVotes+ ]++prop_chooseAllegianceCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_chooseAllegianceCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryChooseAllegianceCommand game) $ verbose_runCommandErrors game . getBlind++prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist :: GameAtWolfHoundsTurn -> Player -> Allegiance -> Property+prop_chooseAllegianceCommandErrorsWhenCallerDoesNotExist (GameAtWolfHoundsTurn game) caller allegiance = do+ let command = chooseAllegianceCommand (caller ^. name) (T.pack $ show allegiance)+ not (doesPlayerExist (caller ^. name) (game ^. players))- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = devourVoteCommand (caller ^. name) (target ^. name)+ ==> verbose_runCommandErrors game command - verbose_runCommandErrors game command+prop_chooseAllegianceCommandErrorsWhenCallerIsDead :: GameAtWolfHoundsTurn -> Allegiance -> Property+prop_chooseAllegianceCommandErrorsWhenCallerIsDead (GameAtWolfHoundsTurn game) allegiance = do+ let wolfHound = findByRole_ wolfHoundRole (game ^. players)+ let game' = killPlayer (wolfHound ^. name) game+ let command = chooseAllegianceCommand (wolfHound ^. name) (T.pack $ show allegiance) -prop_devourVoteCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property-prop_devourVoteCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target =- not (doesPlayerExist (target ^. name) (game ^. players))- ==> forAll (arbitraryWerewolf game) $ \caller -> do- let command = devourVoteCommand (caller ^. name) (target ^. name)+ verbose_runCommandErrors game' command +prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn :: Game -> Property+prop_chooseAllegianceCommandErrorsWhenNotWolfHoundsTurn game =+ not (isWolfHoundsTurn game)+ ==> forAll (arbitraryChooseAllegianceCommand game) $ verbose_runCommandErrors game . getBlind++prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound :: GameAtWolfHoundsTurn -> Allegiance -> Property+prop_chooseAllegianceCommandErrorsWhenCallerNotWolfHound (GameAtWolfHoundsTurn game) allegiance =+ forAll (suchThat (arbitraryPlayer game) (not . isWolfHound)) $ \caller -> do+ let command = chooseAllegianceCommand (caller ^. name) (T.pack $ show allegiance)+ verbose_runCommandErrors game command -prop_devourVoteCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property-prop_devourVoteCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) =- forAll (arbitraryWerewolf game) $ \caller ->+prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist :: GameAtWolfHoundsTurn -> Text -> Property+prop_chooseAllegianceCommandErrorsWhenAllegianceDoesNotExist (GameAtWolfHoundsTurn game) allegiance = do+ let wolfHound = findByRole_ wolfHoundRole (game ^. players)+ let command = chooseAllegianceCommand (wolfHound ^. name) allegiance++ allegiance `notElem` ["Villagers", "Werewolves"]+ ==> verbose_runCommandErrors game command++prop_chooseAllegianceCommandSetsCallersRole :: GameAtWolfHoundsTurn -> Property+prop_chooseAllegianceCommandSetsCallersRole (GameAtWolfHoundsTurn game) = do+ let wolfHound = findByRole_ wolfHoundRole (game ^. players)++ forAll (elements [Villagers, Werewolves]) $ \allegiance' -> do+ let command = chooseAllegianceCommand (wolfHound ^. name) (T.pack $ show allegiance')+ let game' = run_ (apply command) game++ findByName_ (wolfHound ^. name) (game' ^. players) ^. role === roleForAllegiance allegiance'+ where+ roleForAllegiance allegiance = case allegiance of+ Villagers -> simpleVillagerRole+ Werewolves -> simpleWerewolfRole+ _ -> undefined++prop_choosePlayerCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_choosePlayerCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryChoosePlayerCommand game) $ verbose_runCommandErrors game . getBlind++prop_choosePlayerCommandErrorsWhenCallerDoesNotExist :: GameAtWildChildsTurn -> Player -> Property+prop_choosePlayerCommandErrorsWhenCallerDoesNotExist (GameAtWildChildsTurn game) caller = forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game caller- let command = devourVoteCommand (caller ^. name) (target ^. name)+ let command = choosePlayerCommand (caller ^. name) (target ^. name) + not (doesPlayerExist (caller ^. name) (game ^. players))+ ==> verbose_runCommandErrors game command++prop_choosePlayerCommandErrorsWhenTargetDoesNotExist :: GameAtWildChildsTurn -> Player -> Property+prop_choosePlayerCommandErrorsWhenTargetDoesNotExist (GameAtWildChildsTurn game) target = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)++ not (doesPlayerExist (target ^. name) (game ^. players))+ ==> verbose_runCommandErrors game command++prop_choosePlayerCommandErrorsWhenCallerIsDead :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenCallerIsDead (GameAtWildChildsTurn game) = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ let game' = killPlayer (wildChild ^. name) game++ forAll (arbitraryPlayer game') $ \target -> do+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)+ verbose_runCommandErrors game' command -prop_devourVoteCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property-prop_devourVoteCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) =- forAll (arbitraryWerewolf game) $ \caller ->+prop_choosePlayerCommandErrorsWhenTargetIsDead :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenTargetIsDead (GameAtWildChildsTurn game) = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game target- let command = devourVoteCommand (caller ^. name) (target ^. name)+ let game' = killPlayer (target ^. name) game+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name) verbose_runCommandErrors game' command -prop_devourVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property-prop_devourVoteCommandErrorsWhenNotWerewolvesTurn game =- not (isWerewolvesTurn game)- ==> forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game . getBlind+prop_choosePlayerCommandErrorsWhenTargetIsCaller :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenTargetIsCaller (GameAtWildChildsTurn game) = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ let command = choosePlayerCommand (wildChild ^. name) (wildChild ^. name) -prop_devourVoteCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property-prop_devourVoteCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) =- forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = devourVoteCommand (caller ^. name) (target ^. name)+ verbose_runCommandErrors game command - verbose_runCommandErrors game command+prop_choosePlayerCommandErrorsWhenNotWildChildsTurn :: Game -> Property+prop_choosePlayerCommandErrorsWhenNotWildChildsTurn game =+ not (isWildChildsTurn game)+ ==> forAll (arbitraryChoosePlayerCommand game) $ verbose_runCommandErrors game . getBlind -prop_devourVoteCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property-prop_devourVoteCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) =- forAll (arbitraryWerewolf game) $ \caller ->- forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \target -> do- let command = devourVoteCommand (caller ^. name) (target ^. name)+prop_choosePlayerCommandErrorsWhenCallerNotWildChild :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandErrorsWhenCallerNotWildChild (GameAtWildChildsTurn game) =+ forAll (suchThat (arbitraryPlayer game) (not . isWildChild)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = choosePlayerCommand (caller ^. name) (target ^. name) verbose_runCommandErrors game command -prop_devourVoteCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property-prop_devourVoteCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) =- forAll (suchThat (arbitraryPlayer game) isWerewolf) $ \target ->- forAll (arbitraryPlayer game) $ \caller ->- verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))+prop_choosePlayerCommandSetsRoleModel :: GameAtWildChildsTurn -> Property+prop_choosePlayerCommandSetsRoleModel (GameAtWildChildsTurn game) = do+ let wildChild = findByRole_ wildChildRole (game ^. players) -prop_devourVoteCommandUpdatesVotes :: GameAtWerewolvesTurn -> Property-prop_devourVoteCommandUpdatesVotes (GameAtWerewolvesTurn game) =- forAll (arbitraryDevourVoteCommand game) $ \(Blind command) -> do- let game' = run_ (apply command) game+ forAll (suchThat (arbitraryPlayer game) (not . isWildChild)) $ \target -> do+ let command = choosePlayerCommand (wildChild ^. name) (target ^. name)+ let game' = run_ (apply command) game - Map.size (game' ^. votes) == 1+ fromJust (game' ^. roleModel) === target ^. name prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = healCommand $ witch ^. name verbose_runCommandErrors game command@@ -169,28 +277,28 @@ prop_healCommandErrorsWhenCallerIsDead :: GameWithDevourEvent -> Property prop_healCommandErrorsWhenCallerIsDead (GameWithDevourEvent game) = forAll (arbitraryPlayer game) $ \caller -> do- let game' = killPlayer game caller+ let game' = killPlayer (caller ^. name) game let command = healCommand (caller ^. name) verbose_runCommandErrors game' command prop_healCommandErrorsWhenNoTargetIsDevoured :: GameAtWitchsTurn -> Property prop_healCommandErrorsWhenNoTargetIsDevoured (GameAtWitchsTurn game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = healCommand $ witch ^. name verbose_runCommandErrors game command prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property prop_healCommandErrorsWhenNotWitchsTurn game = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = healCommand $ witch ^. name not (isWitchsTurn game) ==> verbose_runCommandErrors game command prop_healCommandErrorsWhenCallerHasHealed :: GameWithHeal -> Property prop_healCommandErrorsWhenCallerHasHealed (GameWithHeal game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = healCommand $ witch ^. name verbose_runCommandErrors game command@@ -212,64 +320,6 @@ forAll (arbitraryHealCommand game) $ \(Blind command) -> (run_ (apply command) game) ^. healUsed -prop_lynchVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property-prop_lynchVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) =- forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game . getBlind--prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property-prop_lynchVoteCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller =- not (doesPlayerExist (caller ^. name) (game ^. players))- ==> forAll (arbitraryPlayer game) $ \target -> do- let command = lynchVoteCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_lynchVoteCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property-prop_lynchVoteCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target =- not (doesPlayerExist (target ^. name) (game ^. players))- ==> forAll (arbitraryPlayer game) $ \caller -> do- let command = lynchVoteCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_lynchVoteCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property-prop_lynchVoteCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game caller- let command = lynchVoteCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_lynchVoteCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property-prop_lynchVoteCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game target- let command = lynchVoteCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game' command--prop_lynchVoteCommandErrorsWhenNotVillagesTurn :: Game -> Property-prop_lynchVoteCommandErrorsWhenNotVillagesTurn game =- not (isVillagesTurn game)- ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game . getBlind--prop_lynchVoteCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property-prop_lynchVoteCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) =- forAll (arbitraryPlayer game) $ \caller ->- forAll (arbitraryPlayer game) $ \target -> do- let command = lynchVoteCommand (caller ^. name) (target ^. name)-- verbose_runCommandErrors game command--prop_lynchVoteCommandUpdatesVotes :: GameAtVillagesTurn -> Property-prop_lynchVoteCommandUpdatesVotes (GameAtVillagesTurn game) =- forAll (arbitraryLynchVoteCommand game) $ \(Blind command) -> do- let game' = run_ (apply command) game-- Map.size (game' ^. votes) == 1- prop_passCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property prop_passCommandErrorsWhenGameIsOver (GameAtGameOver game) = forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind@@ -282,7 +332,7 @@ prop_passCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property prop_passCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = forAll (arbitraryPlayer game) $ \caller -> do- let game' = killPlayer game caller+ let game' = killPlayer (caller ^. name) game let command = passCommand (caller ^. name) verbose_runCommandErrors game' command@@ -313,7 +363,7 @@ prop_poisonCommandErrorsWhenTargetDoesNotExist :: GameAtWitchsTurn -> Player -> Property prop_poisonCommandErrorsWhenTargetDoesNotExist (GameAtWitchsTurn game) target = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = poisonCommand (witch ^. name) (target ^. name) not (doesPlayerExist (target ^. name) (game ^. players))@@ -321,20 +371,20 @@ prop_poisonCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property prop_poisonCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game witch+ let game' = killPlayer (witch ^. name) game let command = poisonCommand (witch ^. name) (target ^. name) verbose_runCommandErrors game' command prop_poisonCommandErrorsWhenTargetIsDead :: GameAtWitchsTurn -> Property prop_poisonCommandErrorsWhenTargetIsDead (GameAtWitchsTurn game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game target+ let game' = killPlayer (target ^. name) game let command = poisonCommand (witch ^. name) (target ^. name) verbose_runCommandErrors game' command@@ -343,7 +393,7 @@ prop_poisonCommandErrorsWhenTargetIsDevoured (GameWithDevourEvent game) = do let (DevourEvent targetName) = fromJust $ getDevourEvent game - let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = poisonCommand (witch ^. name) targetName verbose_runCommandErrors game command@@ -355,7 +405,7 @@ prop_poisonCommandErrorsWhenCallerHasPoisoned :: GameWithPoison -> Property prop_poisonCommandErrorsWhenCallerHasPoisoned (GameWithPoison game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) forAll (arbitraryPlayer game) $ \target -> do let command = poisonCommand (witch ^. name) (target ^. name)@@ -394,7 +444,7 @@ prop_protectCommandErrorsWhenTargetDoesNotExist :: GameAtDefendersTurn -> Player -> Property prop_protectCommandErrorsWhenTargetDoesNotExist (GameAtDefendersTurn game) target = do- let defender = head . filterDefenders $ game ^. players+ let defender = findByRole_ defenderRole (game ^. players) let command = protectCommand (defender ^. name) (target ^. name) not (doesPlayerExist (target ^. name) (game ^. players))@@ -402,8 +452,8 @@ prop_protectCommandErrorsWhenCallerIsDead :: GameAtDefendersTurn -> Property prop_protectCommandErrorsWhenCallerIsDead (GameAtDefendersTurn game) = do- let defender = head . filterDefenders $ game ^. players- let game' = killPlayer game defender+ let defender = findByRole_ defenderRole (game ^. players)+ let game' = killPlayer (defender ^. name) game forAll (arbitraryPlayer game') $ \target -> do let command = protectCommand (defender ^. name) (target ^. name)@@ -412,10 +462,10 @@ prop_protectCommandErrorsWhenTargetIsDead :: GameAtDefendersTurn -> Property prop_protectCommandErrorsWhenTargetIsDead (GameAtDefendersTurn game) = do- let defender = head . filterDefenders $ game ^. players+ let defender = findByRole_ defenderRole (game ^. players) forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game target+ let game' = killPlayer (target ^. name) game let command = protectCommand (defender ^. name) (target ^. name) verbose_runCommandErrors game' command@@ -435,7 +485,7 @@ prop_protectCommandErrorsWhenTargetIsCaller :: GameAtDefendersTurn -> Property prop_protectCommandErrorsWhenTargetIsCaller (GameAtDefendersTurn game) = do- let defender = head . filterDefenders $ game ^. players+ let defender = findByRole_ defenderRole (game ^. players) let command = protectCommand (defender ^. name) (defender ^. name) verbose_runCommandErrors game command@@ -444,7 +494,7 @@ prop_protectCommandErrorsWhenTargetIsPriorProtect (GameWithProtect game) = do let game' = game & protect .~ Nothing - let defender = head . filterDefenders $ game' ^. players+ let defender = findByRole_ defenderRole (game' ^. players) let command = protectCommand (defender ^. name) (fromJust $ game' ^. priorProtect) verbose_runCommandErrors game' command@@ -471,7 +521,7 @@ prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property prop_quitCommandErrorsWhenCallerIsDead game = forAll (arbitraryPlayer game) $ \caller -> do- let game' = killPlayer game caller+ let game' = killPlayer (caller ^. name) game let command = quitCommand $ caller ^. name verbose_runCommandErrors game' command@@ -486,42 +536,42 @@ prop_quitCommandClearsHealWhenCallerIsWitch :: GameWithHeal -> Bool prop_quitCommandClearsHealWhenCallerIsWitch (GameWithHeal game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = quitCommand (witch ^. name) not $ run_ (apply command) game ^. heal prop_quitCommandClearsHealUsedWhenCallerIsWitch :: GameWithHeal -> Bool prop_quitCommandClearsHealUsedWhenCallerIsWitch (GameWithHeal game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = quitCommand (witch ^. name) not $ run_ (apply command) game ^. healUsed prop_quitCommandClearsPoisonWhenCallerIsWitch :: GameWithPoison -> Bool prop_quitCommandClearsPoisonWhenCallerIsWitch (GameWithPoison game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = quitCommand (witch ^. name) isNothing $ run_ (apply command) game ^. poison prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: GameWithPoison -> Bool prop_quitCommandClearsPoisonUsedWhenCallerIsWitch (GameWithPoison game) = do- let witch = head . filterWitches $ game ^. players+ let witch = findByRole_ witchRole (game ^. players) let command = quitCommand (witch ^. name) not $ run_ (apply command) game ^. poisonUsed prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: GameWithProtect -> Bool prop_quitCommandClearsPriorProtectWhenCallerIsDefender (GameWithProtect game) = do- let defender = head . filterDefenders $ game ^. players+ let defender = findByRole_ defenderRole (game ^. players) let command = quitCommand (defender ^. name) isNothing $ run_ (apply command) game ^. priorProtect prop_quitCommandClearsProtectWhenCallerIsDefender :: GameWithProtect -> Bool prop_quitCommandClearsProtectWhenCallerIsDefender (GameWithProtect game) = do- let defender = head . filterDefenders $ game ^. players+ let defender = findByRole_ defenderRole (game ^. players) let command = quitCommand (defender ^. name) isNothing $ run_ (apply command) game ^. protect@@ -540,6 +590,20 @@ isNothing $ run_ (apply command) game ^. votes . at (caller ^. name) +prop_quitCommandClearsRoleModelWhenCallerIsWildChild :: GameWithRoleModel -> Bool+prop_quitCommandClearsRoleModelWhenCallerIsWildChild (GameWithRoleModel game) = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ let command = quitCommand (wildChild ^. name)++ isNothing $ run_ (apply command) game ^. roleModel++prop_quitCommandSetsAngelsRoleWhenCallerIsAngel :: Game -> Bool+prop_quitCommandSetsAngelsRoleWhenCallerIsAngel game = do+ let angel = findByRole_ angelRole (game ^. players)+ let command = quitCommand (angel ^. name)++ isSimpleVillager $ findByName_ (angel ^. name) (run_ (apply command) game ^. players)+ prop_seeCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property prop_seeCommandErrorsWhenGameIsOver (GameAtGameOver game) = forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind@@ -554,7 +618,7 @@ prop_seeCommandErrorsWhenTargetDoesNotExist :: GameAtSeersTurn -> Player -> Property prop_seeCommandErrorsWhenTargetDoesNotExist (GameAtSeersTurn game) target = do- let seer = head . filterSeers $ game ^. players+ let seer = findByRole_ seerRole (game ^. players) let command = seeCommand (seer ^. name) (target ^. name) not (doesPlayerExist (target ^. name) (game ^. players))@@ -562,8 +626,8 @@ prop_seeCommandErrorsWhenCallerIsDead :: GameAtSeersTurn -> Property prop_seeCommandErrorsWhenCallerIsDead (GameAtSeersTurn game) = do- let seer = head . filterSeers $ game ^. players- let game' = killPlayer game seer+ let seer = findByRole_ seerRole (game ^. players)+ let game' = killPlayer (seer ^. name) game forAll (arbitraryPlayer game') $ \target -> do let command = seeCommand (seer ^. name) (target ^. name)@@ -572,10 +636,10 @@ prop_seeCommandErrorsWhenTargetIsDead :: GameAtSeersTurn -> Property prop_seeCommandErrorsWhenTargetIsDead (GameAtSeersTurn game) = do- let seer = head . filterSeers $ game ^. players+ let seer = findByRole_ seerRole (game ^. players) forAll (arbitraryPlayer game) $ \target -> do- let game' = killPlayer game target+ let game' = killPlayer (target ^. name) game let command = seeCommand (seer ^. name) (target ^. name) verbose_runCommandErrors game' command@@ -597,6 +661,136 @@ prop_seeCommandSetsSee (GameAtSeersTurn game) = forAll (arbitrarySeeCommand game) $ \(Blind command) -> isJust $ run_ (apply command) game ^. see++prop_voteDevourCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_voteDevourCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryVoteDevourCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteDevourCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property+prop_voteDevourCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller =+ not (doesPlayerExist (caller ^. name) (game ^. players))+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property+prop_voteDevourCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target =+ not (doesPlayerExist (target ^. name) (game ^. players))+ ==> forAll (arbitraryWerewolf game) $ \caller -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) =+ forAll (arbitraryWerewolf game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (caller ^. name) game+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteDevourCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) =+ forAll (arbitraryWerewolf game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteDevourCommandErrorsWhenNotWerewolvesTurn :: Game -> Property+prop_voteDevourCommandErrorsWhenNotWerewolvesTurn game =+ not (isWerewolvesTurn game)+ ==> forAll (arbitraryVoteDevourCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteDevourCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) =+ forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property+prop_voteDevourCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) =+ forAll (arbitraryWerewolf game) $ \caller ->+ forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \target -> do+ let command = voteDevourCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteDevourCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryWerewolf game) $ \target ->+ verbose_runCommandErrors game (voteDevourCommand (caller ^. name) (target ^. name))++prop_voteDevourCommandUpdatesVotes :: GameAtWerewolvesTurn -> Property+prop_voteDevourCommandUpdatesVotes (GameAtWerewolvesTurn game) =+ forAll (arbitraryVoteDevourCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ Map.size (game' ^. votes) == 1++prop_voteLynchCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_voteLynchCommandErrorsWhenGameIsOver (GameAtGameOver game) =+ forAll (arbitraryVoteLynchCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteLynchCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property+prop_voteLynchCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller =+ not (doesPlayerExist (caller ^. name) (game ^. players))+ ==> forAll (arbitraryPlayer game) $ \target -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteLynchCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property+prop_voteLynchCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target =+ not (doesPlayerExist (target ^. name) (game ^. players))+ ==> forAll (arbitraryPlayer game) $ \caller -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteLynchCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property+prop_voteLynchCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (caller ^. name) game+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteLynchCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property+prop_voteLynchCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let game' = killPlayer (target ^. name) game+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game' command++prop_voteLynchCommandErrorsWhenNotVillagesTurn :: Game -> Property+prop_voteLynchCommandErrorsWhenNotVillagesTurn game =+ not (isVillagesTurn game)+ ==> forAll (arbitraryVoteLynchCommand game) $ verbose_runCommandErrors game . getBlind++prop_voteLynchCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property+prop_voteLynchCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) =+ forAll (arbitraryPlayer game) $ \caller ->+ forAll (arbitraryPlayer game) $ \target -> do+ let command = voteLynchCommand (caller ^. name) (target ^. name)++ verbose_runCommandErrors game command++prop_voteLynchCommandUpdatesVotes :: GameAtVillagesTurn -> Property+prop_voteLynchCommandUpdatesVotes (GameAtVillagesTurn game) =+ forAll (arbitraryVoteLynchCommand game) $ \(Blind command) -> do+ let game' = run_ (apply command) game++ Map.size (game' ^. votes) == 1 verbose_runCommandErrors :: Game -> Command -> Property verbose_runCommandErrors game command = whenFail (mapM_ putStrLn data_) (isLeft result)
test/src/Game/Werewolf/Test/Engine.hs view
@@ -9,48 +9,8 @@ {-# LANGUAGE OverloadedStrings #-} module Game.Werewolf.Test.Engine (- -- * checkStage- prop_checkStageSkipsDefendersTurnWhenNoDefender, prop_checkStageSkipsSeersTurnWhenNoSeer,- prop_checkStageSkipsWitchsTurnWhenNoWitch, prop_checkStageDoesNothingWhenGameOver,-- prop_checkDefendersTurnAdvancesToWerewolvesTurn,-- prop_checkSeersTurnAdvancesToDefendersTurn, prop_checkSeersTurnResetsSee,- prop_checkSeersTurnDoesNothingUnlessSeen,-- prop_checkVillagesTurnAdvancesToSeersTurn, prop_checkVillagesTurnLynchesOnePlayerWhenConsensus,- prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats,- prop_checkVillagesTurnLynchesScapegoatWhenConflicted, prop_checkVillagesTurnResetsVotes,- prop_checkVillagesTurnDoesNothingUnlessAllVoted,-- prop_checkWerewolvesTurnAdvancesToWitchsTurn,- prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned,- prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus,- prop_checkWerewolvesTurnKillsNoOneWhenConflicted,- prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended, prop_checkWerewolvesTurnResetsProtect,- 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_startGameErrorsWhenMoreThan1Defender,- prop_startGameErrorsWhenMoreThan1Scapegoat, prop_startGameErrorsWhenMoreThan1Seer,- prop_startGameErrorsWhenMoreThan1VillagerVillager, prop_startGameErrorsWhenMoreThan1Witch,-- -- * createPlayers- prop_createPlayersUsesGivenPlayerNames, prop_createPlayersUsesGivenRoles,- prop_createPlayersCreatesAlivePlayers,-- -- * randomiseRoles- prop_randomiseRolesReturnsNRoles, prop_randomiseRolesUsesGivenRoles,- prop_randomiseRolesProportionsAllegiances,+ -- * Tests+ allEngineTests, ) where import Control.Lens hiding (elements)@@ -67,7 +27,8 @@ import Game.Werewolf.Engine hiding (doesPlayerExist, getDevourEvent, getVoteResult, isDefendersTurn, isGameOver, isSeersTurn, isVillagesTurn, isWerewolvesTurn,- isWitchsTurn, killPlayer)+ isWildChildsTurn, isWitchsTurn, isWolfHoundsTurn,+ killPlayer) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Role hiding (name)@@ -75,39 +36,165 @@ import Game.Werewolf.Test.Arbitrary import Game.Werewolf.Test.Util +import Prelude hiding (round)+ import Test.QuickCheck import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck -prop_checkStageSkipsDefendersTurnWhenNoDefender :: GameWithSee -> Bool-prop_checkStageSkipsDefendersTurnWhenNoDefender (GameWithSee game) =- not . isDefendersTurn $ run_ checkStage game'+allEngineTests :: [TestTree]+allEngineTests =+ [ testProperty "check stage skips defender's turn when no defender" prop_checkStageSkipsDefendersTurnWhenNoDefender+ , testProperty "check stage skips seer's turn when no seer" prop_checkStageSkipsSeersTurnWhenNoSeer+ , testProperty "check stage skips wild-child's turn when no wild-child" prop_checkStageSkipsWildChildsTurnWhenNoWildChild+ , testProperty "check stage skips witch's turn when no witch" prop_checkStageSkipsWitchsTurnWhenNoWitch+ , testProperty "check stage skips wolf-hound's turn when no wolf-hound" prop_checkStageSkipsWolfHoundsTurnWhenNoWolfHound+ , testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver++ , testProperty "check defender's turn advances to wolf-hound's turn" prop_checkDefendersTurnAdvancesToWolfHoundsTurn+ , testProperty "check defender's turn advances when no defender" prop_checkDefendersTurnAdvancesWhenNoDefender+ , testProperty "check defender's turn does nothing unless protected" prop_checkDefendersTurnDoesNothingUnlessProtected++ , testProperty "check seer's turn advances to wild-child's turn" prop_checkSeersTurnAdvancesToWildChildsTurn+ , testProperty "check seer's turn advances when no seer" prop_checkSeersTurnAdvancesWhenNoSeer+ , testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee+ , testProperty "check seer's turn does nothing unless seen" prop_checkSeersTurnDoesNothingUnlessSeen++ , testProperty "check sunrise increments round" prop_checkSunriseIncrementsRound+ , testProperty "check sunrise sets angel's role" prop_checkSunriseSetsAngelsRole++ , testProperty "check sunset sets wild-child's allegiance when role model dead" prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead++ , testProperty "check villages' turn advances to seer's turn" prop_checkVillagesTurnAdvancesToSeersTurn+ , testProperty "check villages' turn lynches one player when consensus" prop_checkVillagesTurnLynchesOnePlayerWhenConsensus+ , testProperty "check villages' turn lynches no one when conflicted and no scapegoats" prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats+ , testProperty "check villages' turn lynches scapegoat when conflicted" prop_checkVillagesTurnLynchesScapegoatWhenConflicted+ , testProperty "check villages' turn resets votes" prop_checkVillagesTurnResetsVotes+ , testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted++ , testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn+ , testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned+ , testProperty "check werewolves' turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus+ , testProperty "check werewolves' turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted+ , testProperty "check werewolves' turn kills no one when target defended" prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended+ , testProperty "check werewolves' turn resets protect" prop_checkWerewolvesTurnResetsProtect+ , testProperty "check werewolves' turn resets votes" prop_checkWerewolvesTurnResetsVotes+ , testProperty "check werewolves' turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted++ , testProperty "check wild-child's turn advances to defender's turn" prop_checkWildChildsTurnAdvancesToDefendersTurn+ , testProperty "check wild-child's turn advances when no wild-child" prop_checkWildChildsTurnAdvancesWhenNoWildChild+ , testProperty "check wild-child's turn does nothing unless chosen" prop_checkWildChildsTurnDoesNothingUnlessRoleModelChosen++ , testProperty "check witch's turn advances to villages' turn" prop_checkWitchsTurnAdvancesToVillagesTurn+ , testProperty "check witch's turn advances when no witch" prop_checkWitchsTurnAdvancesWhenNoWitch+ , 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 does nothing unless actioned or passed" prop_checkWitchsTurnDoesNothingUnlessActionedOrPassed+ , testProperty "check witch's turn resets heal" prop_checkWitchsTurnResetsHeal+ , testProperty "check witch's turn resets poison" prop_checkWitchsTurnResetsPoison+ , testProperty "check witch's turn clears passes" prop_checkWitchsTurnClearsPasses++ , testProperty "check wolf-hound's turn advances to werewolves' turn" prop_checkWolfHoundsTurnAdvancesToWerewolvesTurn+ , testProperty "check wolf-hound's turn advances when no wolf-hound" prop_checkWolfHoundsTurnAdvancesWhenNoWolfHound+ , testProperty "check wolf-hound's turn does nothing unless chosen" prop_checkWolfHoundsTurnDoesNothingUnlessChosen++ , testProperty "check game over advances stage when zero allegiances alive" prop_checkGameOverAdvancesStageWhenZeroAllegiancesAlive+ , testProperty "check game over advances stage when one allegiance alive" prop_checkGameOverAdvancesStageWhenOneAllegianceAlive+ -- TODO (hjw): pending+ --, testProperty "check game over does nothing when at least two allegiances alive" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive+ , testProperty "check game over advances stage when second round and angel dead" prop_checkGameOverAdvancesStageWhenSecondRoundAndAngelDead++ , 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 angel" prop_startGameErrorsWhenMoreThan1Angel+ , testProperty "start game errors when more than 1 defender" prop_startGameErrorsWhenMoreThan1Defender+ , testProperty "start game errors when more than 1 scapegoat" prop_startGameErrorsWhenMoreThan1Scapegoat+ , testProperty "start game errors when more than 1 seer" prop_startGameErrorsWhenMoreThan1Seer+ , testProperty "start game errors when more than 1 villager-villager" prop_startGameErrorsWhenMoreThan1VillagerVillager+ , testProperty "start game errors when more than 1 wild-child" prop_startGameErrorsWhenMoreThan1WildChild+ , testProperty "start game errors when more than 1 witch" prop_startGameErrorsWhenMoreThan1Witch+ , testProperty "start game errors when more than 1 wolf-hound" prop_startGameErrorsWhenMoreThan1WolfHound++ , 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+ ]++prop_checkStageSkipsDefendersTurnWhenNoDefender :: GameWithRoleModel -> Bool+prop_checkStageSkipsDefendersTurnWhenNoDefender (GameWithRoleModel game) =+ isWolfHoundsTurn $ run_ checkStage game' where- game' = foldl killPlayer game (filterDefenders $ game ^. players)+ defendersName = findByRole_ defenderRole (game ^. players) ^. name+ game' = killPlayer defendersName game -prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithLynchVotes -> Bool+prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithLynchVotes -> Property prop_checkStageSkipsSeersTurnWhenNoSeer (GameWithLynchVotes game) =- not . isSeersTurn $ run_ checkStage game'+ isAlive (findByRole_ angelRole $ run_ checkStage game' ^. players)+ ==> isWildChildsTurn game' || isDefendersTurn game' where- game' = foldl killPlayer game (filterSeers $ game ^. players)+ seersName = findByRole_ seerRole (game ^. players) ^. name+ game' = run_ (apply (quitCommand seersName) >> checkStage) game -prop_checkStageSkipsWitchsTurnWhenNoWitch :: GameWithDevourVotes -> Bool+prop_checkStageSkipsWildChildsTurnWhenNoWildChild :: GameWithSee -> Bool+prop_checkStageSkipsWildChildsTurnWhenNoWildChild (GameWithSee game) =+ isDefendersTurn $ run_ checkStage game'+ where+ wildChildsName = findByRole_ wildChildRole (game ^. players) ^. name+ game' = killPlayer wildChildsName game++prop_checkStageSkipsWitchsTurnWhenNoWitch :: GameWithDevourVotes -> Property prop_checkStageSkipsWitchsTurnWhenNoWitch (GameWithDevourVotes game) =- not . isWitchsTurn $ run_ checkStage game'+ isNothing (findByRole angelRole $ run_ checkStage game' ^. players)+ ==> isVillagesTurn $ run_ checkStage game' where- game' = foldl killPlayer game (filterWitches $ game ^. players)+ witchsName = findByRole_ witchRole (game ^. players) ^. name+ game' = killPlayer witchsName game +prop_checkStageSkipsWolfHoundsTurnWhenNoWolfHound :: GameWithProtect -> Bool+prop_checkStageSkipsWolfHoundsTurnWhenNoWolfHound (GameWithProtect game) =+ isWerewolvesTurn $ run_ checkStage game'+ where+ wolfHoundsName = findByRole_ wolfHoundRole (game ^. players) ^. name+ game' = killPlayer wolfHoundsName game+ prop_checkStageDoesNothingWhenGameOver :: GameAtGameOver -> Property prop_checkStageDoesNothingWhenGameOver (GameAtGameOver game) = run_ checkStage game === game -prop_checkDefendersTurnAdvancesToWerewolvesTurn :: GameWithProtect -> Bool-prop_checkDefendersTurnAdvancesToWerewolvesTurn (GameWithProtect game) =- isWerewolvesTurn $ run_ checkStage game+prop_checkDefendersTurnAdvancesToWolfHoundsTurn :: GameWithProtect -> Bool+prop_checkDefendersTurnAdvancesToWolfHoundsTurn (GameWithProtect game) =+ isWolfHoundsTurn $ run_ checkStage game -prop_checkSeersTurnAdvancesToDefendersTurn :: GameWithSee -> Bool-prop_checkSeersTurnAdvancesToDefendersTurn (GameWithSee game) =+prop_checkDefendersTurnAdvancesWhenNoDefender :: GameAtDefendersTurn -> Bool+prop_checkDefendersTurnAdvancesWhenNoDefender (GameAtDefendersTurn game) = do+ let defender = findByRole_ defenderRole (game ^. players)+ let game' = killPlayer (defender ^. name) game++ not . isDefendersTurn $ run_ checkStage game'++prop_checkDefendersTurnDoesNothingUnlessProtected :: GameAtDefendersTurn -> Bool+prop_checkDefendersTurnDoesNothingUnlessProtected (GameAtDefendersTurn game) = isDefendersTurn $ run_ checkStage game +prop_checkSeersTurnAdvancesToWildChildsTurn :: GameWithSee -> Bool+prop_checkSeersTurnAdvancesToWildChildsTurn (GameWithSee game) =+ isWildChildsTurn $ run_ checkStage game++prop_checkSeersTurnAdvancesWhenNoSeer :: GameAtSeersTurn -> Bool+prop_checkSeersTurnAdvancesWhenNoSeer (GameAtSeersTurn game) = do+ let seer = findByRole_ seerRole (game ^. players)+ let game' = killPlayer (seer ^. name) game++ not . isSeersTurn $ run_ checkStage game'+ prop_checkSeersTurnResetsSee :: GameWithSee -> Bool prop_checkSeersTurnResetsSee (GameWithSee game) = isNothing $ run_ checkStage game ^. see@@ -116,9 +203,29 @@ prop_checkSeersTurnDoesNothingUnlessSeen (GameAtSeersTurn game) = isSeersTurn $ run_ checkStage game +prop_checkSunriseIncrementsRound :: GameAtSunrise -> Property+prop_checkSunriseIncrementsRound (GameAtSunrise game) =+ run_ checkStage game ^. round === game ^. round + 1++prop_checkSunriseSetsAngelsRole :: GameAtSunrise -> Bool+prop_checkSunriseSetsAngelsRole (GameAtSunrise game) = do+ let angel = findByRole_ angelRole (game ^. players)+ let game' = run_ checkStage game++ isSimpleVillager $ findByName_ (angel ^. name) (game' ^. players)++prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead :: GameWithRoleModelAtVillagesTurn -> Property+prop_checkSunsetSetsWildChildsAllegianceWhenRoleModelDead (GameWithRoleModelAtVillagesTurn game) = do+ let roleModelsName = fromJust $ game ^. roleModel+ let game' = foldr (\player -> run_ (apply $ voteLynchCommand (player ^. name) roleModelsName)) game (game ^. players)++ not (isAngel $ findByName_ roleModelsName (game' ^. players))+ ==> isWerewolf $ findByRole_ wildChildRole (run_ checkStage game' ^. players)+ prop_checkVillagesTurnAdvancesToSeersTurn :: GameWithLynchVotes -> Property prop_checkVillagesTurnAdvancesToSeersTurn (GameWithLynchVotes game) =- any isSeer (filterAlive $ run_ checkStage game ^. players)+ isAlive (findByRole_ seerRole $ run_ checkStage game ^. players)+ && isAlive (findByRole_ angelRole $ run_ checkStage game ^. players) ==> isSeersTurn $ run_ checkStage game prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: GameWithLynchVotes -> Property@@ -126,20 +233,21 @@ length (getVoteResult game) == 1 ==> length (filterDead $ run_ checkStage game ^. players) == 1 --- TODO (hjw)+-- TODO (hjw): tidy this test prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats :: Game -> Property prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats game = forAll (runArbitraryCommands n game') $ \game'' -> length (getVoteResult game'') > 1 ==> length (filterDead $ run_ checkStage game'' ^. players) == length (filterDead $ game' ^. players) where- game' = foldl killPlayer game (filterScapegoats $ game ^. players) & stage .~ VillagesTurn- n = length $ game' ^. players+ scapegoatsName = findByRole_ scapegoatRole (game ^. players) ^. name+ game' = killPlayer scapegoatsName game & stage .~ VillagesTurn+ n = length $ game' ^. players prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: GameWithLynchVotes -> Property prop_checkVillagesTurnLynchesScapegoatWhenConflicted (GameWithLynchVotes game) = length (getVoteResult game) > 1- ==> isScapegoat $ head (filterDead $ run_ checkStage game ^. players)+ ==> isDead . findByRole_ scapegoatRole $ run_ checkStage game ^. players prop_checkVillagesTurnResetsVotes :: GameWithLynchVotes -> Bool prop_checkVillagesTurnResetsVotes (GameWithLynchVotes game) =@@ -196,29 +304,39 @@ where n = length (filterWerewolves $ game ^. players) - 1 +prop_checkWildChildsTurnAdvancesToDefendersTurn :: GameAtWildChildsTurn -> Property+prop_checkWildChildsTurnAdvancesToDefendersTurn (GameAtWildChildsTurn game) =+ forAll (arbitraryChoosePlayerCommand game) $ \(Blind command) ->+ isDefendersTurn $ run_ (apply command >> checkStage) game++prop_checkWildChildsTurnAdvancesWhenNoWildChild :: GameAtWildChildsTurn -> Bool+prop_checkWildChildsTurnAdvancesWhenNoWildChild (GameAtWildChildsTurn game) = do+ let wildChild = findByRole_ wildChildRole (game ^. players)+ let game' = killPlayer (wildChild ^. name) game++ not . isWildChildsTurn $ run_ checkStage game'++prop_checkWildChildsTurnDoesNothingUnlessRoleModelChosen :: GameAtWildChildsTurn -> Bool+prop_checkWildChildsTurnDoesNothingUnlessRoleModelChosen (GameAtWildChildsTurn game) =+ isWildChildsTurn $ run_ checkStage game+ prop_checkWitchsTurnAdvancesToVillagesTurn :: GameAtWitchsTurn -> Property prop_checkWitchsTurnAdvancesToVillagesTurn (GameAtWitchsTurn game) = forAll (arbitraryPassCommand game) $ \(Blind command) -> isVillagesTurn $ run_ (apply command >> checkStage) game --- TODO (hjw)-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''') $ \(Blind command) ->- forAll (arbitraryPassCommand game''') $ \(Blind passCommand) ->- null . filterDead $ run_ checkStage- (run_ (apply passCommand) $- run_ (apply command) game'''- ) ^. players- where- game' = game & stage .~ WerewolvesTurn- n = length . filterWerewolves $ game' ^. players+prop_checkWitchsTurnAdvancesWhenNoWitch :: GameAtWitchsTurn -> Bool+prop_checkWitchsTurnAdvancesWhenNoWitch (GameAtWitchsTurn game) = do+ let witch = findByRole_ witchRole (game ^. players)+ let game' = killPlayer (witch ^. name) game + not . isWitchsTurn $ run_ checkStage game'++prop_checkWitchsTurnHealsDevoureeWhenHealed :: GameWithHeal -> Property+prop_checkWitchsTurnHealsDevoureeWhenHealed (GameWithHeal game) =+ forAll (arbitraryPassCommand game) $ \(Blind command) ->+ null . filterDead $ run_ (apply command >> checkStage) game ^. players+ prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: GameWithPoison -> Property prop_checkWitchsTurnKillsOnePlayerWhenPoisoned (GameWithPoison game) = forAll (arbitraryPassCommand game) $ \(Blind command) ->@@ -229,6 +347,10 @@ forAll (arbitraryPassCommand game) $ \(Blind command) -> null . filterDead $ run_ (apply command >> checkStage) game ^. players +prop_checkWitchsTurnDoesNothingUnlessActionedOrPassed :: GameAtWitchsTurn -> Bool+prop_checkWitchsTurnDoesNothingUnlessActionedOrPassed (GameAtWitchsTurn game) =+ isWitchsTurn $ run_ checkStage game+ prop_checkWitchsTurnResetsHeal :: GameWithHeal -> Property prop_checkWitchsTurnResetsHeal (GameWithHeal game) = forAll (arbitraryPassCommand game) $ \(Blind command) ->@@ -239,28 +361,51 @@ forAll (arbitraryPassCommand game) $ \(Blind command) -> isNothing $ run_ (apply command >> checkStage) game ^. poison --- TODO (hjw)-prop_checkGameOverAdvancesStage :: Game -> Property-prop_checkGameOverAdvancesStage game =- forAll (sublistOf $ game ^. players) $ \players' ->- let game' = foldl killPlayer game players' in- length (nub . map (view $ role . allegiance) . filterAlive $ game' ^. players) <= 1- ==> isGameOver $ run_ checkGameOver game'+prop_checkWitchsTurnClearsPasses :: GameAtWitchsTurn -> Property+prop_checkWitchsTurnClearsPasses (GameAtWitchsTurn game) =+ forAll (arbitraryPassCommand game) $ \(Blind command) ->+ null $ run_ (apply command >> checkStage) game ^. passes --- TODO (hjw)-prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive :: Game -> Property-prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive game =- not (isGameOver game)- ==> forAll (sublistOf $ game ^. players) $ \players' ->- let game' = foldl killPlayer game players' in- length (nub . map (view $ role . allegiance) . filterAlive $ game' ^. players) > 1- ==> not . isGameOver $ run_ checkGameOver game'+prop_checkWolfHoundsTurnAdvancesToWerewolvesTurn :: GameAtWolfHoundsTurn -> Property+prop_checkWolfHoundsTurnAdvancesToWerewolvesTurn (GameAtWolfHoundsTurn game) =+ forAll (arbitraryChooseAllegianceCommand game) $ \(Blind command) ->+ isWerewolvesTurn $ run_ (apply command >> checkStage) game -prop_startGameStartsWithSunsetStage :: Property-prop_startGameStartsWithSunsetStage =- forAll arbitraryPlayerSet $ \players ->- isSunset (fst . fromRight . runExcept . runWriterT $ startGame "" players)+prop_checkWolfHoundsTurnAdvancesWhenNoWolfHound :: GameAtWolfHoundsTurn -> Bool+prop_checkWolfHoundsTurnAdvancesWhenNoWolfHound (GameAtWolfHoundsTurn game) = do+ let wolfHound = findByRole_ wolfHoundRole (game ^. players)+ let game' = killPlayer (wolfHound ^. name) game + not . isWolfHoundsTurn $ run_ checkStage game'++prop_checkWolfHoundsTurnDoesNothingUnlessChosen :: GameAtWolfHoundsTurn -> Bool+prop_checkWolfHoundsTurnDoesNothingUnlessChosen (GameAtWolfHoundsTurn game) =+ isWolfHoundsTurn $ run_ checkStage game++prop_checkGameOverAdvancesStageWhenZeroAllegiancesAlive :: GameWithZeroAllegiancesAlive -> Bool+prop_checkGameOverAdvancesStageWhenZeroAllegiancesAlive (GameWithZeroAllegiancesAlive game) =+ isGameOver $ run_ checkGameOver game++prop_checkGameOverAdvancesStageWhenOneAllegianceAlive :: GameWithOneAllegianceAlive -> Property+prop_checkGameOverAdvancesStageWhenOneAllegianceAlive (GameWithOneAllegianceAlive game) =+ forAll (sublistOf . filterAlive $ game ^. players) $ \players' -> do+ let game' = foldr killPlayer game (map (view name) players')++ isGameOver $ run_ checkGameOver game'++-- TODO (hjw): pending+--prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive :: GameWithDeadPlayers -> Property+--prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive (GameWithDeadPlayers game) =+-- length (nub . map (view $ role . allegiance) . filterAlive $ game ^. players) > 1+-- ==> not . isGameOver $ run_ checkGameOver game++prop_checkGameOverAdvancesStageWhenSecondRoundAndAngelDead :: GameOnSecondRound -> Bool+prop_checkGameOverAdvancesStageWhenSecondRoundAndAngelDead (GameOnSecondRound game) = do+ let angel = findByRole_ angelRole (game ^. players)+ let game' = killPlayer (angel ^. name) game++ isGameOver $ run_ checkGameOver game'+ prop_startGameUsesGivenPlayers :: Property prop_startGameUsesGivenPlayers = forAll arbitraryPlayerSet $ \players' ->@@ -284,29 +429,44 @@ length players > 24 ==> isLeft . runExcept . runWriterT $ startGame "" players +prop_startGameErrorsWhenMoreThan1Angel :: [Player] -> Property+prop_startGameErrorsWhenMoreThan1Angel players =+ length (filter isAngel players) > 1+ ==> isLeft . runExcept . runWriterT $ startGame "" players+ prop_startGameErrorsWhenMoreThan1Defender :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Defender players =- length (filterDefenders players) > 1+ length (filter isDefender players) > 1 ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1Scapegoat :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Scapegoat players =- length (filterScapegoats players) > 1+ length (filter isScapegoat players) > 1 ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1Seer :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Seer players =- length (filterSeers players) > 1+ length (filter isSeer players) > 1 ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1VillagerVillager :: [Player] -> Property prop_startGameErrorsWhenMoreThan1VillagerVillager players =- length (filterVillagerVillagers players) > 1+ length (filter isVillagerVillager players) > 1 ==> isLeft . runExcept . runWriterT $ startGame "" players +prop_startGameErrorsWhenMoreThan1WildChild :: [Player] -> Property+prop_startGameErrorsWhenMoreThan1WildChild players =+ length (filter isWildChild players) > 1+ ==> isLeft . runExcept . runWriterT $ startGame "" players+ prop_startGameErrorsWhenMoreThan1Witch :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Witch players =- length (filterWitches players) > 1+ length (filter isWitch players) > 1+ ==> isLeft . runExcept . runWriterT $ startGame "" players++prop_startGameErrorsWhenMoreThan1WolfHound :: [Player] -> Property+prop_startGameErrorsWhenMoreThan1WolfHound players =+ length (filter isWolfHound players) > 1 ==> isLeft . runExcept . runWriterT $ startGame "" players prop_createPlayersUsesGivenPlayerNames :: [Text] -> [Role] -> Property
test/src/Game/Werewolf/Test/Game.hs view
@@ -8,12 +8,8 @@ {-# OPTIONS_HADDOCK hide, prune #-} module Game.Werewolf.Test.Game (- prop_newGameStartsWithSunsetStage, prop_newGameStartsWithEventsEmpty,- prop_newGameStartsWithPassesEmpty, prop_newGameStartsWithNoHeal,- prop_newGameStartsWithNoHealUsed, prop_newGameStartsWithNoPoison,- prop_newGameStartsWithNoPoisonUsed, prop_newGameStartsWithNoPriorProtect,- prop_newGameStartsWithNoProtect, prop_newGameStartsWithNoSee,- prop_newGameStartsWithVotesEmpty, prop_newGameUsesGivenPlayers,+ -- * Tests+ allGameTests, ) where import Control.Lens@@ -23,9 +19,43 @@ import Game.Werewolf.Game import Game.Werewolf.Player+import Game.Werewolf.Test.Arbitrary () -prop_newGameStartsWithSunsetStage :: [Player] -> Bool-prop_newGameStartsWithSunsetStage players = isSunset (newGame players)+import Prelude hiding (round)++import Test.Tasty+import Test.Tasty.QuickCheck++allGameTests :: [TestTree]+allGameTests =+ [ testProperty "new game starts at village's turn when angel in play" prop_newGameStartsAtVillagesTurnWhenAngelInPlay+ , testProperty "new game starts at sunset when no angel in play" prop_newGameStartsAtSunsetWhenNoAngelInPlay+ , testProperty "new game starts on first round" prop_newGameStartsOnFirstRound+ , testProperty "new game starts with events empty" prop_newGameStartsWithEventsEmpty+ , testProperty "new game starts with passes empty" prop_newGameStartsWithPassesEmpty+ , testProperty "new game starts with no heal" prop_newGameStartsWithNoHeal+ , testProperty "new game starts with no heal used" prop_newGameStartsWithNoHealUsed+ , testProperty "new game starts with no poison" prop_newGameStartsWithNoPoison+ , testProperty "new game starts with no poison used" prop_newGameStartsWithNoPoisonUsed+ , testProperty "new game starts with no prior protect" prop_newGameStartsWithNoPriorProtect+ , testProperty "new game starts with no protect" prop_newGameStartsWithNoProtect+ , testProperty "new game starts with no see" prop_newGameStartsWithNoSee+ , testProperty "new game starts with votes empty" prop_newGameStartsWithVotesEmpty+ , testProperty "new game uses given players" prop_newGameUsesGivenPlayers+ ]++prop_newGameStartsAtVillagesTurnWhenAngelInPlay :: [Player] -> Property+prop_newGameStartsAtVillagesTurnWhenAngelInPlay players =+ any isAngel players+ ==> isVillagesTurn (newGame players)++prop_newGameStartsAtSunsetWhenNoAngelInPlay :: [Player] -> Property+prop_newGameStartsAtSunsetWhenNoAngelInPlay players =+ none isAngel players+ ==> isSunset (newGame players)++prop_newGameStartsOnFirstRound :: [Player] -> Bool+prop_newGameStartsOnFirstRound players = isFirstRound $ newGame players prop_newGameStartsWithEventsEmpty :: [Player] -> Bool prop_newGameStartsWithEventsEmpty players = null $ newGame players ^. events
test/src/Game/Werewolf/Test/Player.hs view
@@ -8,7 +8,8 @@ {-# OPTIONS_HADDOCK hide, prune #-} module Game.Werewolf.Test.Player (- prop_newPlayerIsAlive,+ -- * Tests+ allPlayerTests, ) where import Control.Lens@@ -17,6 +18,15 @@ import Game.Werewolf.Player import Game.Werewolf.Role+import Game.Werewolf.Test.Arbitrary ()++import Test.Tasty+import Test.Tasty.QuickCheck++allPlayerTests :: [TestTree]+allPlayerTests =+ [ testProperty "new player is alive" prop_newPlayerIsAlive+ ] prop_newPlayerIsAlive :: Text -> Role -> Bool prop_newPlayerIsAlive name role = newPlayer name role ^. state == Alive
test/src/Game/Werewolf/Test/Util.hs view
@@ -6,7 +6,6 @@ -} {-# OPTIONS_HADDOCK hide, prune #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Game.Werewolf.Test.Util ( -- * Utility functions
werewolf.cabal view
@@ -1,5 +1,5 @@ name: werewolf-version: 0.4.4.1+version: 0.4.5.0 author: Henry J. Wylde maintainer: public@hjwylde.com@@ -28,6 +28,7 @@ hs-source-dirs: app/ ghc-options: -threaded -with-rtsopts=-N other-modules:+ Werewolf.Commands.Choose, Werewolf.Commands.End, Werewolf.Commands.Heal, Werewolf.Commands.Help,@@ -40,6 +41,7 @@ Werewolf.Commands.See, Werewolf.Commands.Start, Werewolf.Commands.Status,+ Werewolf.Commands.Version, Werewolf.Commands.Vote, Werewolf.Options, Werewolf.Version,