werewolf 0.2.0.2 → 0.3.0.0
raw patch · 20 files changed
+491/−263 lines, 20 files
Files
- CHANGELOG.md +7/−8
- README.md +1/−2
- app/Main.hs +19/−10
- app/Werewolf/Commands/Help.hs +23/−9
- app/Werewolf/Commands/Interpret.hs +2/−30
- app/Werewolf/Commands/Quit.hs +43/−0
- app/Werewolf/Commands/Start.hs +15/−7
- app/Werewolf/Options.hs +15/−1
- src/Game/Werewolf/Command.hs +27/−11
- src/Game/Werewolf/Engine.hs +39/−38
- src/Game/Werewolf/Game.hs +13/−4
- src/Game/Werewolf/Player.hs +1/−1
- src/Game/Werewolf/Response.hs +27/−16
- src/Game/Werewolf/Role.hs +14/−7
- test/app/Main.hs +27/−15
- test/src/Game/Werewolf/Test/Arbitrary.hs +20/−11
- test/src/Game/Werewolf/Test/Command.hs +147/−63
- test/src/Game/Werewolf/Test/Engine.hs +39/−25
- test/src/Game/Werewolf/Test/Game.hs +10/−4
- werewolf.cabal +2/−1
CHANGELOG.md view
@@ -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
README.md view
@@ -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?"} ]} ```
app/Main.hs view
@@ -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
app/Werewolf/Commands/Help.hs view
@@ -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." ]
app/Werewolf/Commands/Interpret.hs view
@@ -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)
+ app/Werewolf/Commands/Quit.hs view
@@ -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 }
app/Werewolf/Commands/Start.hs view
@@ -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 }
app/Werewolf/Options.hs view
@@ -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")
src/Game/Werewolf/Command.hs view
@@ -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
src/Game/Werewolf/Engine.hs view
@@ -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
src/Game/Werewolf/Game.hs view
@@ -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
src/Game/Werewolf/Player.hs view
@@ -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
src/Game/Werewolf/Response.hs view
@@ -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."]
src/Game/Werewolf/Role.hs view
@@ -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"
test/app/Main.hs view
@@ -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
test/src/Game/Werewolf/Test/Arbitrary.hs view
@@ -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
test/src/Game/Werewolf/Test/Command.hs view
@@ -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)
test/src/Game/Werewolf/Test/Engine.hs view
@@ -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
test/src/Game/Werewolf/Test/Game.hs view
@@ -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
werewolf.cabal view
@@ -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,