diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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* diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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?"} ]} diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/app/Werewolf/Commands/Choose.hs b/app/Werewolf/Commands/Choose.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Commands/Choose.hs @@ -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 } diff --git a/app/Werewolf/Commands/Help.hs b/app/Werewolf/Commands/Help.hs --- a/app/Werewolf/Commands/Help.hs +++ b/app/Werewolf/Commands/Help.hs @@ -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." + ] ] ] diff --git a/app/Werewolf/Commands/Start.hs b/app/Werewolf/Commands/Start.hs --- a/app/Werewolf/Commands/Start.hs +++ b/app/Werewolf/Commands/Start.hs @@ -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 diff --git a/app/Werewolf/Commands/Version.hs b/app/Werewolf/Commands/Version.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Commands/Version.hs @@ -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] } diff --git a/app/Werewolf/Commands/Vote.hs b/app/Werewolf/Commands/Vote.hs --- a/app/Werewolf/Commands/Vote.hs +++ b/app/Werewolf/Commands/Vote.hs @@ -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 diff --git a/app/Werewolf/Options.hs b/app/Werewolf/Options.hs --- a/app/Werewolf/Options.hs +++ b/app/Werewolf/Options.hs @@ -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 diff --git a/src/Game/Werewolf/Command.hs b/src/Game/Werewolf/Command.hs --- a/src/Game/Werewolf/Command.hs +++ b/src/Game/Werewolf/Command.hs @@ -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] diff --git a/src/Game/Werewolf/Engine.hs b/src/Game/Werewolf/Engine.hs --- a/src/Game/Werewolf/Engine.hs +++ b/src/Game/Werewolf/Engine.hs @@ -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 diff --git a/src/Game/Werewolf/Game.hs b/src/Game/Werewolf/Game.hs --- a/src/Game/Werewolf/Game.hs +++ b/src/Game/Werewolf/Game.hs @@ -13,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] diff --git a/src/Game/Werewolf/Player.hs b/src/Game/Werewolf/Player.hs --- a/src/Game/Werewolf/Player.hs +++ b/src/Game/Werewolf/Player.hs @@ -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 diff --git a/src/Game/Werewolf/Response.hs b/src/Game/Werewolf/Response.hs --- a/src/Game/Werewolf/Response.hs +++ b/src/Game/Werewolf/Response.hs @@ -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" diff --git a/src/Game/Werewolf/Role.hs b/src/Game/Werewolf/Role.hs --- a/src/Game/Werewolf/Role.hs +++ b/src/Game/Werewolf/Role.hs @@ -17,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] diff --git a/test/app/Main.hs b/test/app/Main.hs --- a/test/app/Main.hs +++ b/test/app/Main.hs @@ -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 - ] diff --git a/test/src/Game/Werewolf/Test/Arbitrary.hs b/test/src/Game/Werewolf/Test/Arbitrary.hs --- a/test/src/Game/Werewolf/Test/Arbitrary.hs +++ b/test/src/Game/Werewolf/Test/Arbitrary.hs @@ -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 diff --git a/test/src/Game/Werewolf/Test/Command.hs b/test/src/Game/Werewolf/Test/Command.hs --- a/test/src/Game/Werewolf/Test/Command.hs +++ b/test/src/Game/Werewolf/Test/Command.hs @@ -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) diff --git a/test/src/Game/Werewolf/Test/Engine.hs b/test/src/Game/Werewolf/Test/Engine.hs --- a/test/src/Game/Werewolf/Test/Engine.hs +++ b/test/src/Game/Werewolf/Test/Engine.hs @@ -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 diff --git a/test/src/Game/Werewolf/Test/Game.hs b/test/src/Game/Werewolf/Test/Game.hs --- a/test/src/Game/Werewolf/Test/Game.hs +++ b/test/src/Game/Werewolf/Test/Game.hs @@ -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 diff --git a/test/src/Game/Werewolf/Test/Player.hs b/test/src/Game/Werewolf/Test/Player.hs --- a/test/src/Game/Werewolf/Test/Player.hs +++ b/test/src/Game/Werewolf/Test/Player.hs @@ -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 diff --git a/test/src/Game/Werewolf/Test/Util.hs b/test/src/Game/Werewolf/Test/Util.hs --- a/test/src/Game/Werewolf/Test/Util.hs +++ b/test/src/Game/Werewolf/Test/Util.hs @@ -6,7 +6,6 @@ -} {-# OPTIONS_HADDOCK hide, prune #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Game.Werewolf.Test.Util ( -- * Utility functions diff --git a/werewolf.cabal b/werewolf.cabal --- a/werewolf.cabal +++ b/werewolf.cabal @@ -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,