diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,8 +2,15 @@ #### Upcoming +#### v0.2.0.0 + +*Major* + +* Added the Seer role. ([#4](https://github.com/hjwylde/werewolf/issues/4)) +* Removed the need to encode / decode to JSON for the state file. ([#9](https://github.com/hjwylde/werewolf/issues/9)) + #### v0.1.0.0 *Major* -* Initial implementation with villagers and werewolves. +* Initial implementation with Villagers and Werewolves. ([#1](https://github.com/hjwylde/werewolf/issues/1)) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,17 +9,18 @@ ### Game description -Deep in the American countryside, the little town of Millers Hollow has recently been infiltrated by werewolves. -Each night, murders are committed by the villagers, who due to some mysterious phenomenon (possibly the greenhouse effect) have become werewolves. +Deep in the American countryside, the little town of Millers Hollow has recently been infiltrated by Werewolves. +Each night, murders are committed by the Villagers, who due to some mysterious phenomenon (possibly the greenhouse effect) have become Werewolves. It is now time to take control and eliminate this ancient evil, before the town loses its last few inhabitants. Objective of the Game: -For the villagers: kill all of the werewolves. -For the werewolves: kill all of the villagers. +For the Villagers: kill all of the Werewolves. +For the Werewolves: kill all of the Villagers. #### Roles The current implemented roles are: +* Seer. * Villager. * Werewolf. @@ -51,9 +52,13 @@ E.g., to start a game: ```bash > werewolf --caller @foo start @foo @bar @baz @qux @quux @corge @grault -{"ok":true,"messages":[{"to":null,"message":"Night falls, the town is asleep. The werewolves wake -up, recognise one another and choose a new victim."},{"to":["@foo"],"message":"You slip away -silently from your home."},{"to":["@bar"],"message":"ZzzZZzzz, you're sound asleep."},...]} +{"ok":true,"messages":[ + {"to":["@foo"],"message":"You're a Villager.\nAn ordinary townsperson humbly living in Millers Hollow.\n"}, + ..., + {"to":null,"message":"Night falls, the townsfolk are asleep."}, + {"to":null,"message":"The Seers wake up."}, + {"to":["@grault"],"message":"Who's allegiance would you like to see?"} + ]} ``` In this example, user _@foo_ ran the `start` command with the player names as arguments. @@ -65,9 +70,20 @@ The `to` header on a message may either be `null` for a public message or have a list of intended recipients. -Let's have _@foo_, a werewolf, vote to kill a villager. +It's the Seers' turn now. ```bash -> werewolf --caller @foo vote @bar +> werewolf --caller @grault see @qux +{"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?"} + ]} +``` + +Let's have _@bar_, a Werewolf, vote to kill a Villager. +```bash +> werewolf --caller @bar vote @foo {"ok":true,"messages":[]} ``` @@ -75,22 +91,23 @@ In this implementation of werewolf votes are only revealed once tallied. ```bash -> werewolf --caller @foo vote @bar -{"ok":false,"messages":[{"to":["@foo"],"message":"You've already voted!"}]} +> werewolf --caller @bar vote @foo +{"ok":false,"messages":[{"to":["@bar"],"message":"You've already voted!"}]} ``` -Here the command was unsuccessful and an error message is sent to _@foo_. +Here the command was unsuccessful and an error message is sent to _@bar_. Note that even though the command was unsuccessful, the chat client interface probably won't need to do anything special. Relaying the error message back to the user should suffice. ```bash -> werewolf --caller @qux vote @bar -{"ok":true,"messages":[{"to":["@foo","@baz"],"message":"@baz voted to kill -@bar."},{"to":["@foo","@baz"],"message":"@foo voted to kill @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 spilling out over the cobblestones. From the look of their -personal effects, you deduce they were a Villager."}]} +> werewolf --caller @corge vote @foo +{"ok":true,"messages":[ + {"to":["@bar","@corge"],"message":"@bar voted to kill @foo."}, + {"to":["@bar","@corge"],"message":"@corge voted to kill @foo."}, + {"to":null,"message":"The sun rises. Everybody wakes up and opens their eyes..."}, + {"to":null,"message":"As you open them you notice a door broken down and @foo's guts spilling out over the cobblestones. From the look of their personal effects, you deduce they were a Villager."} + ]} ``` And so on. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -18,6 +18,7 @@ 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.See as See import qualified Werewolf.Commands.Start as Start import qualified Werewolf.Commands.Vote as Vote import Werewolf.Options @@ -30,5 +31,6 @@ 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 diff --git a/app/Werewolf/Commands/End.hs b/app/Werewolf/Commands/End.hs --- a/app/Werewolf/Commands/End.hs +++ b/app/Werewolf/Commands/End.hs @@ -28,7 +28,9 @@ -- | Handle. handle :: MonadIO m => Text -> m () handle callerName = do - unlessM doesGameExist $ exitWith failure { messages = [privateMessage [callerName] "No game is running."] } + unlessM doesGameExist $ exitWith failure { + messages = [privateMessage [callerName] "No game is running."] + } deleteGame 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 @@ -22,7 +22,6 @@ import Control.Lens import Control.Monad.IO.Class -import Data.List import Data.Text (Text) import qualified Data.Text as T @@ -40,60 +39,115 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () -handle callerName (Options (Just Commands)) = exitWith success { messages = map (privateMessage [callerName]) [ - "Usage: COMMAND ARG ...", - "", +handle callerName (Options (Just Commands)) = exitWith success { + messages = map (privateMessage [callerName]) commandsMessages + } +handle callerName (Options (Just Description)) = exitWith success { + messages = map (privateMessage [callerName]) descriptionMessages + } +handle callerName (Options (Just Roles)) = exitWith success { + messages = map (\role -> privateMessage [callerName] $ T.unlines [ + T.snoc (role ^. Role.name) ':', + role ^. description, + role ^. advice + ]) allRoles + } +handle callerName (Options (Just Rules)) = exitWith success { + messages = map (privateMessage [callerName]) rulesMessages + } +handle callerName (Options Nothing) = exitWith success { + messages = map (privateMessage [callerName]) helpMessages + } + +commandsMessages :: [Text] +commandsMessages = map T.unlines [[ + "Usage: COMMAND ARG ..." + ], [ "Available commands:", " end - end the current game", " help - help documents", + " see - see a player's allegiance", " start - start a new game", - " vote - vote against a player", - "", + " vote - vote against a player" + ], [ "End:", "Usage: end", - " Ends the current game.", - "", + " Ends the current game." + ], [ + "See:", + "Usage: see PLAYER", + " See a player's allegiance. A Seer may determine a player's allegiance once per day." + ], [ "Start:", "Usage: start PLAYER ...", - " Starts a new game with the given players. A game requires at least 7 players.", - "", + " Starts a new game with the given players. A game requires at least 7 players." + ], [ "Vote:", "Usage: vote 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." - ] } -handle callerName (Options (Just Description)) = exitWith success { messages = map (privateMessage [callerName]) [ - "Deep in the American countryside, the little town of Millers Hollow has recently been infiltrated by werewolves.", - "Each night, murders are committed by the villagers, who due to some mysterious phenomenon (possibly the greenhouse effect) have become werewolves.", - "It is now time to take control and eliminate this ancient evil, before the town loses its last few inhabitants.", - "", + T.unwords [ + " Vote against a player.", + "A townsperson may vote at daytime to lynch someone", + "and a Werewolf may vote at nighttime to kill a Villager." + ] + ]] + +descriptionMessages :: [Text] +descriptionMessages = map T.unlines [[ + T.unwords [ + "Deep in the American countryside,", + "the little town of Millers Hollow has recently been infiltrated by Werewolves." + ], + T.unwords [ + "Each night, murders are committed by the Villagers,", + "who due to some mysterious phenomenon (possibly the greenhouse effect)", + "have become Werewolves." + ], + T.unwords [ + "It is now time to take control and eliminate this ancient evil,", + "before the town loses its last few inhabitants." + ] + ], [ "Objective of the Game:", - "For the villagers: kill all of the werewolves.", - "For the werewolves: kill all of the villagers." - ] } -handle callerName (Options (Just Roles)) = exitWith success { messages = map (privateMessage [callerName]) - $ intercalate [""] $ map (\role -> [ - T.snoc (role ^. Role.name) ':', - role ^. description, - role ^. advice - ]) allRoles - } -handle callerName (Options (Just Rules)) = exitWith success { messages = map (privateMessage [callerName]) [ - "Each night, the werewolves bite, kill and devour one villager. During the day they try to conceal their identity and vile deeds from the villagers. Depending upon the number of players and variants used in the game, there are 1, 2, 3 or 4 werewolves in play.", - "Each day, the survivors gather in the town square and try to discover who the werewolves are. This is done by studying the other player's social behaviours for hidden signs of lycanthropy. After discussing and debating, the villagers vote to lynch a suspect, who is then hanged, burned and eliminated from the game.", - "", - "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.", - "1. The town falls asleep.", - "2. The werewolves wake up and select a victim.", - "3. The town wakes up and find the victim.", - "4. The town vote to lynch a suspect.", + "For the Villagers: kill all of the Werewolves.", + "For the Werewolves: kill all of the Villagers." + ]] + +rulesMessages :: [Text] +rulesMessages = map T.unlines [[ + T.unwords [ + "Each night, the Werewolves bite, kill and devour one Villager.", + "During the day they try to conceal their identity and vile deeds from the Villagers.", + "Depending upon the number of players and variants used in the game,", + "there are 1, 2, 3 or 4 Werewolves in play." + ], + T.unwords [ + "Each day,", + "the survivors gather in the town square and try to discover who the Werewolves are.", + "This is done by studying the other player's social behaviours", + "for hidden signs of lycanthropy.", + "After discussing and debating, the Villagers vote to lynch a suspect,", + "who is then hanged, burned and eliminated from the game." + ] + ], [ + T.unwords [ + "Each player is informed of their role (see `help roles' for a list)", + "at the start of the game. A game begins at night and follows a standard cycle." + ], + "1. The townsfolk fall asleep.", + "2. The Seers wake up and each see someone.", + "3. The Werewolves wake up and select a victim.", + "4. The townsfolk wake up and find the victim.", + "5. The townsfolk vote to lynch a suspect.", "The game is over when a single townsperson is left alive." - ] } -handle callerName (Options Nothing) = exitWith success { messages = map (privateMessage [callerName]) [ - "Usage: help COMMAND", - "", + ]] + +helpMessages :: [Text] +helpMessages = map T.unlines [[ + "Usage: help COMMAND" + ], [ "Available commands:", " commands - print the in-game commands", " description - print the game description", " rules - print the game rules", " roles - print the roles and their description" - ] } + ]] 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 @@ -25,6 +25,7 @@ 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 @@ -43,6 +44,7 @@ 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/See.hs b/app/Werewolf/Commands/See.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Commands/See.hs @@ -0,0 +1,51 @@ +{-| +Module : Werewolf.Commands.See +Description : Options and handler for the see subcommand. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Options and handler for the see subcommand. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Werewolf.Commands.See ( + -- * Options + Options(..), + + -- * Handle + handle, +) where + +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf.Command +import Game.Werewolf.Engine +import Game.Werewolf.Response + +-- | Options. +data Options = Options + { argTarget :: Text + } deriving (Eq, Show) + +-- | Handle. +handle :: MonadIO m => Text -> Options -> m () +handle callerName (Options targetName) = do + unlessM doesGameExist $ exitWith failure { + messages = [privateMessage [callerName] "No game is running."] + } + + game <- readGame + + let command = seeCommand callerName targetName + + 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 @@ -21,6 +21,7 @@ import Control.Monad.Except import Control.Monad.Extra +import Control.Monad.Writer import Data.Text (Text) @@ -35,10 +36,12 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () handle callerName (Options playerNames) = do - whenM doesGameExist $ exitWith failure { messages = [privateMessage [callerName] "A game is already running."] } + whenM doesGameExist $ exitWith failure { + messages = [privateMessage [callerName] "A game is already running."] + } players <- createPlayers playerNames - case runExcept (startGame callerName players) of - Left errorMessages -> exitWith failure { messages = errorMessages } - Right game -> writeGame game >> exitWith success { messages = newGameMessages players } + case runExcept (runWriterT $ startGame callerName players) of + Left errorMessages -> exitWith failure { messages = errorMessages } + Right (game, messages) -> writeGame game >> exitWith success { messages = messages } 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 @@ -19,19 +19,16 @@ handle, ) where -import Control.Lens import Control.Monad.Except import Control.Monad.Extra import Control.Monad.State import Control.Monad.Writer -import Data.Maybe -import Data.Text (Text) +import Data.Text (Text) import Game.Werewolf.Command -import Game.Werewolf.Engine +import Game.Werewolf.Engine hiding (isVillagersTurn) import Game.Werewolf.Game -import Game.Werewolf.Player as Player import Game.Werewolf.Response -- | Options. @@ -42,18 +39,17 @@ -- | Handle. handle :: MonadIO m => Text -> Options -> m () handle callerName (Options targetName) = do - unlessM doesGameExist $ exitWith failure { messages = [privateMessage [callerName] "No game is running."] } + unlessM doesGameExist $ exitWith failure { + messages = [privateMessage [callerName] "No game is running."] + } game <- readGame - let mCaller = findByName callerName (game ^. players) - let mTarget = findByName targetName (game ^. players) - - when (isNothing mCaller) $ exitWith failure { messages = [playerDoesNotExistMessage callerName callerName] } - when (isNothing mTarget) $ exitWith failure { messages = [playerDoesNotExistMessage callerName targetName] } - - let command = Vote { voter = fromJust mCaller, target = fromJust mTarget } + let command = (if isVillagersTurn game + then lynchVoteCommand + else killVoteCommand + ) callerName targetName - case runExcept (runWriterT $ execStateT (validateCommand command >> applyCommand command >> checkGameOver) game) of + 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/Options.hs b/app/Werewolf/Options.hs --- a/app/Werewolf/Options.hs +++ b/app/Werewolf/Options.hs @@ -23,6 +23,7 @@ import qualified Werewolf.Commands.Help as Help import qualified Werewolf.Commands.Interpret as Interpret +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 @@ -40,6 +41,7 @@ = End | Help Help.Options | Interpret Interpret.Options + | See See.Options | Start Start.Options | Vote Vote.Options deriving (Eq, Show) @@ -73,6 +75,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 "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") ]) @@ -91,6 +94,9 @@ interpret :: Parser Command interpret = Interpret . Interpret.Options <$> many (T.pack <$> strArgument (metavar "COMMAND ARG...")) + +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...")) 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 @@ -10,17 +10,69 @@ -} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Game.Werewolf.Command ( -- * Command Command(..), + + -- ** Instances + seeCommand, killVoteCommand, lynchVoteCommand, noopCommand, ) where -import Game.Werewolf.Player +import Control.Lens hiding (only) +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State hiding (state) +import Control.Monad.Writer -data Command = Vote - { voter :: Player - , target :: Player - } deriving (Eq, Show) +import qualified Data.Map as Map +import Data.Text (Text) + +import Game.Werewolf.Engine +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 + + unlessM isWerewolvesTurn $ throwError [playerCannotDoThatMessage callerName] + unlessM (isPlayerWerewolf callerName) $ throwError [playerCannotDoThatMessage callerName] + whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName] + + votes %= Map.insert callerName targetName + +lynchVoteCommand :: Text -> Text -> Command +lynchVoteCommand callerName targetName = Command $ do + validateArguments callerName targetName + + unlessM isVillagersTurn $ throwError [playerCannotDoThatMessage callerName] + whenJustM (getPlayerVote callerName) . const $ throwError [playerHasAlreadyVotedMessage callerName] + + votes %= Map.insert callerName targetName + +noopCommand :: Command +noopCommand = Command $ return () + +validateArguments :: (MonadError [Message] m, MonadState Game m) => Text -> Text -> m () +validateArguments callerName targetName = do + whenM isGameOver $ throwError [gameIsOverMessage callerName] + unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] + unlessM (doesPlayerExist targetName) $ throwError [playerDoesNotExistMessage callerName targetName] + + whenM (isPlayerDead callerName) $ throwError [playerIsDeadMessage callerName] + whenM (isPlayerDead targetName) $ throwError [targetIsDeadMessage callerName targetName] 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 @@ -9,154 +9,179 @@ Engine functions. -} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Game.Werewolf.Engine ( - -- * Command - validateCommand, applyCommand, checkGameOver, + -- * Loop + checkTurn, checkGameOver, -- * Game - -- ** Manipulating - startGame, isGameOver, getPlayerVote, + -- ** Manipulations + startGame, killPlayer, + -- ** Queries + isSeersTurn, isVillagersTurn, isWerewolvesTurn, isGameOver, getPlayerSee, getPlayerVote, + -- ** Reading and writing defaultFilePath, writeGame, readGame, deleteGame, doesGameExist, -- * Player - createPlayers, doesPlayerExist, + -- ** Manipulations + createPlayers, + + -- ** Queries + doesPlayerExist, isPlayerSeer, isPlayerVillager, isPlayerWerewolf, isPlayerAlive, isPlayerDead, + -- * Role randomiseRoles, ) where -import Control.Lens hiding (only) +import Control.Lens hiding (cons, only) import Control.Monad.Except -import Control.Monad.Extra import Control.Monad.Random +import Control.Monad.State hiding (state) import Control.Monad.Writer -import Control.Monad.State hiding (state) -import Data.Aeson hiding ((.=)) import Data.List.Extra -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BS -import Data.Text (Text) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T -import Game.Werewolf.Game hiding (isGameOver) -import qualified Game.Werewolf.Game as Game -import Game.Werewolf.Command +import Game.Werewolf.Game hiding (isGameOver, isSeersTurn, isVillagersTurn, + isWerewolvesTurn, killPlayer) +import qualified Game.Werewolf.Game as Game +import Game.Werewolf.Player hiding (doesPlayerExist) import qualified Game.Werewolf.Player as Player -import Game.Werewolf.Player hiding (doesPlayerExist) -import Game.Werewolf.Response -import Game.Werewolf.Role as Role +import Game.Werewolf.Response +import Game.Werewolf.Role as Role hiding (Villagers, Werewolves) import System.Directory -import System.Exit import System.FilePath import System.Random.Shuffle -validateCommand :: MonadError [Message] m => MonadState Game m => Command -> m () -validateCommand (Vote voter target) = do - whenM isGameOver $ throwError [gameIsOverMessage voterName] - unlessM (doesPlayerExist voterName) $ throwError [playerDoesNotExistMessage voterName voterName] - unlessM (doesPlayerExist targetName) $ throwError [playerDoesNotExistMessage voterName targetName] +checkTurn :: (MonadState Game m, MonadWriter [Message] m) => m () +checkTurn = get >>= \game -> checkTurn' >> get >>= \game' -> unless (game == game') checkTurn - when (isDead voter) $ throwError [playerIsDeadMessage voterName] - when (isDead target) $ throwError [targetIsDeadMessage voterName targetName] +checkTurn' :: (MonadState Game m, MonadWriter [Message] m) => m () +checkTurn' = use turn >>= \turn' -> case turn' of + Seers -> do + seersCount <- uses players (length . filterAlive . filterSeers) + votes' <- use sees - whenJustM (getPlayerVote voter) $ const (throwError [playerHasAlreadyVotedMessage voterName]) + when (seersCount == Map.size votes') $ do + forM_ (Map.toList votes') $ \(seerName, targetName) -> do + target <- uses players (findByName_ targetName) - get >>= \game -> when (isWerewolvesTurn game && not (isWerewolf voter)) $ throwError [playerCannotDoThatMessage voterName] - where - voterName = voter ^. Player.name - targetName = target ^. Player.name + tell [playerSeenMessage seerName target] -applyCommand :: (MonadError [Message] m, MonadState Game m, MonadWriter [Message] m) => Command -> m () -applyCommand (Vote voter target) = do - turn . votes %= Map.insert voterName targetName + advanceTurn - use turn >>= \turn' -> case turn' of - Villagers {} -> applyLynchVote - Werewolves {} -> applyKillVote - NoOne -> throwError [gameIsOverMessage voterName] - where - voterName = voter ^. Player.name - targetName = target ^. Player.name + Werewolves -> do + werewolvesCount <- uses players (length . filterAlive . filterWerewolves) + votes' <- use votes -applyKillVote :: (MonadState Game m, MonadWriter [Message] m) => m () -applyKillVote = do - werewolvesCount <- uses players (length . filterAlive . filterWerewolves) - votes <- use $ turn . votes + when (werewolvesCount == Map.size votes') $ do + werewolfNames <- uses players (map Player._name . filterWerewolves) + tell $ map (uncurry $ playerMadeKillVoteMessage werewolfNames) (Map.toList votes') - when (werewolvesCount == Map.size votes) $ do - werewolfNames <- uses players (map Player._name . filterWerewolves) - tell $ map (uncurry $ playerMadeKillVoteMessage werewolfNames) (Map.toList votes) + advanceTurn - turn .= newVillagersTurn - tell villagersTurnMessages + 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) - 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)] - killPlayer target - tell [playerKilledMessage (target ^. Player.name) (target ^. Player.role . Role.name)] + Villagers -> do + playersCount <- uses players (length . filterAlive) + votes' <- use votes -applyLynchVote :: (MonadState Game m, MonadWriter [Message] m) => m () -applyLynchVote = do - playersCount <- uses players (length . filterAlive) - votes <- use $ turn . votes + when (playersCount == Map.size votes') $ do + tell $ map (uncurry playerMadeLynchVoteMessage) (Map.toList votes') - when (playersCount == Map.size votes) $ do - tell $ map (uncurry playerMadeLynchVoteMessage) (Map.toList votes) + let mLynchedName = only . last $ groupSortOn (length . flip elemIndices (Map.elems votes')) (nub $ Map.elems votes') + case mLynchedName of + Nothing -> tell [noPlayerLynchedMessage] + Just lynchedName -> do + target <- uses players (findByName_ lynchedName) - let mLynchedName = only . last $ groupSortOn (length . flip elemIndices (Map.elems votes)) (nub $ Map.elems votes) - case mLynchedName of - Nothing -> tell [noPlayerLynchedMessage] - Just lynchedName -> do - target <- uses players (findByName_ lynchedName) + killPlayer target + tell [playerLynchedMessage (target ^. Player.name) (target ^. Player.role . Role.name)] - killPlayer target - tell [playerLynchedMessage (target ^. Player.name) (target ^. Player.role . Role.name)] + advanceTurn - turn .= newWerewolvesTurn - tell werewolvesTurnMessages + NoOne -> return () only :: [a] -> Maybe a only [a] = Just a only _ = Nothing +advanceTurn :: (MonadState Game m, MonadWriter [Message] m) => m () +advanceTurn = do + turn' <- use turn + alivePlayers <- uses players filterAlive + + let nextTurn = head . drop1 $ filter (turnAvailable 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 _ Villagers = True + turnAvailable _ Werewolves = True + turnAvailable _ NoOne = False + checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do - alivePlayers <- uses players filterAlive + aliveAllegiances <- uses players $ nub . map (_allegiance . _role) . filterAlive - case length alivePlayers of + case length aliveAllegiances of 0 -> turn .= NoOne >> tell [gameOverMessage Nothing] - 1 -> turn .= NoOne >> tell [gameOverMessage . Just $ head alivePlayers ^. Player.role . Role.name] + 1 -> turn .= NoOne >> tell [gameOverMessage . Just . T.pack . show $ head aliveAllegiances] _ -> return () -startGame :: MonadError [Message] m => Text -> [Player] -> m Game +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."] 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 + return $ newGame players where playerNames = map Player._name players +killPlayer :: MonadState Game m => Player -> m () +killPlayer player = players %= map (\player' -> if player' == player then player' & state .~ Dead else player') + +isSeersTurn :: MonadState Game m => m Bool +isSeersTurn = gets Game.isSeersTurn + +isVillagersTurn :: MonadState Game m => m Bool +isVillagersTurn = gets Game.isVillagersTurn + +isWerewolvesTurn :: MonadState Game m => m Bool +isWerewolvesTurn = gets Game.isWerewolvesTurn + isGameOver :: MonadState Game m => m Bool isGameOver = gets Game.isGameOver -getPlayerVote :: MonadState Game m => Player -> m (Maybe Text) -getPlayerVote player = use $ turn . votes . at (player ^. Player.name) +getPlayerSee :: MonadState Game m => Text -> m (Maybe Text) +getPlayerSee playerName = use $ sees . at playerName +getPlayerVote :: MonadState Game m => Text -> m (Maybe Text) +getPlayerVote playerName = use $ votes . at playerName + defaultFilePath :: MonadIO m => m FilePath defaultFilePath = ( defaultFileName) <$> liftIO getHomeDirectory @@ -164,10 +189,10 @@ defaultFileName = ".werewolf" readGame :: MonadIO m => m Game -readGame = liftIO $ defaultFilePath >>= BS.readFile >>= either die return . eitherDecode +readGame = liftIO . fmap read $ defaultFilePath >>= readFile writeGame :: MonadIO m => Game -> m () -writeGame game = defaultFilePath >>= liftIO . flip BS.writeFile (encode game) +writeGame game = liftIO $ defaultFilePath >>= flip writeFile (show game) deleteGame :: MonadIO m => m () deleteGame = liftIO $ defaultFilePath >>= removeFile @@ -181,11 +206,24 @@ doesPlayerExist :: MonadState Game m => Text -> m Bool doesPlayerExist name = uses players $ Player.doesPlayerExist name -killPlayer :: MonadState Game m => Player -> m () -killPlayer player = players %= map (\player' -> if player' == player then player' & state .~ Dead else player') +isPlayerSeer :: MonadState Game m => Text -> m Bool +isPlayerSeer name = uses players $ isSeer . findByName_ name +isPlayerVillager :: MonadState Game m => Text -> m Bool +isPlayerVillager name = uses players $ isVillager . findByName_ name + +isPlayerWerewolf :: MonadState Game m => Text -> m Bool +isPlayerWerewolf name = uses players $ isWerewolf . findByName_ name + +isPlayerAlive :: MonadState Game m => Text -> m Bool +isPlayerAlive name = uses players $ isAlive . findByName_ name + +isPlayerDead :: MonadState Game m => Text -> m Bool +isPlayerDead name = uses players $ isDead . findByName_ name + randomiseRoles :: MonadIO m => Int -> m [Role] -randomiseRoles n = liftIO . evalRandIO . shuffleM $ werewolfRoles ++ villagerRoles +randomiseRoles n = liftIO . evalRandIO . shuffleM $ seerRoles ++ werewolfRoles ++ villagerRoles where - werewolfRoles = replicate (n `quot` 6 + 1) werewolf - villagerRoles = replicate (n - length werewolfRoles) villager + seerRoles = [seerRole] + werewolfRoles = replicate (n `quot` 6 + 1) werewolfRole + villagerRoles = replicate (n - length (seerRoles ++ 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 @@ -9,86 +9,63 @@ Game and turn data structures. -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Game.Werewolf.Game ( -- * Game Game(..), turn, players, newGame, - -- * Turn - Turn(..), votes, - newVillagersTurn, newWerewolvesTurn, + -- ** Manipulations + killPlayer, -- ** Queries - isVillagersTurn, isWerewolvesTurn, isGameOver, + isSeersTurn, isVillagersTurn, isWerewolvesTurn, isGameOver, + + -- * Turn + Turn(..), sees, votes, + turnRotation, ) where import Control.Lens -import Data.Aeson -#if !MIN_VERSION_aeson(0,10,0) -import Data.Aeson.Types -#endif import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import Game.Werewolf.Player -import GHC.Generics data Game = Game { _turn :: Turn , _players :: [Player] - } deriving (Eq, Generic, Show) - -instance FromJSON Game - -instance ToJSON Game where - toJSON = genericToJSON defaultOptions -#if MIN_VERSION_aeson(0,10,0) - toEncoding = genericToEncoding defaultOptions -#endif - -data Turn - = Villagers { _votes :: Map Text Text } - | Werewolves { _votes :: Map Text Text } - | NoOne - deriving (Eq, Generic, Show) - -instance FromJSON Turn + , _sees :: Map Text Text + , _votes :: Map Text Text + } deriving (Eq, Read, Show) -instance ToJSON Turn where - toJSON = genericToJSON defaultOptions -#if MIN_VERSION_aeson(0,10,0) - toEncoding = genericToEncoding defaultOptions -#endif +data Turn = Seers | Villagers | Werewolves | NoOne + deriving (Eq, Read, Show) makeLenses ''Game makeLenses ''Turn newGame :: [Player] -> Game -newGame = Game newWerewolvesTurn +newGame players = Game (head turnRotation) players Map.empty Map.empty -newVillagersTurn :: Turn -newVillagersTurn = Villagers Map.empty +killPlayer :: Game -> Player -> Game +killPlayer game player = game & players %~ map (\player' -> if player' == player then player' & state .~ Dead else player') -newWerewolvesTurn :: Turn -newWerewolvesTurn = Werewolves Map.empty +isSeersTurn :: Game -> Bool +isSeersTurn game = game ^. turn == Seers isVillagersTurn :: Game -> Bool -isVillagersTurn (Game (Villagers {}) _) = True -isVillagersTurn _ = False +isVillagersTurn game = game ^. turn == Villagers isWerewolvesTurn :: Game -> Bool -isWerewolvesTurn (Game (Werewolves {}) _) = True -isWerewolvesTurn _ = False +isWerewolvesTurn game = game ^. turn == Werewolves isGameOver :: Game -> Bool -isGameOver (Game turn _) = turn == NoOne +isGameOver game = game ^. turn == NoOne + +turnRotation :: [Turn] +turnRotation = cycle [Seers, Werewolves, Villagers, NoOne] 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 @@ -9,10 +9,7 @@ Player data structures. -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Game.Werewolf.Player ( -- * Player @@ -23,10 +20,10 @@ findByName, findByName_, -- ** Filters - filterVillagers, filterWerewolves, + filterSeers, filterVillagers, filterWerewolves, -- ** Queries - doesPlayerExist, isVillager, isWerewolf, isAlive, isDead, + doesPlayerExist, isSeer, isVillager, isWerewolf, isAlive, isDead, -- * State State(..), @@ -37,41 +34,20 @@ import Control.Lens -import Data.Aeson -#if !MIN_VERSION_aeson(0,10,0) -import Data.Aeson.Types -#endif import Data.List import Data.Maybe import Data.Text (Text) import Game.Werewolf.Role hiding (name, _name) -import GHC.Generics data Player = Player { _name :: Text , _role :: Role , _state :: State - } deriving (Eq, Generic, Show) - -instance FromJSON Player - -instance ToJSON Player where - toJSON = genericToJSON defaultOptions -#if MIN_VERSION_aeson(0,10,0) - toEncoding = genericToEncoding defaultOptions -#endif + } deriving (Eq, Read, Show) data State = Alive | Dead - deriving (Eq, Generic, Show) - -instance FromJSON State - -instance ToJSON State where - toJSON = genericToJSON defaultOptions -#if MIN_VERSION_aeson(0,10,0) - toEncoding = genericToEncoding defaultOptions -#endif + deriving (Eq, Read, Show) makeLenses ''Player @@ -84,23 +60,26 @@ findByName_ :: Text -> [Player] -> Player findByName_ name = fromJust . findByName name -filterRole :: Role -> [Player] -> [Player] -filterRole role = filter ((==) role . _role) +filterSeers :: [Player] -> [Player] +filterSeers = filter isSeer filterVillagers :: [Player] -> [Player] -filterVillagers = filterRole villager +filterVillagers = filter isVillager filterWerewolves :: [Player] -> [Player] -filterWerewolves = filterRole werewolf +filterWerewolves = filter isWerewolf doesPlayerExist :: Text -> [Player] -> Bool doesPlayerExist name = isJust . findByName name +isSeer :: Player -> Bool +isSeer player = player ^. role == seerRole + isVillager :: Player -> Bool -isVillager player = player ^. role == villager +isVillager player = player ^. role == villagerRole isWerewolf :: Player -> Bool -isWerewolf player = player ^. role == werewolf +isWerewolf player = player ^. role == werewolfRole isAlive :: Player -> Bool isAlive player = player ^. state == Alive @@ -108,11 +87,8 @@ isDead :: Player -> Bool isDead player = player ^. state == Dead -filterState :: State -> [Player] -> [Player] -filterState state = filter ((==) state . _state) - filterAlive :: [Player] -> [Player] -filterAlive = filterState Alive +filterAlive = filter isAlive filterDead :: [Player] -> [Player] -filterDead = filterState Dead +filterDead = filter isDead 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 @@ -25,33 +25,37 @@ -- * Message Message(..), - emptyMessage, publicMessage, privateMessage, + publicMessage, privateMessage, -- ** Game messages - newGameMessages, villagersTurnMessages, werewolvesTurnMessages, playerMadeKillVoteMessage, - playerKilledMessage, noPlayerKilledMessage, playerMadeLynchVoteMessage, playerLynchedMessage, - noPlayerLynchedMessage, gameOverMessage, + newGameMessages, turnMessages, seersTurnMessages, villagersTurnMessage, werewolvesTurnMessages, + playerSeenMessage, playerMadeKillVoteMessage, playerKilledMessage, noPlayerKilledMessage, + playerMadeLynchVoteMessage, playerLynchedMessage, noPlayerLynchedMessage, gameOverMessage, -- ** Error messages playerDoesNotExistMessage, playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, - gameIsOverMessage, playerIsDeadMessage, playerHasAlreadyVotedMessage, targetIsDeadMessage, + gameIsOverMessage, playerIsDeadMessage, playerHasAlreadySeenMessage, + playerHasAlreadyVotedMessage, targetIsDeadMessage, ) where -import Control.Lens +import Control.Lens hiding (singular) import Control.Monad.IO.Class import Data.Aeson #if !MIN_VERSION_aeson(0,10,0) import Data.Aeson.Types #endif -import qualified Data.ByteString.Lazy.Char8 as BS import Data.List -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Encoding as T +import qualified Data.Text.Lazy.IO as T -import Game.Werewolf.Player as Player -import Game.Werewolf.Role -import GHC.Generics +import Game.Werewolf.Game +import Game.Werewolf.Player +import Game.Werewolf.Role (allegiance, description, singular) +import qualified Game.Werewolf.Role as Role +import GHC.Generics import qualified System.Exit as Exit @@ -75,7 +79,7 @@ failure = Response False [] exitWith :: MonadIO m => Response -> m () -exitWith response = liftIO $ BS.putStrLn (encode response) >> Exit.exitSuccess +exitWith response = liftIO $ T.putStrLn (T.decodeUtf8 $ encode response) >> Exit.exitSuccess exitSuccess :: MonadIO m => m () exitSuccess = exitWith success @@ -96,9 +100,6 @@ toEncoding = genericToEncoding defaultOptions #endif -emptyMessage :: Message -emptyMessage = Message Nothing "" - publicMessage :: Text -> Message publicMessage = Message Nothing @@ -106,36 +107,40 @@ privateMessage to = Message (Just to) newGameMessages :: [Player] -> [Message] -newGameMessages players = concat [ - werewolvesTurnMessages, - map newPlayerMessage players, - werewolvesFirstTurnMessages (filterWerewolves players) - ] +newGameMessages players = map (newPlayerMessage players) players ++ seersTurnMessages (filterSeers players) -newPlayerMessage :: Player -> Message -newPlayerMessage player = privateMessage [player ^. Player.name] (message' $ player ^. role) - where - message' role - | role == villager = "ZzZZzz, you're sound asleep." - | role == werewolf = "You slip away silently from your home." - | otherwise = undefined +nightFallsMessage :: Message +nightFallsMessage = publicMessage "Night falls, the townsfolk are asleep." -werewolvesFirstTurnMessages :: [Player] -> [Message] -werewolvesFirstTurnMessages werewolves = map (\werewolf -> privateMessage [werewolf ^. Player.name] (messageFor werewolf)) werewolves +newPlayerMessage :: [Player] -> Player -> Message +newPlayerMessage players player + | isWerewolf player = privateMessage [player ^. name] $ T.unlines [T.concat ["You're a Werewolf", packMessage], player ^. role . description] + | otherwise = privateMessage [player ^. name] $ T.unlines [T.concat ["You're a ", player ^. role . Role.name, "."], player ^. role . description] where - messageFor werewolf = T.concat $ "As you look around you see the rest of your " : T.intercalate ", " ("pack":names (werewolves \\ [werewolf])) : ["."] - names = map Player._name + packMessage + | length (filterWerewolves players) <= 1 = "." + | otherwise = T.concat [", along with ", T.intercalate "," (map _name $ filterWerewolves players \\ [player]), "."] -villagersTurnMessages :: [Message] -villagersTurnMessages = map publicMessage messages - where - messages = ["The sun rises. Everybody wakes up and opens their eyes..."] +turnMessages :: Turn -> [Player] -> [Message] +turnMessages Seers players = seersTurnMessages $ filter isSeer players +turnMessages Villagers _ = [villagersTurnMessage] +turnMessages Werewolves players = werewolvesTurnMessages $ filter isWerewolf players +turnMessages NoOne _ = undefined -werewolvesTurnMessages :: [Message] -werewolvesTurnMessages = map publicMessage messages - where - messages = ["Night falls, the town is asleep. The werewolves wake up, recognise one another and choose a new victim."] +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) +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 + +playerSeenMessage :: Text -> Player -> Message +playerSeenMessage seerName target = privateMessage [seerName] $ T.concat [target ^. name, " is a ", singular $ target ^. role . allegiance, "."] + playerMadeKillVoteMessage :: [Text] -> Text -> Text -> Message playerMadeKillVoteMessage to voterName targetName = privateMessage to $ T.concat [voterName, " voted to kill ", targetName, "."] @@ -147,30 +152,29 @@ ] noPlayerKilledMessage :: Message -noPlayerKilledMessage = publicMessage "Surprisingly you see everyone present at the town square. Perhaps the werewolves have left Miller's Hollow?" +noPlayerKilledMessage = publicMessage "Surprisingly you see everyone present at the town square. Perhaps the Werewolves have left Miller's Hollow?" playerMadeLynchVoteMessage :: Text -> Text -> Message playerMadeLynchVoteMessage voterName targetName = publicMessage $ T.concat [voterName, " voted to lynch ", targetName, "."] playerLynchedMessage :: Text -> Text -> Message playerLynchedMessage name "Werewolf" = publicMessage $ T.unwords [ - name, - "is tied up to a pyre and set alight.", - "As they scream their body starts to contort and writhe, transforming into a werewolf.", + 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." ] playerLynchedMessage name roleName = publicMessage $ T.concat [ - name, "is tied up to a pyre and set alight.", + 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 ", roleName, "." ] noPlayerLynchedMessage :: Message -noPlayerLynchedMessage = publicMessage "Daylight is wasted as the villagers squabble over whom to tie up. Looks like no one is being burned this day." +noPlayerLynchedMessage = publicMessage "Daylight is wasted as the townsfolk squabble over whom to tie up. Looks like no one is being burned this day." gameOverMessage :: Maybe Text -> Message -gameOverMessage Nothing = publicMessage "The game is over! Everyone died..." -gameOverMessage (Just roleName) = publicMessage $ T.concat ["The game is over! The ", roleName, "s have won."] +gameOverMessage Nothing = publicMessage "The game is over! Everyone died..." +gameOverMessage (Just allegiance) = publicMessage $ T.unwords ["The game is over! The", allegiance, "have won."] playerDoesNotExistMessage :: Text -> Text -> Message playerDoesNotExistMessage to name = privateMessage [to] $ T.unwords ["Player", name, "does not exist."] @@ -186,6 +190,9 @@ playerIsDeadMessage :: Text -> Message playerIsDeadMessage name = privateMessage [name] "Sshh, you're meant to be dead!" + +playerHasAlreadySeenMessage :: Text -> Message +playerHasAlreadySeenMessage name = privateMessage [name] "You've already seen!" playerHasAlreadyVotedMessage :: Text -> Message playerHasAlreadyVotedMessage name = privateMessage [name] "You've already voted!" 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 @@ -9,52 +9,75 @@ Role data structures. -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Game.Werewolf.Role ( -- * Role - Role(..), name, description, advice, + Role(..), name, allegiance, description, advice, -- ** Instances - allRoles, villager, werewolf, -) where + allRoles, seerRole, villagerRole, werewolfRole, -import Control.Lens + -- * Allegiance + Allegiance(..), + singular, +) where -import Data.Aeson -#if !MIN_VERSION_aeson(0,10,0) -import Data.Aeson.Types -#endif -import Data.Text (Text) +import Control.Lens hiding (singular) -import GHC.Generics +import Data.Text as T import Prelude hiding (all) data Role = Role { _name :: Text + , _allegiance :: Allegiance , _description :: Text , _advice :: Text - } deriving (Eq, Generic, Show) + } deriving (Eq, Read, Show) -instance FromJSON Role +allRoles :: [Role] +allRoles = [seerRole, villagerRole, werewolfRole] -instance ToJSON Role where - toJSON = genericToJSON defaultOptions -#if MIN_VERSION_aeson(0,10,0) - toEncoding = genericToEncoding defaultOptions -#endif +seerRole :: Role +seerRole = Role + { _name = "Seer" + , _allegiance = Villagers + , _description = T.unwords + [ "A fortunate teller by other names, with the ability to see into fellow" + , "townsfolk and determine their allegiance." + ] + , _advice = T.unwords + [ "Be extremely careful if you have discovered a Werewolf." + , "It may be worth the pain of revealing yourself in order to identify the player," + , "but avoid doing this too early." + ] + } -makeLenses ''Role +villagerRole :: Role +villagerRole = Role + { _name = "Villager" + , _allegiance = Villagers + , _description = "An ordinary townsperson humbly living in Millers Hollow." + , _advice = + "Bluffing can be a good technique, but you had better be convincing about what you say." + } -allRoles :: [Role] -allRoles = [villager, werewolf] +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." + } -villager :: Role -villager = Role "Villager" "An ordinary townsfolk humbly living in Millers Hollow." "Bluffing can be a good technique, but you had better be convincing about what you say." +data Allegiance = Villagers | Werewolves + deriving (Eq, Read, Show) -werewolf :: Role -werewolf = Role "Werewolf" "A shapeshifting human that, at night, hunts the residents of Millers Hollow." "Voting against your partner can be a good way to deflect suspicion from yourself." +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 @@ -12,31 +12,78 @@ ) 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.HUnit import Test.Tasty.QuickCheck main :: IO () main = defaultMain =<< tests tests :: IO TestTree -tests = return $ testGroup "Tests" (concat [allEngineTests, allGameTests, allPlayerTests]) +tests = return $ testGroup "Tests" (concat [allCommandTests, allEngineTests, allGameTests, allPlayerTests]) +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, + testProperty "PROP: kill vote command errors when caller is dead" prop_killVoteCommandErrorsWhenCallerIsDead, + testProperty "PROP: kill vote command errors when target is dead" prop_killVoteCommandErrorsWhenTargetIsDead, + testProperty "PROP: kill vote command errors when not werewolves turn" prop_killVoteCommandErrorsWhenNotWerewolvesTurn, + testProperty "PROP: kill vote command errors when caller not werewolf" prop_killVoteCommandErrorsWhenCallerNotWerewolf, + testProperty "PROP: kill vote command errors when caller has voted" prop_killVoteCommandErrorsWhenCallerHasVoted, + testProperty "PROP: kill vote command updates votes" prop_killVoteCommandUpdatesVotes, + + testProperty "PROP: lynch vote command errors when game is over" prop_lynchVoteCommandErrorsWhenGameIsOver, + testProperty "PROP: lynch vote command errors when caller does not exist" prop_lynchVoteCommandErrorsWhenCallerDoesNotExist, + testProperty "PROP: lynch vote command errors when target does not exist" prop_lynchVoteCommandErrorsWhenTargetDoesNotExist, + testProperty "PROP: lynch vote command errors when caller is dead" prop_lynchVoteCommandErrorsWhenCallerIsDead, + testProperty "PROP: lynch vote command errors when target is dead" prop_lynchVoteCommandErrorsWhenTargetIsDead, + testProperty "PROP: lynch vote command errors when not 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 + ] + allEngineTests :: [TestTree] allEngineTests = [ - testProperty "PROP: validate vote command errors when game is over" prop_validateVoteCommandErrorsWhenGameIsOver, - testProperty "PROP: validate vote command errors when voter not in game" prop_validateVoteCommandErrorsWhenVoterDoesNotExist, - testProperty "PROP: validate vote command errors when target not in game" prop_validateVoteCommandErrorsWhenTargetDoesNotExist, - testProperty "PROP: validate vote command errors when voter is dead" prop_validateVoteCommandErrorsWhenVoterIsDead, - testProperty "PROP: validate vote command errors when target is dead" prop_validateVoteCommandErrorsWhenTargetIsDead, - testProperty "PROP: validate vote command errors when voter has voted" prop_validateVoteCommandErrorsWhenVoterHasVoted, - testProperty "PROP: validate kill vote command errors when voter not werewolf" prop_validateKillVoteCommandErrorsWhenVoterNotWerewolf, + testProperty "PROP: check turn skips seers when no seers" prop_checkTurnSkipsSeersWhenNoSeers, + testProperty "PROP: check turn does nothing when game over" prop_checkTurnDoesNothingWhenGameOver, - testProperty "PROP: start game starts with werewolves turn" prop_startGameStartsWithWerewolvesTurn, + testProperty "PROP: check seers turn advances to werewolves" prop_checkSeersTurnAdvancesToWerewolves, + testProperty "PROP: check seers turn resets sees" prop_checkSeersTurnResetsSees, + testProperty "PROP: check seers turn does nothing unless all seen" prop_checkSeersTurnDoesNothingUnlessAllSeen, + + testProperty "PROP: check villagers turn advances to seers" prop_checkVillagersTurnAdvancesToSeers, + testProperty "PROP: check villagers turn lynches one player when consensus" prop_checkVillagersTurnLynchesOnePlayerWhenConsensus, + testProperty "PROP: check villagers turn lynches no one when conflicted" prop_checkVillagersTurnLynchesNoOneWhenConflicted, + testProperty "PROP: check villagers turn resets votes" prop_checkVillagersTurnResetsVotes, + testProperty "PROP: check villagers turn does nothing unless all voted" prop_checkVillagersTurnDoesNothingUnlessAllVoted, + + testProperty "PROP: check werewolves turn advances to villagers" prop_checkWerewolvesTurnAdvancesToVillagers, + testProperty "PROP: check werewolves turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus, + testProperty "PROP: check werewolves turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted, + testProperty "PROP: check werewolves turn resets votes" prop_checkWerewolvesTurnResetsVotes, + testProperty "PROP: check werewolves turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, + + testProperty "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 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, @@ -44,14 +91,17 @@ testProperty "PROP: create players uses given player names" prop_createPlayersUsesGivenPlayerNames, testProperty "PROP: create players creates alive players" prop_createPlayersCreatesAlivePlayers, - testProperty "PROP: randomise roles returns n roles" prop_randomiseRolesReturnsNRoles + 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 ] allGameTests :: [TestTree] allGameTests = [ - testProperty "PROP: new game starts with werewolves turn" prop_newGameStartsWithWerewolvesTurn, - testCase "CHCK: newVillagersTurn" check_newVillagersTurn, - testCase "CHCK: newWerewolvesTurn" check_newWerewolvesTurn + testProperty "PROP: new game starts with seers turn" prop_newGameStartsWithSeersTurn, + 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 ] allPlayerTests :: [TestTree] 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 @@ -9,51 +9,106 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Game.Werewolf.Test.Arbitrary ( - arbitraryCommand, arbitraryNewGame, arbitraryNewPlayer, + -- * Contextual arbitraries + arbitraryCommand, arbitrarySeeCommand, arbitraryKillVoteCommand, arbitraryLynchVoteCommand, + arbitraryNewGame, arbitraryPlayer, arbitrarySeer, arbitraryVillager, arbitraryWerewolf, + + -- * Utility functions + run, run_, runArbitraryCommands, ) where -import Control.Lens hiding (elements) +import Control.Lens hiding (elements) +import Control.Monad.Except +import Control.Monad.State hiding (State) +import Control.Monad.Writer -import Data.List.Extra -import Data.Text (Text, pack) +import Data.Either.Extra +import Data.List.Extra +import qualified Data.Map as Map +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.Response +import Game.Werewolf.Role hiding (Villagers, Werewolves, name, _name) import Test.QuickCheck -instance Arbitrary Command where - arbitrary = Vote <$> arbitrary <*> arbitrary +instance Show Command where + show _ = "command" arbitraryCommand :: Game -> Gen Command -arbitraryCommand game = Vote <$> elements (game ^. players) <*> elements (game ^. players) +arbitraryCommand game = case game ^. turn of + Seers -> arbitrarySeeCommand game + Villagers -> arbitraryLynchVoteCommand game + 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) + target <- arbitraryPlayer game + + if null applicableCallers + then return noopCommand + else elements applicableCallers >>= \caller -> return $ killVoteCommand (caller ^. name) (target ^. name) + +arbitraryLynchVoteCommand :: Game -> Gen Command +arbitraryLynchVoteCommand game = do + let applicableCallers = filter (flip Map.notMember (game ^. votes) . _name) (filterAlive $ game ^. players) + target <- arbitraryPlayer game + + if null applicableCallers + then return noopCommand + else elements applicableCallers >>= \caller -> return $ lynchVoteCommand (caller ^. name) (target ^. name) + instance Arbitrary Game where arbitrary = do - n <- choose (7, 24) + game <- arbitraryNewGame turn <- arbitrary - players <- infiniteList - return $ Game turn (take n $ nubOn _name players) + return $ game { _turn = turn } arbitraryNewGame :: Gen Game arbitraryNewGame = do n <- choose (7, 24) - players <- infiniteListOf arbitraryNewPlayer + players <- nubOn _name <$> infiniteList - return $ newGame (take n $ nubOn _name players) + let seer = head $ filterSeers players + let werewolves = take (n `quot` 6 + 1) $ filterWerewolves players + let villagers = take (n - 1 - (length werewolves)) $ filterVillagers players + return $ newGame (seer:werewolves ++ villagers) + instance Arbitrary Turn where - arbitrary = elements [newVillagersTurn, newWerewolvesTurn, NoOne] + arbitrary = elements [Seers, Villagers, Werewolves, NoOne] instance Arbitrary Player where - arbitrary = Player <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = newPlayer <$> arbitrary <*> arbitrary -arbitraryNewPlayer :: Gen Player -arbitraryNewPlayer = newPlayer <$> arbitrary <*> arbitrary +arbitraryPlayer :: Game -> Gen Player +arbitraryPlayer = elements . filterAlive . _players +arbitrarySeer :: Game -> Gen Player +arbitrarySeer = elements . filterAlive . filterSeers . _players + +arbitraryVillager :: Game -> Gen Player +arbitraryVillager = elements . filterAlive . filterVillagers . _players + +arbitraryWerewolf :: Game -> Gen Player +arbitraryWerewolf = elements . filterAlive . filterWerewolves . _players + instance Arbitrary State where arbitrary = elements [Alive, Dead] @@ -61,4 +116,20 @@ arbitrary = elements allRoles instance Arbitrary Text where - arbitrary = pack <$> vectorOf 6 (elements ['a'..'z']) + arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) + +run :: StateT Game (WriterT [Message] (Except [Message])) a -> Game -> Either [Message] (Game, [Message]) +run action game = runExcept . runWriterT $ execStateT action game + +run_ :: StateT Game (WriterT [Message] (Except [Message])) a -> Game -> Game +run_ action = fst . fromRight . run action + +runArbitraryCommands :: Int -> Game -> Gen Game +runArbitraryCommands n = iterateM n $ \game -> do + command <- arbitraryCommand game + + return $ run_ (apply command) game + +iterateM :: Monad m => Int -> (a -> m a) -> a -> m a +iterateM 0 _ a = return a +iterateM n f a = f a >>= iterateM (n - 1) f diff --git a/test/src/Game/Werewolf/Test/Command.hs b/test/src/Game/Werewolf/Test/Command.hs new file mode 100644 --- /dev/null +++ b/test/src/Game/Werewolf/Test/Command.hs @@ -0,0 +1,169 @@ +{-| +Module : Game.Werewolf.Test.Command +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com +-} + +{-# 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, + prop_killVoteCommandErrorsWhenTargetIsDead, prop_killVoteCommandErrorsWhenNotWerewolvesTurn, + prop_killVoteCommandErrorsWhenCallerNotWerewolf, prop_killVoteCommandErrorsWhenCallerHasVoted, + prop_killVoteCommandUpdatesVotes, + + -- * lynchVoteCommand + prop_lynchVoteCommandErrorsWhenGameIsOver, prop_lynchVoteCommandErrorsWhenCallerDoesNotExist, + prop_lynchVoteCommandErrorsWhenTargetDoesNotExist, prop_lynchVoteCommandErrorsWhenCallerIsDead, + prop_lynchVoteCommandErrorsWhenTargetIsDead, prop_lynchVoteCommandErrorsWhenNotVillagersTurn, + prop_lynchVoteCommandErrorsWhenCallerHasVoted, prop_lynchVoteCommandUpdatesVotes, +) where + +import Control.Lens hiding (elements) + +import Data.Either.Extra +import Data.Map as Map + +import Game.Werewolf.Command +import Game.Werewolf.Game +import Game.Werewolf.Player +import Game.Werewolf.Test.Arbitrary + +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 + +prop_killVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property +prop_killVoteCommandErrorsWhenCallerDoesNotExist game caller = not (doesPlayerExist (caller ^. name) (game ^. players)) + ==> forAll (arbitraryPlayer game) $ \target -> + verbose_runCommandErrors game (killVoteCommand (caller ^. name) (target ^. name)) + +prop_killVoteCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property +prop_killVoteCommandErrorsWhenTargetDoesNotExist game target = not (doesPlayerExist (target ^. name) (game ^. players)) + ==> forAll (arbitraryWerewolf game) $ \caller -> + verbose_runCommandErrors game (killVoteCommand (caller ^. name) (target ^. name)) + +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)) + +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)) + +prop_killVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property +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)) + +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 + +prop_killVoteCommandUpdatesVotes :: Game -> Property +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 + ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game + +prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property +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)) + ==> 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)) + +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)) + +prop_lynchVoteCommandErrorsWhenNotVillagersTurn :: Game -> Property +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 + +prop_lynchVoteCommandUpdatesVotes :: Game -> Property +prop_lynchVoteCommandUpdatesVotes game = + isVillagersTurn game ==> + forAll (arbitraryLynchVoteCommand game) $ \command -> + Map.size (run_ (apply command) game ^. votes) == 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 new file mode 100644 --- /dev/null +++ b/test/src/Game/Werewolf/Test/Engine.hs @@ -0,0 +1,238 @@ +{-| +Module : Game.Werewolf.Test.Engine +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com +-} + +{-# OPTIONS_HADDOCK hide, prune #-} +{-# LANGUAGE OverloadedStrings #-} + +module Game.Werewolf.Test.Engine ( + -- * checkTurn + prop_checkTurnSkipsSeersWhenNoSeers, prop_checkTurnDoesNothingWhenGameOver, + prop_checkSeersTurnAdvancesToWerewolves, prop_checkSeersTurnResetsSees, + prop_checkSeersTurnDoesNothingUnlessAllSeen, prop_checkVillagersTurnAdvancesToSeers, + prop_checkVillagersTurnLynchesOnePlayerWhenConsensus, + prop_checkVillagersTurnLynchesNoOneWhenConflicted, prop_checkVillagersTurnResetsVotes, + prop_checkVillagersTurnDoesNothingUnlessAllVoted, prop_checkWerewolvesTurnAdvancesToVillagers, + prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus, + prop_checkWerewolvesTurnKillsNoOneWhenConflicted, prop_checkWerewolvesTurnResetsVotes, + prop_checkWerewolvesTurnDoesNothingUnlessAllVoted, + + -- * checkGameOver + prop_checkGameOverAdvancesTurn, prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive, + + -- * startGame + prop_startGameStartsWithSeersTurn, prop_startGameUsesGivenPlayers, + prop_startGameErrorsUnlessUniquePlayerNames, prop_startGameErrorsWhenLessThan7Players, + prop_startGameErrorsWhenMoreThan24Players, + + -- * createPlayers + prop_createPlayersUsesGivenPlayerNames, prop_createPlayersCreatesAlivePlayers, + + -- * randomiseRoles + prop_randomiseRolesReturnsNRoles, prop_randomiseRolesProportionsRoles, + prop_randomiseRolesHasOneSeer, +) where + +import Control.Lens hiding (elements) +import Control.Monad.Except +import Control.Monad.Writer + +import Data.Either.Extra +import Data.List.Extra +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 Test.QuickCheck +import Test.QuickCheck.Monadic + +prop_checkTurnSkipsSeersWhenNoSeers :: Game -> Property +prop_checkTurnSkipsSeersWhenNoSeers game = + forAll (runArbitraryCommands n game') $ \game'' -> + isWerewolvesTurn $ run_ checkTurn game'' + where + game' = (foldl killPlayer game (filterSeers $ game ^. players)) { _turn = Villagers } + n = length . filterAlive $ game' ^. players + +prop_checkTurnDoesNothingWhenGameOver :: Game -> Property +prop_checkTurnDoesNothingWhenGameOver game = run_ checkTurn game' === game' + where + game' = game { _turn = NoOne } + +prop_checkSeersTurnAdvancesToWerewolves :: Game -> Property +prop_checkSeersTurnAdvancesToWerewolves game = + forAll (runArbitraryCommands n game') $ \game'' -> + isWerewolvesTurn $ run_ checkTurn game'' + where + game' = game { _turn = Seers } + n = length . filterSeers $ game' ^. players + +prop_checkSeersTurnResetsSees :: Game -> Property +prop_checkSeersTurnResetsSees game = + forAll (runArbitraryCommands n game') $ \game'' -> + Map.null $ run_ checkTurn game'' ^. sees + where + game' = game { _turn = Seers } + n = length . filterSeers $ game' ^. players + +prop_checkSeersTurnDoesNothingUnlessAllSeen :: Game -> Property +prop_checkSeersTurnDoesNothingUnlessAllSeen game = + forAll (runArbitraryCommands n game') $ \game'' -> + isSeersTurn $ run_ checkTurn game'' + where + game' = game { _turn = Seers } + n = length (filterSeers $ game' ^. players) - 1 + +prop_checkVillagersTurnAdvancesToSeers :: Game -> Property +prop_checkVillagersTurnAdvancesToSeers game = + forAll (runArbitraryCommands n game') $ \game'' -> + not (null . filterAlive . filterSeers $ run_ checkTurn game'' ^. players) + ==> isSeersTurn $ run_ checkTurn game'' + where + game' = game { _turn = Villagers } + n = length $ game' ^. players + +prop_checkVillagersTurnLynchesOnePlayerWhenConsensus :: Game -> Property +prop_checkVillagersTurnLynchesOnePlayerWhenConsensus game = + forAll (runArbitraryCommands n game') $ \game'' -> + length (last $ groupSortOn (length . flip elemIndices (Map.elems $ game'' ^. votes)) (nub . Map.elems $ game'' ^. votes)) == 1 + ==> length (filterDead $ run_ checkTurn game'' ^. players) == 1 + where + game' = game { _turn = Villagers } + n = length $ game' ^. players + +prop_checkVillagersTurnLynchesNoOneWhenConflicted :: Game -> Property +prop_checkVillagersTurnLynchesNoOneWhenConflicted game = + forAll (runArbitraryCommands n game') $ \game'' -> + length (last $ groupSortOn (length . flip elemIndices (Map.elems $ game'' ^. votes)) (nub . Map.elems $ game'' ^. votes)) > 1 + ==> length (filterDead $ run_ checkTurn game'' ^. players) == 0 + where + game' = game { _turn = Villagers } + n = length $ game' ^. players + +prop_checkVillagersTurnResetsVotes :: Game -> Property +prop_checkVillagersTurnResetsVotes game = + forAll (runArbitraryCommands n game') $ \game'' -> + Map.null $ run_ checkTurn game'' ^. votes + where + game' = game { _turn = Villagers } + n = length $ game' ^. players + +prop_checkVillagersTurnDoesNothingUnlessAllVoted :: Game -> Property +prop_checkVillagersTurnDoesNothingUnlessAllVoted game = + forAll (runArbitraryCommands n game') $ \game'' -> + isVillagersTurn $ run_ checkTurn game'' + where + game' = game { _turn = Villagers } + n = length (game' ^. players) - 1 + +prop_checkWerewolvesTurnAdvancesToVillagers :: Game -> Property +prop_checkWerewolvesTurnAdvancesToVillagers game = + forAll (runArbitraryCommands n game') $ \game' -> + isVillagersTurn $ run_ checkTurn game' + where + game' = game { _turn = Werewolves } + n = length . filterWerewolves $ game' ^. players + +prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus :: Game -> Property +prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus game = + forAll (runArbitraryCommands n game') $ \game'' -> + length (last $ groupSortOn (length . flip elemIndices (Map.elems $ game'' ^. votes)) (nub . Map.elems $ game'' ^. votes)) == 1 + ==> length (filterDead $ run_ checkTurn game'' ^. players) == 1 + where + game' = game { _turn = Werewolves } + n = length $ game' ^. players + +prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: Game -> Property +prop_checkWerewolvesTurnKillsNoOneWhenConflicted game = + forAll (runArbitraryCommands n game') $ \game'' -> + length (last $ groupSortOn (length . flip elemIndices (Map.elems $ game'' ^. votes)) (nub . Map.elems $ game'' ^. votes)) > 1 + ==> length (filterDead $ run_ checkTurn game'' ^. players) == 0 + where + game' = game { _turn = Werewolves } + n = length $ game' ^. players + +prop_checkWerewolvesTurnResetsVotes :: Game -> Property +prop_checkWerewolvesTurnResetsVotes game = + forAll (runArbitraryCommands n game') $ \game' -> + Map.null $ run_ checkTurn game' ^. votes + where + game' = game { _turn = Werewolves } + n = length . filterWerewolves $ game' ^. players + +prop_checkWerewolvesTurnDoesNothingUnlessAllVoted :: Game -> Property +prop_checkWerewolvesTurnDoesNothingUnlessAllVoted game = + forAll (runArbitraryCommands n game') $ \game'' -> + isWerewolvesTurn $ run_ checkTurn game'' + where + game' = game { _turn = Werewolves } + n = length (filterWerewolves $ game' ^. players) - 1 + +prop_checkGameOverAdvancesTurn :: Game -> Property +prop_checkGameOverAdvancesTurn game = + forAll (sublistOf $ game ^. players) $ \players' -> + let game' = foldl killPlayer game players' in + length (nub . map (_allegiance . _role) . filterAlive $ game' ^. players) <= 1 + ==> isGameOver $ run_ checkGameOver game' + +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 (_allegiance . _role) . filterAlive $ game' ^. players) > 1 + ==> not . isGameOver $ run_ checkGameOver game' + +prop_startGameStartsWithSeersTurn :: [Player] -> Property +prop_startGameStartsWithSeersTurn players = and [ + isRight . runExcept . runWriterT $ startGame "" players + ] ==> isSeersTurn (fst . fromRight . runExcept . runWriterT $ startGame "" players) + +prop_startGameUsesGivenPlayers :: [Player] -> Property +prop_startGameUsesGivenPlayers players' = and [ + isRight . runExcept . runWriterT $ startGame "" players' + ] ==> (fst . fromRight . runExcept . runWriterT $ startGame "" players') ^. players == players' + +prop_startGameErrorsUnlessUniquePlayerNames :: [Player] -> Property +prop_startGameErrorsUnlessUniquePlayerNames players = and [ + isRight . runExcept . runWriterT $ startGame "" players + ] ==> forAll (elements players) $ \player -> isLeft (runExcept . runWriterT $ startGame "" (player:players)) + +prop_startGameErrorsWhenLessThan7Players :: [Player] -> Property +prop_startGameErrorsWhenLessThan7Players players = and [ + length players < 7 + ] ==> isLeft (runExcept . runWriterT $ startGame "" players) + +prop_startGameErrorsWhenMoreThan24Players :: Property +prop_startGameErrorsWhenMoreThan24Players = forAll (resize 30 $ listOf arbitrary) $ \players -> and [ + length players > 24 + ] ==> isLeft (runExcept . runWriterT $ startGame "" players) + +prop_createPlayersUsesGivenPlayerNames :: [Text] -> Property +prop_createPlayersUsesGivenPlayerNames playerNames = monadicIO $ createPlayers playerNames >>= return . (playerNames ==) . map _name + +prop_createPlayersCreatesAlivePlayers :: [Text] -> Property +prop_createPlayersCreatesAlivePlayers playerNames = monadicIO $ createPlayers playerNames >>= return . all ((==) Alive . _state) + +prop_randomiseRolesReturnsNRoles :: Int -> Property +prop_randomiseRolesReturnsNRoles n = monadicIO $ randomiseRoles n >>= return . (==) n . length + +prop_randomiseRolesProportionsRoles :: Int -> Property +prop_randomiseRolesProportionsRoles n = monadicIO $ do + roles <- randomiseRoles n + + let werewolvesCount = length $ elemIndices werewolfRole roles + + return $ n `quot` 6 + 1 == werewolvesCount + +prop_randomiseRolesHasOneSeer :: Int -> Property +prop_randomiseRolesHasOneSeer n = monadicIO $ randomiseRoles n >>= return . (1 ==) . length . elemIndices seerRole 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 @@ -6,10 +6,10 @@ -} {-# OPTIONS_HADDOCK hide, prune #-} -{-# LANGUAGE OverloadedStrings #-} module Game.Werewolf.Test.Game ( - prop_newGameStartsWithWerewolvesTurn, check_newVillagersTurn, check_newWerewolvesTurn, + prop_newGameStartsWithSeersTurn, prop_newGameStartsWithSeesEmpty, + prop_newGameStartsWithVotesEmpty, prop_newGameUsesGivenPlayers, ) where import Control.Lens @@ -19,13 +19,14 @@ import Game.Werewolf.Game import Game.Werewolf.Player -import Test.HUnit +prop_newGameStartsWithSeersTurn :: [Player] -> Bool +prop_newGameStartsWithSeersTurn players = isSeersTurn $ newGame players -prop_newGameStartsWithWerewolvesTurn :: [Player] -> Bool -prop_newGameStartsWithWerewolvesTurn players = newGame players ^. turn == newWerewolvesTurn +prop_newGameStartsWithSeesEmpty :: [Player] -> Bool +prop_newGameStartsWithSeesEmpty players = Map.null $ newGame players ^. sees -check_newVillagersTurn :: Assertion -check_newVillagersTurn = newVillagersTurn @?= Villagers Map.empty +prop_newGameStartsWithVotesEmpty :: [Player] -> Bool +prop_newGameStartsWithVotesEmpty players = Map.null $ newGame players ^. votes -check_newWerewolvesTurn :: Assertion -check_newWerewolvesTurn = newWerewolvesTurn @?= Werewolves Map.empty +prop_newGameUsesGivenPlayers :: [Player] -> Bool +prop_newGameUsesGivenPlayers players' = newGame players' ^. players == players' diff --git a/werewolf.cabal b/werewolf.cabal --- a/werewolf.cabal +++ b/werewolf.cabal @@ -1,5 +1,5 @@ name: werewolf -version: 0.1.0.0 +version: 0.2.0.0 author: Henry J. Wylde maintainer: public@hjwylde.com @@ -14,7 +14,7 @@ license-file: LICENSE cabal-version: >= 1.10 -category: Game +category: Development build-type: Simple extra-source-files: CHANGELOG.md README.md @@ -31,6 +31,7 @@ Werewolf.Commands.End, Werewolf.Commands.Help, Werewolf.Commands.Interpret, + Werewolf.Commands.See, Werewolf.Commands.Start, Werewolf.Commands.Vote, Werewolf.Options, @@ -43,7 +44,6 @@ build-depends: aeson >= 0.8, base >= 4.8 && < 5, - bytestring >= 0.10, directory >= 1.2, extra >= 1.4, filepath >= 1.4, @@ -69,13 +69,12 @@ CPP, DeriveGeneric, FlexibleContexts, - MultiParamTypeClasses, OverloadedStrings, + RankNTypes, TemplateHaskell build-depends: aeson >= 0.8, base >= 4.8 && < 5, - bytestring >= 0.10, containers >= 0.5, directory >= 1.2, extra >= 1.4, @@ -94,6 +93,8 @@ ghc-options: -threaded -with-rtsopts=-N other-modules: Game.Werewolf.Test.Arbitrary + Game.Werewolf.Test.Command + Game.Werewolf.Test.Engine Game.Werewolf.Test.Game Game.Werewolf.Test.Player @@ -104,12 +105,10 @@ base >= 4.8 && < 5, containers >= 0.5, extra >= 1.4, - HUnit >= 1.2, lens >= 4.12, mtl >= 2.2, QuickCheck >= 2.8, tasty >= 0.10 && < 0.12, - tasty-hunit >= 0.9, tasty-quickcheck >= 0.8, text >= 1.2, werewolf