packages feed

werewolf 0.1.0.0 → 0.2.0.0

raw patch · 22 files changed

+1123/−382 lines, 22 filesdep −HUnitdep −bytestringdep −tasty-hunit

Dependencies removed: HUnit, bytestring, tasty-hunit

Files

CHANGELOG.md view
@@ -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))
README.md view
@@ -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.
app/Main.hs view
@@ -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
app/Werewolf/Commands/End.hs view
@@ -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
app/Werewolf/Commands/Help.hs view
@@ -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"-    ] }+    ]]
app/Werewolf/Commands/Interpret.hs view
@@ -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)
+ app/Werewolf/Commands/See.hs view
@@ -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 }
app/Werewolf/Commands/Start.hs view
@@ -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 }
app/Werewolf/Commands/Vote.hs view
@@ -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 }
app/Werewolf/Options.hs view
@@ -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..."))
src/Game/Werewolf/Command.hs view
@@ -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]
src/Game/Werewolf/Engine.hs view
@@ -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
src/Game/Werewolf/Game.hs view
@@ -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]
src/Game/Werewolf/Player.hs view
@@ -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
src/Game/Werewolf/Response.hs view
@@ -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!"
src/Game/Werewolf/Role.hs view
@@ -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"
test/app/Main.hs view
@@ -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]
test/src/Game/Werewolf/Test/Arbitrary.hs view
@@ -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
+ test/src/Game/Werewolf/Test/Command.hs view
@@ -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)
+ test/src/Game/Werewolf/Test/Engine.hs view
@@ -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
test/src/Game/Werewolf/Test/Game.hs view
@@ -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'
werewolf.cabal view
@@ -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