diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,18 +2,17 @@ #### Upcoming -#### v0.2.0.2 - -*Revisions* +#### v0.3.0.0 -* Fixed dead werewolves being informed of votes. ([#24](https://github.com/hjwylde/werewolf/issues/24)) +*Major* -#### v0.2.0.1 +* Added `--extra-roles` option to `start`. ([#12](https://github.com/hjwylde/werewolf/issues/12)) +* Removed Seer from being included by default. ([#12](https://github.com/hjwylde/werewolf/issues/12)) -*Revisions* +*Minor* -* Tidied up the help text to be smaller. ([#26](https://github.com/hjwylde/werewolf/issues/26)) -* Fixed a bug where the turn was advanced to Werewolves when no Werewolves were alive. ([#26](https://github.com/hjwylde/werewolf/issues/26)) +* Allowed `start` to work when the game has ended but `end` hasn't been called. ([#15](https://github.com/hjwylde/werewolf/issues/15)) +* Added `quit` command. ([#13](https://github.com/hjwylde/werewolf/issues/13)) #### v0.2.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -76,8 +76,7 @@ {"ok":true,"messages":[ {"to":["@grault"],"message":"@qux is a Villager."}, {"to":null,"message":"The Werewolves wake up, recognise one another and choose a new victim."}, - {"to":["@bar"],"message":"Who would you like to kill?"}, - {"to":["@corge"],"message":"Who would you like to kill?"} + {"to":["@bar","@corge"],"message":"Who would you like to kill?"} ]} ``` diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -8,29 +8,38 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide, prune #-} +{-# LANGUAGE OverloadedStrings #-} module Main ( - main, + main, handle, ) where +import qualified Data.Text as T + import Options.Applicative +import System.Environment + import qualified Werewolf.Commands.End as End import qualified Werewolf.Commands.Help as Help import qualified Werewolf.Commands.Interpret as Interpret +import qualified Werewolf.Commands.Quit as Quit import qualified Werewolf.Commands.See as See import qualified Werewolf.Commands.Start as Start import qualified Werewolf.Commands.Vote as Vote import Werewolf.Options main :: IO () -main = customExecParser werewolfPrefs werewolfInfo >>= handle +main = getArgs >>= handle -handle :: Options -> IO () -handle (Options caller command) = case command of - End -> End.handle caller - Help options -> Help.handle caller options - Interpret options -> Interpret.handle caller options - See options -> See.handle caller options - Start options -> Start.handle caller options - Vote options -> Vote.handle caller options +handle :: [String] -> IO () +handle args = handleParseResult (execParserPure werewolfPrefs werewolfInfo args) >>= handle' + where + handle' (Options callerName command) = case command of + End -> End.handle callerName + Help options -> Help.handle callerName options + Interpret (Interpret.Options args) -> handle . map T.unpack $ "--caller":callerName:args + Quit -> Quit.handle callerName + See options -> See.handle callerName options + Start options -> Start.handle callerName options + Vote options -> Vote.handle callerName options 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,22 +61,36 @@ commandsMessages :: [Text] commandsMessages = map T.unlines [[ - "End: end the current game", + "Usage: COMMAND ARG ..." + ], [ + "Available commands:", + " end - end the current game", + " help - help documents", + " quit - quit the current game", + " see - see a player's allegiance", + " start - start a new game", + " vote - vote against a player" + ], [ + "End:", "Usage: end", - "- Ends the current game." + " Ends the current game." ], [ - "See: see a player's allegiance", + "Quit:", + "Usage: quit", + " Quit the current game." + ], [ + "See:", "Usage: see PLAYER", - "- See a player's allegiance. A Seer may determine a player's allegiance once per day." + " See a player's allegiance. A Seer may determine a player's allegiance once per day." ], [ - "Start: start a new game", - "Usage: start [--extra-roles ROLE,...] PLAYER ...", - "- Starts a new game with the given players and extra roles. A game requires at least 7 players." + "Start:", + "Usage: start PLAYER ...", + " Starts a new game with the given players. A game requires at least 7 players." ], [ - "Vote: vote against a player", + "Vote:", "Usage: vote PLAYER", T.unwords [ - "- Vote against a player.", + " Vote against a player.", "A townsperson may vote at daytime to lynch someone", "and a Werewolf may vote at nighttime to kill a Villager." ] diff --git a/app/Werewolf/Commands/Interpret.hs b/app/Werewolf/Commands/Interpret.hs --- a/app/Werewolf/Commands/Interpret.hs +++ b/app/Werewolf/Commands/Interpret.hs @@ -1,50 +1,22 @@ {-| Module : Werewolf.Commands.Interpret -Description : Options and handler for the interpret subcommand. +Description : Options for the interpret subcommand. Copyright : (c) Henry J. Wylde, 2015 License : BSD3 Maintainer : public@hjwylde.com -Options and handler for the interpret subcommand. +Options for the interpret subcommand. -} -{-# LANGUAGE OverloadedStrings #-} - module Werewolf.Commands.Interpret ( -- * Options Options(..), - - -- * Handle - handle, ) where -import Control.Monad.Except - import Data.Text (Text) -import qualified Werewolf.Commands.End as End -import qualified Werewolf.Commands.Help as Help -import qualified Werewolf.Commands.See as See -import qualified Werewolf.Commands.Start as Start -import qualified Werewolf.Commands.Vote as Vote - -- | Options. data Options = Options { args :: [Text] } deriving (Eq, Show) - --- | Handle. -handle :: MonadIO m => Text -> Options -> m () -handle callerName (Options args) = interpret callerName args - -interpret :: MonadIO m => Text -> [Text] -> m () -interpret callerName ["end"] = End.handle callerName -interpret callerName ["help"] = Help.handle callerName (Help.Options Nothing) -interpret callerName ("help":["description"]) = Help.handle callerName (Help.Options $ Just Help.Description) -interpret callerName ("help":["rules"]) = Help.handle callerName (Help.Options $ Just Help.Rules) -interpret callerName ("help":["roles"]) = Help.handle callerName (Help.Options $ Just Help.Roles) -interpret callerName ("see":[targetName]) = See.handle callerName (See.Options targetName) -interpret callerName ("start":playerNames) = Start.handle callerName (Start.Options playerNames) -interpret callerName ("vote":[targetName]) = Vote.handle callerName (Vote.Options targetName) -interpret callerName _ = Help.handle callerName (Help.Options $ Just Help.Commands) diff --git a/app/Werewolf/Commands/Quit.hs b/app/Werewolf/Commands/Quit.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Commands/Quit.hs @@ -0,0 +1,43 @@ +{-| +Module : Werewolf.Commands.Quit +Description : Handler for the quit subcommand. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Handler for the quit subcommand. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Werewolf.Commands.Quit ( + -- * Handle + handle, +) where + +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf.Command +import Game.Werewolf.Engine hiding (isVillagersTurn) +import Game.Werewolf.Response + +-- | Handle. +handle :: MonadIO m => Text -> m () +handle callerName = do + unlessM doesGameExist $ exitWith failure { + messages = [privateMessage [callerName] "No game is running."] + } + + game <- readGame + + let command = quitCommand callerName + + case runExcept (runWriterT $ execStateT (apply command >> checkTurn >> checkGameOver) game) of + Left errorMessages -> exitWith failure { messages = errorMessages } + Right (game', messages) -> writeGame game' >> exitWith success { messages = messages } 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 @@ -25,23 +25,31 @@ import Data.Text (Text) -import Game.Werewolf.Engine +import Game.Werewolf.Engine hiding (isGameOver) +import Game.Werewolf.Game import Game.Werewolf.Response +import Game.Werewolf.Role -- | Options. data Options = Options - { argPlayers :: [Text] + { optExtraRoleNames :: [Text] + , argPlayers :: [Text] } deriving (Eq, Show) -- | Handle. handle :: MonadIO m => Text -> Options -> m () -handle callerName (Options playerNames) = do - whenM doesGameExist $ exitWith failure { +handle callerName (Options extraRoleNames playerNames) = do + whenM doesGameExist . whenM (fmap (not . isGameOver) readGame) $ exitWith failure { messages = [privateMessage [callerName] "A game is already running."] } - players <- createPlayers playerNames + result <- runExceptT $ do + extraRoles <- forM extraRoleNames $ \roleName -> maybe (throwError [roleDoesNotExistMessage callerName roleName]) return (findByName roleName) - case runExcept (runWriterT $ startGame callerName players) of + players <- createPlayers playerNames extraRoles + + runWriterT $ startGame callerName players + + case result of Left errorMessages -> exitWith failure { messages = errorMessages } - Right (game, messages) -> writeGame game >> exitWith success { messages = messages } + Right (game, messages) -> writeGame game >> exitWith success { messages = messages } diff --git a/app/Werewolf/Options.hs b/app/Werewolf/Options.hs --- a/app/Werewolf/Options.hs +++ b/app/Werewolf/Options.hs @@ -9,6 +9,8 @@ Optparse utilities. -} +{-# LANGUAGE OverloadedStrings #-} + module Werewolf.Options ( -- * Options Options(..), Command(..), @@ -17,6 +19,7 @@ werewolfPrefs, werewolfInfo, werewolf, ) where +import Data.List.Extra import Data.Text (Text) import qualified Data.Text as T import Data.Version (showVersion) @@ -41,6 +44,7 @@ = End | Help Help.Options | Interpret Interpret.Options + | Quit | See See.Options | Start Start.Options | Vote Vote.Options @@ -75,6 +79,7 @@ command "end" $ info (helper <*> end) (fullDesc <> progDesc "End the current game"), command "help" $ info (helper <*> help_) (fullDesc <> progDesc "Help documents"), command "interpret" $ info (helper <*> interpret) (fullDesc <> progDesc "Interpret a command"), + command "quit" $ info (helper <*> quit) (fullDesc <> progDesc "Quit the current game"), command "see" $ info (helper <*> see) (fullDesc <> progDesc "See a player's allegiance"), command "start" $ info (helper <*> start) (fullDesc <> progDesc "Start a new game"), command "vote" $ info (helper <*> vote) (fullDesc <> progDesc "Vote against a player") @@ -95,11 +100,20 @@ interpret :: Parser Command interpret = Interpret . Interpret.Options <$> many (T.pack <$> strArgument (metavar "COMMAND ARG...")) +quit :: Parser Command +quit = pure Quit + see :: Parser Command see = See . See.Options . T.pack <$> strArgument (metavar "PLAYER") start :: Parser Command -start = Start . Start.Options <$> many (T.pack <$> strArgument (metavar "PLAYER...")) +start = fmap Start $ Start.Options + <$> fmap (map T.pack . wordsBy (',' ==)) (strOption $ mconcat [ + long "extra-roles", metavar "ROLE,...", + value [], + help "Specify the extra roles to include" + ]) + <*> many (T.pack <$> strArgument (metavar "PLAYER...")) vote :: Parser Command vote = Vote . Vote.Options . T.pack <$> strArgument (metavar "PLAYER") 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 @@ -17,7 +17,7 @@ Command(..), -- ** Instances - seeCommand, killVoteCommand, lynchVoteCommand, noopCommand, + killVoteCommand, lynchVoteCommand, noopCommand, quitCommand, seeCommand, ) where import Control.Lens hiding (only) @@ -30,22 +30,13 @@ import Data.Text (Text) import Game.Werewolf.Engine +import Game.Werewolf.Player hiding (doesPlayerExist) import Game.Werewolf.Game hiding (isGameOver, isSeersTurn, isVillagersTurn, isWerewolvesTurn, killPlayer) import Game.Werewolf.Response data Command = Command { apply :: forall m . (MonadError [Message] m, MonadState Game m, MonadWriter [Message] m) => m () } -seeCommand :: Text -> Text -> Command -seeCommand callerName targetName = Command $ do - validateArguments callerName targetName - - unlessM isSeersTurn $ throwError [playerCannotDoThatMessage callerName] - unlessM (isPlayerSeer callerName) $ throwError [playerCannotDoThatMessage callerName] - whenJustM (getPlayerSee callerName) . const $ throwError [playerHasAlreadySeenMessage callerName] - - sees %= Map.insert callerName targetName - killVoteCommand :: Text -> Text -> Command killVoteCommand callerName targetName = Command $ do validateArguments callerName targetName @@ -67,6 +58,31 @@ noopCommand :: Command noopCommand = Command $ return () + +quitCommand :: Text -> Command +quitCommand callerName = Command $ do + whenM isGameOver $ throwError [gameIsOverMessage callerName] + unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] + + whenM (isPlayerDead callerName) $ throwError [playerIsDeadMessage callerName] + + caller <- uses players $ findByName_ callerName + + killPlayer caller + tell [playerQuitMessage caller] + + sees %= Map.delete callerName + votes %= Map.delete callerName + +seeCommand :: Text -> Text -> Command +seeCommand callerName targetName = Command $ do + validateArguments callerName targetName + + unlessM isSeersTurn $ throwError [playerCannotDoThatMessage callerName] + unlessM (isPlayerSeer callerName) $ throwError [playerCannotDoThatMessage callerName] + whenJustM (getPlayerSee callerName) . const $ throwError [playerHasAlreadySeenMessage callerName] + + sees %= Map.insert callerName targetName validateArguments :: (MonadError [Message] m, MonadState Game m) => Text -> Text -> m () validateArguments callerName targetName = do 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 @@ -56,7 +56,8 @@ import Game.Werewolf.Player hiding (doesPlayerExist) import qualified Game.Werewolf.Player as Player import Game.Werewolf.Response -import Game.Werewolf.Role as Role hiding (Villagers, Werewolves) +import Game.Werewolf.Role (Role, werewolfRole, villagerRole, _allegiance) +import qualified Game.Werewolf.Role as Role import System.Directory import System.FilePath @@ -79,24 +80,6 @@ advanceTurn - Werewolves -> do - aliveWerewolves <- uses players (filterAlive . filterWerewolves) - votes' <- use votes - - when (length aliveWerewolves == Map.size votes') $ do - tell $ map (uncurry . playerMadeKillVoteMessage $ map Player._name aliveWerewolves) (Map.toList votes') - - advanceTurn - - let mTargetName = only . last $ groupSortOn (length . flip elemIndices (Map.elems votes')) (nub $ Map.elems votes') - case mTargetName of - Nothing -> tell [noPlayerKilledMessage] - Just targetName -> do - target <- uses players (findByName_ targetName) - - killPlayer target - tell [playerKilledMessage (target ^. Player.name) (target ^. Player.role . Role.name)] - Villagers -> do playersCount <- uses players (length . filterAlive) votes' <- use votes @@ -111,10 +94,31 @@ target <- uses players (findByName_ lynchedName) killPlayer target - tell [playerLynchedMessage (target ^. Player.name) (target ^. Player.role . Role.name)] + tell [playerLynchedMessage (target ^. name) (target ^. role . Role.name)] + tell [nightFallsMessage] + advanceTurn + Werewolves -> do + werewolvesCount <- uses players (length . filterAlive . filterWerewolves) + votes' <- use votes + + when (werewolvesCount == Map.size votes') $ do + werewolfNames <- uses players (map _name . filterWerewolves) + tell $ map (uncurry $ playerMadeKillVoteMessage werewolfNames) (Map.toList votes') + + advanceTurn + + let mTargetName = only . last $ groupSortOn (length . flip elemIndices (Map.elems votes')) (nub $ Map.elems votes') + case mTargetName of + Nothing -> tell [noPlayerKilledMessage] + Just targetName -> do + target <- uses players (findByName_ targetName) + + killPlayer target + tell [playerKilledMessage (target ^. name) (target ^. role . Role.name)] + NoOne -> return () only :: [a] -> Maybe a @@ -126,20 +130,13 @@ turn' <- use turn alivePlayers <- uses players filterAlive - let nextTurn = if length (nub $ map (_allegiance . _role) alivePlayers) <= 1 - then NoOne - else head . drop1 $ filter (turnAvailable alivePlayers) (dropWhile (turn' /=) turnRotation) + let nextTurn = head . drop1 $ filter (turnAvailable $ map _role alivePlayers) (dropWhile (turn' /=) turnRotation) tell $ turnMessages nextTurn alivePlayers turn .= nextTurn sees .= Map.empty votes .= Map.empty - where - turnAvailable alivePlayers Seers = not . null $ filterSeers alivePlayers - turnAvailable alivePlayers Villagers = not . null $ filterVillagers alivePlayers - turnAvailable alivePlayers Werewolves = not . null $ filterWerewolves alivePlayers - turnAvailable _ NoOne = False checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do @@ -156,11 +153,13 @@ when (length players < 7) $ throwError [privateMessage [callerName] "Must have at least 7 players."] when (length players > 24) $ throwError [privateMessage [callerName] "Cannot have more than 24 players."] - tell $ newGameMessages players + let game = newGame players - return $ newGame players + tell $ newGameMessages game + + return game where - playerNames = map Player._name players + playerNames = map _name players killPlayer :: MonadState Game m => Player -> m () killPlayer player = players %= map (\player' -> if player' == player then player' & state .~ Dead else player') @@ -201,8 +200,8 @@ doesGameExist :: MonadIO m => m Bool doesGameExist = liftIO $ defaultFilePath >>= doesFileExist -createPlayers :: MonadIO m => [Text] -> m [Player] -createPlayers playerNames = zipWith newPlayer playerNames <$> randomiseRoles (length playerNames) +createPlayers :: MonadIO m => [Text] -> [Role] -> m [Player] +createPlayers playerNames extraRoles = zipWith newPlayer playerNames <$> randomiseRoles extraRoles (length playerNames) doesPlayerExist :: MonadState Game m => Text -> m Bool doesPlayerExist name = uses players $ Player.doesPlayerExist name @@ -222,9 +221,11 @@ isPlayerDead :: MonadState Game m => Text -> m Bool isPlayerDead name = uses players $ isDead . findByName_ name -randomiseRoles :: MonadIO m => Int -> m [Role] -randomiseRoles n = liftIO . evalRandIO . shuffleM $ seerRoles ++ werewolfRoles ++ villagerRoles +randomiseRoles :: MonadIO m => [Role] -> Int -> m [Role] +randomiseRoles extraRoles n = liftIO . evalRandIO . shuffleM $ extraRoles ++ werewolfRoles ++ villagerRoles where - seerRoles = [seerRole] - werewolfRoles = replicate (n `quot` 6 + 1) werewolfRole - villagerRoles = replicate (n - length (seerRoles ++ werewolfRoles)) villagerRole + extraWerewolfRoles = filter ((==) Role.Werewolves . _allegiance) extraRoles + extraVillagerRoles = filter ((==) Role.Villagers . _allegiance) extraRoles + + werewolfRoles = replicate (n `quot` 6 + 1 - length extraWerewolfRoles) werewolfRole + villagerRoles = replicate (n - length (extraVillagerRoles ++ werewolfRoles)) villagerRole 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,7 +13,7 @@ module Game.Werewolf.Game ( -- * Game - Game(..), turn, players, + Game(..), turn, players, sees, votes, newGame, -- ** Manipulations @@ -23,8 +23,8 @@ isSeersTurn, isVillagersTurn, isWerewolvesTurn, isGameOver, -- * Turn - Turn(..), sees, votes, - turnRotation, + Turn(..), + turnRotation, turnAvailable, ) where import Control.Lens @@ -34,6 +34,7 @@ import Data.Text (Text) import Game.Werewolf.Player +import Game.Werewolf.Role hiding (Villagers, Werewolves) data Game = Game { _turn :: Turn @@ -50,7 +51,9 @@ makeLenses ''Turn newGame :: [Player] -> Game -newGame players = Game (head turnRotation) players Map.empty Map.empty +newGame players = Game (head $ filter (turnAvailable aliveRoles) turnRotation) players Map.empty Map.empty + where + aliveRoles = map _role $ filterAlive players killPlayer :: Game -> Player -> Game killPlayer game player = game & players %~ map (\player' -> if player' == player then player' & state .~ Dead else player') @@ -69,3 +72,9 @@ turnRotation :: [Turn] turnRotation = cycle [Seers, Werewolves, Villagers, NoOne] + +turnAvailable :: [Role] -> Turn -> Bool +turnAvailable aliveRoles Seers = seerRole `elem` aliveRoles +turnAvailable _ Villagers = True +turnAvailable _ Werewolves = True +turnAvailable _ NoOne = False 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 @@ -38,7 +38,7 @@ import Data.Maybe import Data.Text (Text) -import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Role hiding (findByName, findByName_, name, _name) data Player = Player { _name :: Text 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,17 +28,18 @@ publicMessage, privateMessage, -- ** Game messages - newGameMessages, turnMessages, seersTurnMessages, villagersTurnMessage, werewolvesTurnMessages, - playerSeenMessage, playerMadeKillVoteMessage, playerKilledMessage, noPlayerKilledMessage, - playerMadeLynchVoteMessage, playerLynchedMessage, noPlayerLynchedMessage, gameOverMessage, + newGameMessages, nightFallsMessage, turnMessages, seersTurnMessages, villagersTurnMessage, + werewolvesTurnMessages, playerSeenMessage, playerMadeKillVoteMessage, playerKilledMessage, + noPlayerKilledMessage, playerMadeLynchVoteMessage, playerLynchedMessage, noPlayerLynchedMessage, + playerQuitMessage, gameOverMessage, -- ** Error messages - playerDoesNotExistMessage, playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, - gameIsOverMessage, playerIsDeadMessage, playerHasAlreadySeenMessage, - playerHasAlreadyVotedMessage, targetIsDeadMessage, + roleDoesNotExistMessage, playerDoesNotExistMessage, playerCannotDoThatMessage, + playerCannotDoThatRightNowMessage, gameIsOverMessage, playerIsDeadMessage, + playerHasAlreadySeenMessage, playerHasAlreadyVotedMessage, targetIsDeadMessage, ) where -import Control.Lens hiding (singular) +import Control.Lens import Control.Monad.IO.Class import Data.Aeson @@ -53,7 +54,7 @@ import Game.Werewolf.Game import Game.Werewolf.Player -import Game.Werewolf.Role (allegiance, description, singular) +import Game.Werewolf.Role (allegiance, description) import qualified Game.Werewolf.Role as Role import GHC.Generics @@ -106,8 +107,11 @@ privateMessage :: [Text] -> Text -> Message privateMessage to = Message (Just to) -newGameMessages :: [Player] -> [Message] -newGameMessages players = map (newPlayerMessage players) players ++ seersTurnMessages (filterSeers players) +newGameMessages :: Game -> [Message] +newGameMessages game = map (newPlayerMessage alivePlayers) alivePlayers ++ [nightFallsMessage] ++ turnMessages turn' alivePlayers + where + turn' = game ^. turn + alivePlayers = filterAlive $ game ^. players nightFallsMessage :: Message nightFallsMessage = publicMessage "Night falls, the townsfolk are asleep." @@ -125,21 +129,22 @@ turnMessages Seers players = seersTurnMessages $ filter isSeer players turnMessages Villagers _ = [villagersTurnMessage] turnMessages Werewolves players = werewolvesTurnMessages $ filter isWerewolf players -turnMessages NoOne _ = [] +turnMessages NoOne _ = undefined seersTurnMessages :: [Player] -> [Message] -seersTurnMessages seers = nightFallsMessage:(publicMessage "The Seers wake up."):(map (\seer -> privateMessage [seer ^. name] "Who's allegiance would you like to see?") seers) +seersTurnMessages seers = publicMessage "The Seers wake up.":privateMessage (map _name seers) "Who's allegiance would you like to see?":[] villagersTurnMessage :: Message villagersTurnMessage = publicMessage "The sun rises. Everybody wakes up and opens their eyes..." werewolvesTurnMessages :: [Player] -> [Message] -werewolvesTurnMessages werewolves = - publicMessage "The Werewolves wake up, recognise one another and choose a new victim." - :map (\werewolf -> privateMessage [werewolf ^. name] "Who would you like to kill?") werewolves +werewolvesTurnMessages werewolves = [ + publicMessage "The Werewolves wake up, recognise one another and choose a new victim.", + privateMessage (map _name werewolves) "Who would you like to kill?" + ] playerSeenMessage :: Text -> Player -> Message -playerSeenMessage seerName target = privateMessage [seerName] $ T.concat [target ^. name, " is a ", singular $ target ^. role . allegiance, "."] +playerSeenMessage seerName target = privateMessage [seerName] $ T.concat [target ^. name, " is aligned with the ", T.pack . show $ target ^. role . allegiance, "."] playerMadeKillVoteMessage :: [Text] -> Text -> Text -> Message playerMadeKillVoteMessage to voterName targetName = privateMessage to $ T.concat [voterName, " voted to kill ", targetName, "."] @@ -172,9 +177,15 @@ noPlayerLynchedMessage :: Message noPlayerLynchedMessage = publicMessage "Daylight is wasted as the townsfolk squabble over whom to tie up. Looks like no one is being burned this day." +playerQuitMessage :: Player -> Message +playerQuitMessage player = publicMessage $ T.unwords [player ^. name, "the", player ^. role . Role.name, "has quit!"] + gameOverMessage :: Maybe Text -> Message gameOverMessage Nothing = publicMessage "The game is over! Everyone died..." gameOverMessage (Just allegiance) = publicMessage $ T.unwords ["The game is over! The", allegiance, "have won."] + +roleDoesNotExistMessage :: Text -> Text -> Message +roleDoesNotExistMessage to name = privateMessage [to] $ T.unwords ["Role", name, "does not exist."] playerDoesNotExistMessage :: Text -> Text -> Message playerDoesNotExistMessage to name = privateMessage [to] $ T.unwords ["Player", name, "does not exist."] 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 @@ -19,14 +19,19 @@ -- ** Instances allRoles, seerRole, villagerRole, werewolfRole, + -- ** Queries + findByName, findByName_, + -- * Allegiance Allegiance(..), - singular, ) where -import Control.Lens hiding (singular) +import Control.Lens -import Data.Text as T +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T import Prelude hiding (all) @@ -73,11 +78,13 @@ "Voting against your partner can be a good way to deflect suspicion from yourself." } +findByName :: Text -> Maybe Role +findByName name = find ((==) name . _name) allRoles + +findByName_ :: Text -> Role +findByName_ name = fromJust $ findByName name + data Allegiance = Villagers | Werewolves deriving (Eq, Read, Show) makeLenses ''Role - -singular :: Allegiance -> Text -singular Villagers = "Villager" -singular Werewolves = "Werewolf" diff --git a/test/app/Main.hs b/test/app/Main.hs --- a/test/app/Main.hs +++ b/test/app/Main.hs @@ -28,16 +28,6 @@ allCommandTests :: [TestTree] allCommandTests = [ - testProperty "PROP: see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver, - testProperty "PROP: see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist, - testProperty "PROP: see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist, - testProperty "PROP: see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead, - testProperty "PROP: see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead, - testProperty "PROP: see command errors when not seers turn" prop_seeCommandErrorsWhenNotSeersTurn, - testProperty "PROP: see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer, - testProperty "PROP: see command errors when caller has seen" prop_seeCommandErrorsWhenCallerHasSeen, - testProperty "PROP: see command errors updates sees" prop_seeCommandUpdatesSees, - testProperty "PROP: kill vote command errors when game is over" prop_killVoteCommandErrorsWhenGameIsOver, testProperty "PROP: kill vote command errors when caller does not exist" prop_killVoteCommandErrorsWhenCallerDoesNotExist, testProperty "PROP: kill vote command errors when target does not exist" prop_killVoteCommandErrorsWhenTargetDoesNotExist, @@ -55,7 +45,25 @@ testProperty "PROP: lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead, testProperty "PROP: lynch vote command errors when not villagers turn" prop_lynchVoteCommandErrorsWhenNotVillagersTurn, testProperty "PROP: lynch vote command errors when caller has voted" prop_lynchVoteCommandErrorsWhenCallerHasVoted, - testProperty "PROP: lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes + testProperty "PROP: lynch vote command updates votes" prop_lynchVoteCommandUpdatesVotes, + + testProperty "PROP: quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver, + testProperty "PROP: quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist, + testProperty "PROP: quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead, + testProperty "PROP: quit command kills player" prop_quitCommandKillsPlayer, + testProperty "PROP: quit command clears players kill vote" prop_quitCommandClearsPlayersKillVote, + testProperty "PROP: quit command clears players lynch vote" prop_quitCommandClearsPlayersLynchVote, + testProperty "PROP: quit command clears players see" prop_quitCommandClearsPlayersSee, + + testProperty "PROP: see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver, + testProperty "PROP: see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist, + testProperty "PROP: see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist, + testProperty "PROP: see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead, + testProperty "PROP: see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead, + testProperty "PROP: see command errors when not seers turn" prop_seeCommandErrorsWhenNotSeersTurn, + testProperty "PROP: see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer, + testProperty "PROP: see command errors when caller has seen" prop_seeCommandErrorsWhenCallerHasSeen, + testProperty "PROP: see command errors updates sees" prop_seeCommandUpdatesSees ] allEngineTests :: [TestTree] @@ -82,23 +90,27 @@ testProperty "PROP: check game over advances turn" prop_checkGameOverAdvancesTurn, testProperty "PROP: check game over does nothing when at least two allegiances alivevoted" prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive, - testProperty "PROP: start game starts with seers turn" prop_startGameStartsWithSeersTurn, + testProperty "PROP: start game starts with seers turn when seers present" prop_startGameStartsWithSeersTurnWhenSeersPresent, + testProperty "PROP: start game starts with werewolves turn when seers absent" prop_startGameStartsWithWerewolvesTurnWhenSeersAbsent, testProperty "PROP: start game uses given players" prop_startGameUsesGivenPlayers, testProperty "PROP: start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames, testProperty "PROP: start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players, testProperty "PROP: start game errors when more than 24 players" prop_startGameErrorsWhenMoreThan24Players, testProperty "PROP: create players uses given player names" prop_createPlayersUsesGivenPlayerNames, + testProperty "PROP: create players uses given roles" prop_createPlayersUsesGivenRoles, testProperty "PROP: create players creates alive players" prop_createPlayersCreatesAlivePlayers, testProperty "PROP: randomise roles returns n roles" prop_randomiseRolesReturnsNRoles, - testProperty "PROP: randomise roles proportions roles" prop_randomiseRolesProportionsRoles, - testProperty "PROP: randomise roles has one seer" prop_randomiseRolesHasOneSeer + testProperty "PROP: randomise roles uses given roles" prop_randomiseRolesUsesGivenRoles, + testProperty "PROP: randomise roles proportions allegiances" prop_randomiseRolesProportionsAllegiances ] allGameTests :: [TestTree] allGameTests = [ - testProperty "PROP: new game starts with seers turn" prop_newGameStartsWithSeersTurn, + testProperty "PROP: new game starts with seers turn when seers present" prop_newGameStartsWithSeersTurnWhenSeersPresent, + testProperty "PROP: new game starts with werewolves turn when seers absent" prop_newGameStartsWithWerewolvesTurnWhenSeersAbsent, + testProperty "PROP: new game starts with sees empty" prop_newGameStartsWithSeesEmpty, testProperty "PROP: new game starts with votes empty" prop_newGameStartsWithVotesEmpty, testProperty "PROP: new game uses given players" prop_newGameUsesGivenPlayers 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 @@ -10,8 +10,9 @@ module Game.Werewolf.Test.Arbitrary ( -- * Contextual arbitraries - arbitraryCommand, arbitrarySeeCommand, arbitraryKillVoteCommand, arbitraryLynchVoteCommand, - arbitraryNewGame, arbitraryPlayer, arbitrarySeer, arbitraryVillager, arbitraryWerewolf, + arbitraryCommand, arbitraryKillVoteCommand, arbitraryLynchVoteCommand, arbitraryQuitCommand, + arbitrarySeeCommand, arbitraryNewGame, arbitraryPlayer, arbitrarySeer, arbitraryVillager, + arbitraryWerewolf, -- * Utility functions run, run_, runArbitraryCommands, @@ -46,15 +47,6 @@ Werewolves -> arbitraryKillVoteCommand game NoOne -> return noopCommand -arbitrarySeeCommand :: Game -> Gen Command -arbitrarySeeCommand game = do - let applicableCallers = filter (flip Map.notMember (game ^. sees) . _name) (filterAlive . filterSeers $ game ^. players) - target <- arbitraryPlayer game - - if null applicableCallers - then return noopCommand - else elements applicableCallers >>= \caller -> return $ seeCommand (caller ^. name) (target ^. name) - arbitraryKillVoteCommand :: Game -> Gen Command arbitraryKillVoteCommand game = do let applicableCallers = filter (flip Map.notMember (game ^. votes) . _name) (filterAlive . filterWerewolves $ game ^. players) @@ -72,6 +64,23 @@ if null applicableCallers then return noopCommand else elements applicableCallers >>= \caller -> return $ lynchVoteCommand (caller ^. name) (target ^. name) + +arbitraryQuitCommand :: Game -> Gen Command +arbitraryQuitCommand game = do + let applicableCallers = filterAlive $ game ^. players + + if null applicableCallers + then return noopCommand + else elements applicableCallers >>= \caller -> return $ quitCommand (caller ^. name) + +arbitrarySeeCommand :: Game -> Gen Command +arbitrarySeeCommand game = do + let applicableCallers = filter (flip Map.notMember (game ^. sees) . _name) (filterAlive . filterSeers $ game ^. players) + target <- arbitraryPlayer game + + if null applicableCallers + then return noopCommand + else elements applicableCallers >>= \caller -> return $ seeCommand (caller ^. name) (target ^. name) instance Arbitrary Game where arbitrary = 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 @@ -8,13 +8,6 @@ {-# OPTIONS_HADDOCK hide, prune #-} module Game.Werewolf.Test.Command ( - -- * seeCommand - prop_seeCommandErrorsWhenGameIsOver, prop_seeCommandErrorsWhenCallerDoesNotExist, - prop_seeCommandErrorsWhenTargetDoesNotExist, prop_seeCommandErrorsWhenCallerIsDead, - prop_seeCommandErrorsWhenTargetIsDead, prop_seeCommandErrorsWhenNotSeersTurn, - prop_seeCommandErrorsWhenCallerNotSeer, prop_seeCommandErrorsWhenCallerHasSeen, - prop_seeCommandUpdatesSees, - -- * killVoteCommand prop_killVoteCommandErrorsWhenGameIsOver, prop_killVoteCommandErrorsWhenCallerDoesNotExist, prop_killVoteCommandErrorsWhenTargetDoesNotExist, prop_killVoteCommandErrorsWhenCallerIsDead, @@ -27,6 +20,19 @@ prop_lynchVoteCommandErrorsWhenTargetDoesNotExist, prop_lynchVoteCommandErrorsWhenCallerIsDead, prop_lynchVoteCommandErrorsWhenTargetIsDead, prop_lynchVoteCommandErrorsWhenNotVillagersTurn, prop_lynchVoteCommandErrorsWhenCallerHasVoted, prop_lynchVoteCommandUpdatesVotes, + + -- * quitCommand + prop_quitCommandErrorsWhenGameIsOver, prop_quitCommandErrorsWhenCallerDoesNotExist, + prop_quitCommandErrorsWhenCallerIsDead, prop_quitCommandKillsPlayer, + prop_quitCommandClearsPlayersKillVote, prop_quitCommandClearsPlayersLynchVote, + prop_quitCommandClearsPlayersSee, + + -- * seeCommand + prop_seeCommandErrorsWhenGameIsOver, prop_seeCommandErrorsWhenCallerDoesNotExist, + prop_seeCommandErrorsWhenTargetDoesNotExist, prop_seeCommandErrorsWhenCallerIsDead, + prop_seeCommandErrorsWhenTargetIsDead, prop_seeCommandErrorsWhenNotSeersTurn, + prop_seeCommandErrorsWhenCallerNotSeer, prop_seeCommandErrorsWhenCallerHasSeen, + prop_seeCommandUpdatesSees, ) where import Control.Lens hiding (elements) @@ -41,48 +47,6 @@ import Test.QuickCheck -prop_seeCommandErrorsWhenGameIsOver :: Game -> Property -prop_seeCommandErrorsWhenGameIsOver game = isGameOver game - ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game - -prop_seeCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_seeCommandErrorsWhenCallerDoesNotExist game caller = not (doesPlayerExist (caller ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) - -prop_seeCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_seeCommandErrorsWhenTargetDoesNotExist game target = not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitrarySeer game) $ \caller -> - verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) - -prop_seeCommandErrorsWhenCallerIsDead :: Game -> Property -prop_seeCommandErrorsWhenCallerIsDead game = - forAll (arbitrarySeer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors (killPlayer game caller) (seeCommand (caller ^. name) (target ^. name)) - -prop_seeCommandErrorsWhenTargetIsDead :: Game -> Property -prop_seeCommandErrorsWhenTargetIsDead game = - forAll (arbitrarySeer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors (killPlayer game target) (seeCommand (caller ^. name) (target ^. name)) - -prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property -prop_seeCommandErrorsWhenNotSeersTurn game = not (isSeersTurn game) ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game - -prop_seeCommandErrorsWhenCallerNotSeer :: Game -> Property -prop_seeCommandErrorsWhenCallerNotSeer game = - forAll (arbitraryPlayer game) $ \caller -> not (isSeer caller) ==> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) - -prop_seeCommandErrorsWhenCallerHasSeen :: Game -> Property -prop_seeCommandErrorsWhenCallerHasSeen game = - isSeersTurn game ==> - forAll (arbitrarySeer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - let command = seeCommand (caller ^. name) (target ^. name) in verbose_runCommandErrors (run_ (apply command) game) command - -prop_seeCommandUpdatesSees :: Game -> Property -prop_seeCommandUpdatesSees game = isSeersTurn game ==> forAll (arbitrarySeeCommand game) $ \command -> Map.size (run_ (apply command) game ^. sees) == 1 - prop_killVoteCommandErrorsWhenGameIsOver :: Game -> Property prop_killVoteCommandErrorsWhenGameIsOver game = isGameOver game ==> forAll (arbitraryKillVoteCommand game) $ verbose_runCommandErrors game @@ -100,70 +64,190 @@ prop_killVoteCommandErrorsWhenCallerIsDead :: Game -> Property prop_killVoteCommandErrorsWhenCallerIsDead game = forAll (arbitraryWerewolf game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors (killPlayer game caller) (killVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors (killPlayer game caller) (killVoteCommand (caller ^. name) (target ^. name)) prop_killVoteCommandErrorsWhenTargetIsDead :: Game -> Property prop_killVoteCommandErrorsWhenTargetIsDead game = forAll (arbitraryWerewolf game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors (killPlayer game target) (killVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors (killPlayer game target) (killVoteCommand (caller ^. name) (target ^. name)) prop_killVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property -prop_killVoteCommandErrorsWhenNotWerewolvesTurn game = not (isWerewolvesTurn game) ==> forAll (arbitraryKillVoteCommand game) $ verbose_runCommandErrors game +prop_killVoteCommandErrorsWhenNotWerewolvesTurn game = + not (isWerewolvesTurn game) + ==> forAll (arbitraryKillVoteCommand game) $ verbose_runCommandErrors game prop_killVoteCommandErrorsWhenCallerNotWerewolf :: Game -> Property prop_killVoteCommandErrorsWhenCallerNotWerewolf game = - forAll (arbitraryPlayer game) $ \caller -> not (isWerewolf caller) ==> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors game (killVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \caller -> not (isWerewolf caller) + ==> forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors game (killVoteCommand (caller ^. name) (target ^. name)) prop_killVoteCommandErrorsWhenCallerHasVoted :: Game -> Property prop_killVoteCommandErrorsWhenCallerHasVoted game = isWerewolvesTurn game ==> forAll (arbitraryWerewolf game) $ \caller -> forAll (arbitraryPlayer game) $ \target -> - let command = killVoteCommand (caller ^. name) (target ^. name) in verbose_runCommandErrors (run_ (apply command) game) command + let command = killVoteCommand (caller ^. name) (target ^. name) + in verbose_runCommandErrors (run_ (apply command) game) command prop_killVoteCommandUpdatesVotes :: Game -> Property -prop_killVoteCommandUpdatesVotes game = isWerewolvesTurn game ==> forAll (arbitraryKillVoteCommand game) $ \command -> Map.size (run_ (apply command) game ^. votes) == 1 +prop_killVoteCommandUpdatesVotes game = + isWerewolvesTurn game + ==> forAll (arbitraryKillVoteCommand game) $ \command -> + Map.size (run_ (apply command) game ^. votes) == 1 prop_lynchVoteCommandErrorsWhenGameIsOver :: Game -> Property -prop_lynchVoteCommandErrorsWhenGameIsOver game = isGameOver game +prop_lynchVoteCommandErrorsWhenGameIsOver game = + isGameOver game ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_lynchVoteCommandErrorsWhenCallerDoesNotExist game caller = not (doesPlayerExist (caller ^. name) (game ^. players)) +prop_lynchVoteCommandErrorsWhenCallerDoesNotExist game caller = + not (doesPlayerExist (caller ^. name) (game ^. players)) ==> forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors game (lynchVoteCommand (caller ^. name) (target ^. name)) prop_lynchVoteCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_lynchVoteCommandErrorsWhenTargetDoesNotExist game target = not (doesPlayerExist (target ^. name) (game ^. players)) +prop_lynchVoteCommandErrorsWhenTargetDoesNotExist game target = + not (doesPlayerExist (target ^. name) (game ^. players)) ==> forAll (arbitraryPlayer game) $ \caller -> verbose_runCommandErrors game (lynchVoteCommand (caller ^. name) (target ^. name)) prop_lynchVoteCommandErrorsWhenCallerIsDead :: Game -> Property prop_lynchVoteCommandErrorsWhenCallerIsDead game = forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors (killPlayer game caller) (lynchVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors (killPlayer game caller) (lynchVoteCommand (caller ^. name) (target ^. name)) prop_lynchVoteCommandErrorsWhenTargetIsDead :: Game -> Property prop_lynchVoteCommandErrorsWhenTargetIsDead game = forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> verbose_runCommandErrors (killPlayer game target) (lynchVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors (killPlayer game target) (lynchVoteCommand (caller ^. name) (target ^. name)) prop_lynchVoteCommandErrorsWhenNotVillagersTurn :: Game -> Property -prop_lynchVoteCommandErrorsWhenNotVillagersTurn game = not (isVillagersTurn game) ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game +prop_lynchVoteCommandErrorsWhenNotVillagersTurn game = + not (isVillagersTurn game) + ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game prop_lynchVoteCommandErrorsWhenCallerHasVoted :: Game -> Property prop_lynchVoteCommandErrorsWhenCallerHasVoted game = isVillagersTurn game ==> forAll (arbitraryPlayer game) $ \caller -> forAll (arbitraryPlayer game) $ \target -> - let command = lynchVoteCommand (caller ^. name) (target ^. name) in verbose_runCommandErrors (run_ (apply command) game) command + let command = lynchVoteCommand (caller ^. name) (target ^. name) + in verbose_runCommandErrors (run_ (apply command) game) command prop_lynchVoteCommandUpdatesVotes :: Game -> Property prop_lynchVoteCommandUpdatesVotes game = isVillagersTurn game ==> forAll (arbitraryLynchVoteCommand game) $ \command -> Map.size (run_ (apply command) game ^. votes) == 1 + +prop_quitCommandErrorsWhenGameIsOver :: Game -> Property +prop_quitCommandErrorsWhenGameIsOver game = + isGameOver game + ==> forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game + +prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property +prop_quitCommandErrorsWhenCallerDoesNotExist game caller = + not (doesPlayerExist (caller ^. name) (game ^. players)) + ==> verbose_runCommandErrors game (quitCommand $ caller ^. name) + +prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property +prop_quitCommandErrorsWhenCallerIsDead game = + forAll (arbitraryPlayer game) $ \caller -> + verbose_runCommandErrors (killPlayer game caller) (quitCommand $ caller ^. name) + +prop_quitCommandKillsPlayer :: Game -> Property +prop_quitCommandKillsPlayer game = + not (isGameOver game) + ==> forAll (arbitraryQuitCommand game) $ \command -> + length (filterDead $ run_ (apply command) game ^. players) == 1 + +prop_quitCommandClearsPlayersKillVote :: Game -> Property +prop_quitCommandClearsPlayersKillVote game = + forAll (arbitraryWerewolf game') $ \caller -> + forAll (arbitraryPlayer game') $ \target -> + let game'' = run_ (apply $ killVoteCommand (caller ^. name) (target ^. name)) game' + in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes + where + game' = game { _turn = Werewolves } + +prop_quitCommandClearsPlayersLynchVote :: Game -> Property +prop_quitCommandClearsPlayersLynchVote game = + forAll (arbitraryWerewolf game') $ \caller -> + forAll (arbitraryPlayer game') $ \target -> + let game'' = run_ (apply $ lynchVoteCommand (caller ^. name) (target ^. name)) game' + in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes + where + game' = game { _turn = Villagers } + +prop_quitCommandClearsPlayersSee :: Game -> Property +prop_quitCommandClearsPlayersSee game = + forAll (arbitrarySeer game') $ \caller -> + forAll (arbitraryPlayer game') $ \target -> + let game'' = run_ (apply $ seeCommand (caller ^. name) (target ^. name)) game' + in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes + where + game' = game { _turn = Seers } + +prop_seeCommandErrorsWhenGameIsOver :: Game -> Property +prop_seeCommandErrorsWhenGameIsOver game = + isGameOver game + ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game + +prop_seeCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property +prop_seeCommandErrorsWhenCallerDoesNotExist game caller = + not (doesPlayerExist (caller ^. name) (game ^. players)) + ==> forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) + +prop_seeCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property +prop_seeCommandErrorsWhenTargetDoesNotExist game target = + not (doesPlayerExist (target ^. name) (game ^. players)) + ==> forAll (arbitrarySeer game) $ \caller -> + verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) + +prop_seeCommandErrorsWhenCallerIsDead :: Game -> Property +prop_seeCommandErrorsWhenCallerIsDead game = + forAll (arbitrarySeer game) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors (killPlayer game caller) (seeCommand (caller ^. name) (target ^. name)) + +prop_seeCommandErrorsWhenTargetIsDead :: Game -> Property +prop_seeCommandErrorsWhenTargetIsDead game = + forAll (arbitrarySeer game) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors (killPlayer game target) (seeCommand (caller ^. name) (target ^. name)) + +prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property +prop_seeCommandErrorsWhenNotSeersTurn game = + not (isSeersTurn game) + ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game + +prop_seeCommandErrorsWhenCallerNotSeer :: Game -> Property +prop_seeCommandErrorsWhenCallerNotSeer game = + forAll (arbitraryPlayer game) $ \caller -> + not (isSeer caller) + ==> forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors game (seeCommand (caller ^. name) (target ^. name)) + +prop_seeCommandErrorsWhenCallerHasSeen :: Game -> Property +prop_seeCommandErrorsWhenCallerHasSeen game = + isSeersTurn game + ==> forAll (arbitrarySeer game) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> + let command = seeCommand (caller ^. name) (target ^. name) + in verbose_runCommandErrors (run_ (apply command) game) command + +prop_seeCommandUpdatesSees :: Game -> Property +prop_seeCommandUpdatesSees game = + isSeersTurn game + ==> forAll (arbitrarySeeCommand game) $ \command -> + Map.size (run_ (apply command) game ^. sees) == 1 verbose_runCommandErrors :: Game -> Command -> Property verbose_runCommandErrors game command = whenFail (mapM_ putStrLn [show game, show command, show . fromRight $ run (apply command) game]) (isLeft $ run (apply command) game) 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 @@ -24,16 +24,18 @@ prop_checkGameOverAdvancesTurn, prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive, -- * startGame - prop_startGameStartsWithSeersTurn, prop_startGameUsesGivenPlayers, + prop_startGameStartsWithSeersTurnWhenSeersPresent, + prop_startGameStartsWithWerewolvesTurnWhenSeersAbsent, prop_startGameUsesGivenPlayers, prop_startGameErrorsUnlessUniquePlayerNames, prop_startGameErrorsWhenLessThan7Players, prop_startGameErrorsWhenMoreThan24Players, -- * createPlayers - prop_createPlayersUsesGivenPlayerNames, prop_createPlayersCreatesAlivePlayers, + prop_createPlayersUsesGivenPlayerNames, prop_createPlayersUsesGivenRoles, + prop_createPlayersCreatesAlivePlayers, -- * randomiseRoles - prop_randomiseRolesReturnsNRoles, prop_randomiseRolesProportionsRoles, - prop_randomiseRolesHasOneSeer, + prop_randomiseRolesReturnsNRoles, prop_randomiseRolesUsesGivenRoles, + prop_randomiseRolesProportionsAllegiances, ) where import Control.Lens hiding (elements) @@ -45,12 +47,13 @@ import qualified Data.Map as Map import Data.Text (Text) -import Game.Werewolf.Engine hiding (doesPlayerExist, isGameOver, isSeersTurn, - isVillagersTurn, isWerewolvesTurn, killPlayer) -import Game.Werewolf.Game -import Game.Werewolf.Player -import Game.Werewolf.Role hiding (Villagers, Werewolves, _name) -import Game.Werewolf.Test.Arbitrary +import Game.Werewolf.Engine hiding (doesPlayerExist, isGameOver, isSeersTurn, + isVillagersTurn, isWerewolvesTurn, killPlayer) +import Game.Werewolf.Game +import Game.Werewolf.Player +import Game.Werewolf.Role hiding (Villagers, Werewolves, _name) +import qualified Game.Werewolf.Role as Role +import Game.Werewolf.Test.Arbitrary import Test.QuickCheck import Test.QuickCheck.Monadic @@ -192,11 +195,19 @@ length (nub . map (_allegiance . _role) . filterAlive $ game' ^. players) > 1 ==> not . isGameOver $ run_ checkGameOver game' -prop_startGameStartsWithSeersTurn :: [Player] -> Property -prop_startGameStartsWithSeersTurn players = and [ +prop_startGameStartsWithSeersTurnWhenSeersPresent :: [Player] -> Property +prop_startGameStartsWithSeersTurnWhenSeersPresent players = and [ + any isSeer players, isRight . runExcept . runWriterT $ startGame "" players ] ==> isSeersTurn (fst . fromRight . runExcept . runWriterT $ startGame "" players) +prop_startGameStartsWithWerewolvesTurnWhenSeersAbsent :: [Player] -> Property +prop_startGameStartsWithWerewolvesTurnWhenSeersAbsent players = and [ + isRight . runExcept . runWriterT $ startGame "" players' + ] ==> isWerewolvesTurn (fst . fromRight . runExcept . runWriterT $ startGame "" players') + where + players' = filter (not . isSeer) players + prop_startGameUsesGivenPlayers :: [Player] -> Property prop_startGameUsesGivenPlayers players' = and [ isRight . runExcept . runWriterT $ startGame "" players' @@ -217,22 +228,25 @@ length players > 24 ] ==> isLeft (runExcept . runWriterT $ startGame "" players) -prop_createPlayersUsesGivenPlayerNames :: [Text] -> Property -prop_createPlayersUsesGivenPlayerNames playerNames = monadicIO $ createPlayers playerNames >>= return . (playerNames ==) . map _name +prop_createPlayersUsesGivenPlayerNames :: [Text] -> [Role] -> Property +prop_createPlayersUsesGivenPlayerNames playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . (playerNames ==) . map _name -prop_createPlayersCreatesAlivePlayers :: [Text] -> Property -prop_createPlayersCreatesAlivePlayers playerNames = monadicIO $ createPlayers playerNames >>= return . all ((==) Alive . _state) +prop_createPlayersUsesGivenRoles :: [Text] -> [Role] -> Property +prop_createPlayersUsesGivenRoles playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . isSubsequenceOf extraRoles . map _role -prop_randomiseRolesReturnsNRoles :: Int -> Property -prop_randomiseRolesReturnsNRoles n = monadicIO $ randomiseRoles n >>= return . (==) n . length +prop_createPlayersCreatesAlivePlayers :: [Text] -> [Role] -> Property +prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . all ((==) Alive . _state) -prop_randomiseRolesProportionsRoles :: Int -> Property -prop_randomiseRolesProportionsRoles n = monadicIO $ do - roles <- randomiseRoles n +prop_randomiseRolesReturnsNRoles :: [Role] -> Int -> Property +prop_randomiseRolesReturnsNRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . (==) n . length - let werewolvesCount = length $ elemIndices werewolfRole roles +prop_randomiseRolesUsesGivenRoles :: [Role] -> Int -> Property +prop_randomiseRolesUsesGivenRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . isSubsequenceOf extraRoles - return $ n `quot` 6 + 1 == werewolvesCount +prop_randomiseRolesProportionsAllegiances :: [Role] -> Int -> Property +prop_randomiseRolesProportionsAllegiances extraRoles n = monadicIO $ do + roles <- randomiseRoles extraRoles n -prop_randomiseRolesHasOneSeer :: Int -> Property -prop_randomiseRolesHasOneSeer n = monadicIO $ randomiseRoles n >>= return . (1 ==) . length . elemIndices seerRole + let werewolvesCount = length . elemIndices Role.Werewolves $ map _allegiance roles + + return $ n `quot` 6 + 1 == werewolvesCount 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,19 +8,25 @@ {-# OPTIONS_HADDOCK hide, prune #-} module Game.Werewolf.Test.Game ( - prop_newGameStartsWithSeersTurn, prop_newGameStartsWithSeesEmpty, + prop_newGameStartsWithSeersTurnWhenSeersPresent, + prop_newGameStartsWithWerewolvesTurnWhenSeersAbsent, prop_newGameStartsWithSeesEmpty, prop_newGameStartsWithVotesEmpty, prop_newGameUsesGivenPlayers, ) where import Control.Lens -import Data.Map as Map +import qualified Data.Map as Map import Game.Werewolf.Game import Game.Werewolf.Player -prop_newGameStartsWithSeersTurn :: [Player] -> Bool -prop_newGameStartsWithSeersTurn players = isSeersTurn $ newGame players +import Test.QuickCheck + +prop_newGameStartsWithSeersTurnWhenSeersPresent :: [Player] -> Property +prop_newGameStartsWithSeersTurnWhenSeersPresent players = any isSeer players ==> isSeersTurn (newGame players) + +prop_newGameStartsWithWerewolvesTurnWhenSeersAbsent :: [Player] -> Bool +prop_newGameStartsWithWerewolvesTurnWhenSeersAbsent players = isWerewolvesTurn (newGame $ filter (not . isSeer) players) prop_newGameStartsWithSeesEmpty :: [Player] -> Bool prop_newGameStartsWithSeesEmpty players = Map.null $ newGame players ^. sees diff --git a/werewolf.cabal b/werewolf.cabal --- a/werewolf.cabal +++ b/werewolf.cabal @@ -1,5 +1,5 @@ name: werewolf -version: 0.2.0.2 +version: 0.3.0.0 author: Henry J. Wylde maintainer: public@hjwylde.com @@ -31,6 +31,7 @@ Werewolf.Commands.End, Werewolf.Commands.Help, Werewolf.Commands.Interpret, + Werewolf.Commands.Quit, Werewolf.Commands.See, Werewolf.Commands.Start, Werewolf.Commands.Vote,