diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,34 @@ # Changelog +**N.B.**, prior to v1 a change was considered *breaking* if it altered how an interface interacts + with the werewolf binary. +Post v1 a change is further considered breaking if the state file format is incompatible with the + previous version. + ### Upcoming +### v1.1.0.0 + +*Major* + +* Moved majority of library classes to app/. ([#208](https://github.com/hjwylde/werewolf/issues/208)) +* Changed the Fallen Angel to be a true Loner. ([#173](https://github.com/hjwylde/werewolf/issues/173)) +* Added the Oracle role. ([#141](https://github.com/hjwylde/werewolf/issues/141)) +* Removed the event concept. ([#147](https://github.com/hjwylde/werewolf/issues/147)) + +*Minor* + +* Added private message to players when they die. ([#188](https://github.com/hjwylde/werewolf/issues/188)) +* Added the Medusa role. ([#99](https://github.com/hjwylde/werewolf/issues/99)) +* Added `unvote` command. ([#213](https://github.com/hjwylde/werewolf/issues/213)) +* Removed public knowledge of Villagers and Werewolves that have voted. ([#214](https://github.com/hjwylde/werewolf/issues/214)) +* Added the Spiteful Ghost role. ([#206](https://github.com/hjwylde/werewolf/issues/206)) + +*Revisions* + +* Updated the Scapegoat's turn messages to be clear that they may choose more than 1 player. ([#185](https://github.com/hjwylde/werewolf/issues/185)) +* Updated Beholder's balance to 1. + ### v1.0.2.2 *Revisions* @@ -367,7 +394,7 @@ *Minor* -* Added a Scapegoat role. ([#40](https://github.com/hjwylde/werewolf/issues/40)) +* Added the Scapegoat role. ([#40](https://github.com/hjwylde/werewolf/issues/40)) * Added a `status` command. ([#18](https://github.com/hjwylde/werewolf/issues/18)) *Revisions* diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ A game engine for playing werewolf within an arbitrary chat client. Werewolf is a well known social party game, commonly also called Mafia. -See the [Wikipedia article](https://en.wikipedia.org/wiki/Mafia_(party_game)) for a rundown on it's +See the [Wikipedia article](https://en.wikipedia.org/wiki/Mafia_(party_game)) for a rundown on its gameplay and history. If you're here just to play werewolf, you may wish to skip straight to @@ -49,6 +49,7 @@ The Loners must complete their own objective. * Fallen Angel +* Spiteful Ghost **The Villagers:** @@ -65,6 +66,8 @@ * Hunter * Jester * Lycan +* Medusa +* Oracle * Protector * Scapegoat * Seer diff --git a/app/Game/Werewolf/Command.hs b/app/Game/Werewolf/Command.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command.hs @@ -0,0 +1,48 @@ +{-| +Module : Game.Werewolf.Command +Description : Command data structure. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Command data structures. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} + +module Game.Werewolf.Command ( + -- * Command + Command(..), + + -- ** Instances + noopCommand, + + -- ** Validation + validatePlayer, +) where + +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf.Game hiding (getPendingVoters) +import Game.Werewolf.Messages +import Game.Werewolf.Response +import Game.Werewolf.Util + +data Command = Command { apply :: forall m . (MonadError [Message] m, MonadState Game m, MonadWriter [Message] m) => m () } + +noopCommand :: Command +noopCommand = Command $ return () + +validatePlayer :: (MonadError [Message] m, MonadState Game m) => Text -> Text -> m () +validatePlayer callerName name = do + whenM isGameOver $ throwError [gameIsOverMessage callerName] + unlessM (doesPlayerExist name) $ throwError [playerDoesNotExistMessage callerName name] + whenM (isPlayerDead name) $ throwError [if callerName == name then playerIsDeadMessage callerName else targetIsDeadMessage callerName name] diff --git a/app/Game/Werewolf/Command/Global.hs b/app/Game/Werewolf/Command/Global.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Global.hs @@ -0,0 +1,50 @@ +{-| +Module : Game.Werewolf.Command.Global +Description : Global commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Global commands. +-} + +module Game.Werewolf.Command.Global ( + -- * Commands + bootCommand, quitCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Writer + +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +bootCommand :: Text -> Text -> Command +bootCommand callerName targetName = Command $ do + validatePlayer callerName callerName + validatePlayer callerName targetName + whenM (uses (boots . at targetName) $ elem callerName . fromMaybe []) $ + throwError [playerHasAlreadyVotedToBootMessage callerName targetName] + + boots %= Map.insertWith (++) targetName [callerName] + + tell [playerVotedToBootMessage callerName targetName] + +quitCommand :: Text -> Command +quitCommand callerName = Command $ do + validatePlayer callerName callerName + + caller <- findPlayerBy_ name callerName + + tell [playerQuitMessage caller] + + removePlayer callerName diff --git a/app/Game/Werewolf/Command/Hunter.hs b/app/Game/Werewolf/Command/Hunter.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Hunter.hs @@ -0,0 +1,42 @@ +{-| +Module : Game.Werewolf.Command.Hunter +Description : Hunter commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Hunter commands. +-} + +module Game.Werewolf.Command.Hunter ( + -- * Commands + chooseCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +chooseCommand :: Text -> Text -> Command +chooseCommand callerName targetName = Command $ do + whenM isGameOver $ throwError [gameIsOverMessage callerName] + unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] + unlessM (isPlayerHunter callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isHuntersTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + validatePlayer callerName targetName + + target <- findPlayerBy_ name targetName + + tell [playerShotMessage target] + killPlayer targetName + + hunterRetaliated .= True diff --git a/app/Game/Werewolf/Command/Oracle.hs b/app/Game/Werewolf/Command/Oracle.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Oracle.hs @@ -0,0 +1,35 @@ +{-| +Module : Game.Werewolf.Command.Oracle +Description : Oracle commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Seer commands. +-} + +module Game.Werewolf.Command.Oracle ( + -- * Commands + divineCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +divineCommand :: Text -> Text -> Command +divineCommand callerName targetName = Command $ do + validatePlayer callerName callerName + unlessM (isPlayerOracle callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isOraclesTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + validatePlayer callerName targetName + + divine .= Just targetName diff --git a/app/Game/Werewolf/Command/Orphan.hs b/app/Game/Werewolf/Command/Orphan.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Orphan.hs @@ -0,0 +1,36 @@ +{-| +Module : Game.Werewolf.Command.Orphan +Description : Orphan commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Orphan commands. +-} + +module Game.Werewolf.Command.Orphan ( + -- * Commands + chooseCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +chooseCommand :: Text -> Text -> Command +chooseCommand callerName targetName = Command $ do + validatePlayer callerName callerName + unlessM (isPlayerOrphan callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isOrphansTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + when (callerName == targetName) $ throwError [playerCannotChooseSelfMessage callerName] + validatePlayer callerName targetName + + roleModel .= Just targetName diff --git a/app/Game/Werewolf/Command/Protector.hs b/app/Game/Werewolf/Command/Protector.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Protector.hs @@ -0,0 +1,38 @@ +{-| +Module : Game.Werewolf.Command.Protector +Description : Protector commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Protector commands. +-} + +module Game.Werewolf.Command.Protector ( + -- * Commands + protectCommand, +) where + +import Control.Lens +import Control.Lens.Extra +import Control.Monad.Except +import Control.Monad.Extra + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +protectCommand :: Text -> Text -> Command +protectCommand callerName targetName = Command $ do + validatePlayer callerName callerName + unlessM (isPlayerProtector callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isProtectorsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + validatePlayer callerName targetName + whenM (hasuse $ priorProtect . traverse . only targetName) $ throwError [playerCannotProtectSamePlayerTwiceInARowMessage callerName] + + priorProtect .= Just targetName + protect .= Just targetName diff --git a/app/Game/Werewolf/Command/Scapegoat.hs b/app/Game/Werewolf/Command/Scapegoat.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Scapegoat.hs @@ -0,0 +1,41 @@ +{-| +Module : Game.Werewolf.Command.Scapegoat +Description : Scapegoat commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Scapegoat commands. +-} + +module Game.Werewolf.Command.Scapegoat ( + -- * Commands + chooseCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +chooseCommand :: Text -> [Text] -> Command +chooseCommand callerName targetNames = Command $ do + whenM isGameOver $ throwError [gameIsOverMessage callerName] + unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] + unlessM (isPlayerScapegoat callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isScapegoatsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + when (null targetNames) $ throwError [playerMustChooseAtLeastOneTargetMessage callerName] + when (callerName `elem` targetNames) $ throwError [playerCannotChooseSelfMessage callerName] + forM_ targetNames $ validatePlayer callerName + whenM (use jesterRevealed &&^ anyM isPlayerJester targetNames) $ + throwError [playerCannotChooseJesterMessage callerName] + + allowedVoters .= targetNames + scapegoatBlamed .= False diff --git a/app/Game/Werewolf/Command/Seer.hs b/app/Game/Werewolf/Command/Seer.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Seer.hs @@ -0,0 +1,35 @@ +{-| +Module : Game.Werewolf.Command.Seer +Description : Seer commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Seer commands. +-} + +module Game.Werewolf.Command.Seer ( + -- * Commands + seeCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +seeCommand :: Text -> Text -> Command +seeCommand callerName targetName = Command $ do + validatePlayer callerName callerName + unlessM (isPlayerSeer callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isSeersTurn $ throwError [playerCannotDoThatRightNowMessage callerName] + validatePlayer callerName targetName + + see .= Just targetName diff --git a/app/Game/Werewolf/Command/Status.hs b/app/Game/Werewolf/Command/Status.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Status.hs @@ -0,0 +1,90 @@ +{-| +Module : Game.Werewolf.Command.Status +Description : Status commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Status commands. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Game.Werewolf.Command.Status ( + -- * Commands + circleCommand, pingCommand, statusCommand, +) where + +import Control.Lens +import Control.Monad.State +import Control.Monad.Writer + +import Data.List +import Data.Text (Text) + +import Game.Werewolf hiding (getPendingVoters) +import Game.Werewolf.Command +import Game.Werewolf.Messages +import qualified Game.Werewolf.Role as Role +import Game.Werewolf.Util + +circleCommand :: Text -> Bool -> Command +circleCommand callerName includeDead = Command $ do + players' <- toListOf (players . traverse . if includeDead then id else alive) <$> get + + tell [circleMessage callerName players'] + +pingCommand :: Text -> Command +pingCommand callerName = Command $ use stage >>= \stage' -> case stage' of + FerinasGrunt -> return () + GameOver -> tell [gameIsOverMessage callerName] + HuntersTurn1 -> pingRole hunterRole + HuntersTurn2 -> pingRole hunterRole + Lynching -> return () + OraclesTurn -> pingRole oracleRole + OrphansTurn -> pingRole orphanRole + ProtectorsTurn -> pingRole protectorRole + ScapegoatsTurn -> pingRole scapegoatRole + SeersTurn -> pingRole seerRole + Sunrise -> return () + Sunset -> return () + VillageDrunksTurn -> pingRole villageDrunkRole + VillagesTurn -> pingVillagers + WerewolvesTurn -> pingWerewolves + WitchsTurn -> pingRole witchRole + +pingRole :: (MonadState Game m, MonadWriter [Message] m) => Role -> m () +pingRole role' = do + player <- findPlayerBy_ role role' + + tell [pingRoleMessage $ role' ^. Role.name] + tell [pingPlayerMessage $ player ^. name] + +pingVillagers :: (MonadState Game m, MonadWriter [Message] m) => m () +pingVillagers = do + allowedVoterNames <- use allowedVoters + pendingVoterNames <- toListOf names <$> getPendingVoters + + tell [pingRoleMessage "village"] + tell $ map pingPlayerMessage (allowedVoterNames `intersect` pendingVoterNames) + +pingWerewolves :: (MonadState Game m, MonadWriter [Message] m) => m () +pingWerewolves = do + pendingVoters <- getPendingVoters + + tell [pingRoleMessage "Werewolves"] + tell $ map pingPlayerMessage (pendingVoters ^.. werewolves . name) + +statusCommand :: Text -> Command +statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of + GameOver -> tell [gameIsOverMessage callerName] + _ -> tell . statusMessages stage' =<< use players + where + statusMessages stage players = + currentStageMessages callerName stage ++ + [ rolesInGameMessage (Just callerName) (players ^.. roles) + , playersInGameMessage callerName players + ] diff --git a/app/Game/Werewolf/Command/Villager.hs b/app/Game/Werewolf/Command/Villager.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Villager.hs @@ -0,0 +1,60 @@ +{-| +Module : Game.Werewolf.Command.Villager +Description : Villager commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Villager commands. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Game.Werewolf.Command.Villager ( + -- * Commands + unvoteCommand, voteCommand, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Writer + +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +unvoteCommand :: Text -> Command +unvoteCommand callerName = Command $ do + validateCommand callerName + whenM (isNothing <$> getPlayerVote callerName) $ throwError [playerHasNotVotedMessage callerName] + + votes %= Map.delete callerName + + whenJustM (preuse $ players . crookedSenators . alive) $ \crookedSenator -> + tell [playerRescindedVoteMessage (crookedSenator ^. name) callerName] + +voteCommand :: Text -> Text -> Command +voteCommand callerName targetName = Command $ do + validateCommand callerName + whenM (isJust <$> getPlayerVote callerName) $ throwError [playerHasAlreadyVotedMessage callerName] + validatePlayer callerName targetName + + votes %= Map.insert callerName targetName + + whenJustM (preuse $ players . crookedSenators . alive) $ \crookedSenator -> + tell [playerMadeLynchVoteMessage (Just $ crookedSenator ^. name) callerName targetName] + +validateCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m () +validateCommand callerName = do + validatePlayer callerName callerName + whenM (uses allowedVoters (callerName `notElem`)) $ throwError [playerCannotDoThatMessage callerName] + unlessM isVillagesTurn $ throwError [playerCannotDoThatRightNowMessage callerName] diff --git a/app/Game/Werewolf/Command/Werewolf.hs b/app/Game/Werewolf/Command/Werewolf.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Werewolf.hs @@ -0,0 +1,67 @@ +{-| +Module : Game.Werewolf.Command.Werewolf +Description : Werewolf commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Werewolf commands. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Game.Werewolf.Command.Werewolf ( + -- * Commands + unvoteCommand, voteCommand, + + -- ** Validation + validatePlayer, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Writer + +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +unvoteCommand :: Text -> Command +unvoteCommand callerName = Command $ do + validateCommand callerName + whenM (isNothing <$> getPlayerVote callerName) $ throwError [playerHasNotVotedMessage callerName] + + votes %= Map.delete callerName + + aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get + + tell [playerRescindedVoteMessage werewolfName callerName | werewolfName <- aliveWerewolfNames \\ [callerName]] + +voteCommand :: Text -> Text -> Command +voteCommand callerName targetName = Command $ do + validateCommand callerName + whenM (isJust <$> getPlayerVote callerName) $ throwError [playerHasAlreadyVotedMessage callerName] + validatePlayer callerName targetName + whenM (isPlayerWerewolf targetName) $ throwError [playerCannotDevourAnotherWerewolfMessage callerName] + + votes %= Map.insert callerName targetName + + aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get + + tell [playerMadeDevourVoteMessage werewolfName callerName targetName | werewolfName <- aliveWerewolfNames \\ [callerName]] + +validateCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m () +validateCommand callerName = do + validatePlayer callerName callerName + unlessM (isPlayerWerewolf callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isWerewolvesTurn $ throwError [playerCannotDoThatRightNowMessage callerName] diff --git a/app/Game/Werewolf/Command/Witch.hs b/app/Game/Werewolf/Command/Witch.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Command/Witch.hs @@ -0,0 +1,63 @@ +{-| +Module : Game.Werewolf.Command.Witch +Description : Witch commands. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Witch commands. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Game.Werewolf.Command.Witch ( + -- * Commands + healCommand, passCommand, poisonCommand, +) where + +import Control.Lens +import Control.Lens.Extra +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.State + +import Data.Map as Map +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Messages +import Game.Werewolf.Util + +healCommand :: Text -> Command +healCommand callerName = Command $ do + validateCommand callerName + whenM (use healUsed) $ throwError [playerHasAlreadyHealedMessage callerName] + whenM (hasn'tuse votee) $ throwError [playerCannotDoThatRightNowMessage callerName] + + healUsed .= True + votes .= Map.empty + +passCommand :: Text -> Command +passCommand callerName = Command $ do + validateCommand callerName + + passed .= True + +poisonCommand :: Text -> Text -> Command +poisonCommand callerName targetName = Command $ do + validateCommand callerName + whenM (use poisonUsed) $ throwError [playerHasAlreadyPoisonedMessage callerName] + validatePlayer callerName targetName + whenM (hasuse $ votee . named targetName) $ throwError [playerCannotDoThatMessage callerName] + + poison .= Just targetName + poisonUsed .= True + +validateCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m () +validateCommand callerName = do + validatePlayer callerName callerName + unlessM (isPlayerWitch callerName) $ throwError [playerCannotDoThatMessage callerName] + unlessM isWitchsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] diff --git a/app/Game/Werewolf/Engine.hs b/app/Game/Werewolf/Engine.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Engine.hs @@ -0,0 +1,233 @@ +{-| +Module : Game.Werewolf.Engine +Description : Engine functions. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Engine functions. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Game.Werewolf.Engine ( + -- * Loop + checkStage, checkGameOver, +) where + +import Control.Lens hiding (cons, isn't) +import Control.Lens.Extra +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Random +import Control.Monad.State +import Control.Monad.Writer + +import Data.List.Extra +import qualified Data.Map as Map +import Data.Maybe + +import Game.Werewolf.Game hiding (getAllowedVoters, getPendingVoters, hasAnyoneWon, + hasFallenAngelWon, hasVillagersWon, hasWerewolvesWon) +import Game.Werewolf.Messages +import Game.Werewolf.Player +import Game.Werewolf.Response +import Game.Werewolf.Role hiding (name) +import Game.Werewolf.Util + +import Prelude hiding (round) + +checkStage :: (MonadRandom m, MonadState Game m, MonadWriter [Message] m) => m () +checkStage = do + game <- get + checkBoots >> checkStage' + game' <- get + + when (game /= game') checkStage + +checkBoots :: (MonadState Game m, MonadWriter [Message] m) => m () +checkBoots = do + alivePlayerCount <- length . toListOf (players . traverse . alive) <$> get + + booteeNames <- uses boots $ Map.keys . Map.filter (\voters -> length voters > alivePlayerCount `div` 2) + bootees <- mapM (findPlayerBy_ name) booteeNames + + forM_ (filter (is alive) bootees) $ \bootee -> do + tell [playerBootedMessage bootee] + + removePlayer (bootee ^. name) + +checkStage' :: (MonadRandom m, MonadState Game m, MonadWriter [Message] m) => m () +checkStage' = use stage >>= \stage' -> case stage' of + FerinasGrunt -> do + druid <- findPlayerBy_ role druidRole + players' <- filter (isn't alphaWolf) <$> getAdjacentAlivePlayers (druid ^. name) + + when (has werewolves players' || has lycans players') $ tell [ferinaGruntsMessage] + + advanceStage + + GameOver -> return () + + HuntersTurn1 -> whenM (use hunterRetaliated) advanceStage + + HuntersTurn2 -> whenM (use hunterRetaliated) advanceStage + + Lynching -> do + lynchVotee =<< preuse votee + + allVoters <- ifM (use jesterRevealed) + (uses players $ filter (isn't jester)) + (use players) + allowedVoters .= allVoters ^.. traverse . alive . name + + votes .= Map.empty + + advanceStage + + OraclesTurn -> do + whenM (hasuse $ players . oracles . dead) advanceStage + + whenM (isJust <$> use divine) advanceStage + + OrphansTurn -> do + whenM (hasuse $ players . orphans . dead) advanceStage + + whenM (isJust <$> use roleModel) advanceStage + + ProtectorsTurn -> do + whenM (hasuse $ players . protectors . dead) advanceStage + + whenM (isJust <$> use protect) advanceStage + + ScapegoatsTurn -> unlessM (use scapegoatBlamed) $ do + allowedVoters' <- use allowedVoters + tell [scapegoatChoseAllowedVotersMessage allowedVoters'] + + advanceStage + + SeersTurn -> do + whenM (hasuse $ players . seers . dead) advanceStage + + whenM (isJust <$> use see) advanceStage + + Sunrise -> do + round += 1 + + devourVotee =<< preuse votee + + whenJustM (use poison) $ \targetName -> do + target <- findPlayerBy_ name targetName + + killPlayer targetName + tell [playerPoisonedMessage target] + + whenJustM (preuse $ players . seers . alive) $ \seer -> do + target <- use see >>= findPlayerBy_ name . fromJust + + when (is alive target) $ tell [playerSeenMessage (seer ^. name) target] + + whenJustM (preuse $ players . oracles . alive) $ \oracle -> do + target <- use divine >>= findPlayerBy_ name . fromJust + + when (is alive target) $ tell [playerDivinedMessage (oracle ^. name) target] + + divine .= Nothing + poison .= Nothing + protect .= Nothing + see .= Nothing + votes .= Map.empty + + advanceStage + + Sunset -> do + whenJustM (use roleModel) $ \roleModelsName -> do + orphan <- findPlayerBy_ role orphanRole + + whenM (isPlayerDead roleModelsName &&^ return (is alive orphan) &&^ return (is villager orphan)) $ do + aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get + + setPlayerAllegiance (orphan ^. name) Werewolves + + tell $ orphanJoinedPackMessages (orphan ^. name) aliveWerewolfNames + + advanceStage + + VillageDrunksTurn -> do + aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get + + randomAllegiance <- getRandomAllegiance + players . villageDrunks . role . allegiance .= randomAllegiance + + villageDrunk <- findPlayerBy_ role villageDrunkRole + + if is villager villageDrunk + then tell [villageDrunkJoinedVillageMessage $ villageDrunk ^. name] + else tell $ villageDrunkJoinedPackMessages (villageDrunk ^. name) aliveWerewolfNames + + advanceStage + + VillagesTurn -> whenM (null <$> liftM2 intersect getAllowedVoters getPendingVoters) $ do + tell . map (uncurry $ playerMadeLynchVoteMessage Nothing) =<< uses votes Map.toList + + advanceStage + + WerewolvesTurn -> whenM (none (is werewolf) <$> getPendingVoters) $ do + whenM (liftM2 (==) (use protect) (preuses votee $ view name)) $ votes .= Map.empty + + advanceStage + + WitchsTurn -> do + whenM (hasuse $ players . witches . dead) advanceStage + + whenM (use healUsed &&^ use poisonUsed) advanceStage + whenM (use passed) advanceStage + +lynchVotee :: (MonadState Game m, MonadWriter [Message] m) => Maybe Player -> m () +lynchVotee (Just votee) + | is jester votee = do + jesterRevealed .= True + + tell [jesterLynchedMessage $ votee ^. name] + | is fallenAngel votee = do + fallenAngelLynched .= True + + tell [playerLynchedMessage votee] + | otherwise = do + killPlayer (votee ^. name) + tell [playerLynchedMessage votee] +lynchVotee _ = preuse (players . scapegoats . alive) >>= \mScapegoat -> case mScapegoat of + Just scapegoat -> do + scapegoatBlamed .= True + + killPlayer (scapegoat ^. name) + tell [scapegoatLynchedMessage (scapegoat ^. name)] + _ -> tell [noPlayerLynchedMessage] + +devourVotee :: (MonadState Game m, MonadWriter [Message] m) => Maybe Player -> m () +devourVotee Nothing = tell [noPlayerDevouredMessage] +devourVotee (Just votee) = do + killPlayer (votee ^. name) + tell [playerDevouredMessage votee] + + when (is medusa votee) . whenJustM (getFirstAdjacentAliveWerewolf $ votee ^. name) $ \werewolf -> do + killPlayer (werewolf ^. name) + tell [playerTurnedToStoneMessage werewolf] + +advanceStage :: (MonadState Game m, MonadWriter [Message] m) => m () +advanceStage = do + game <- get + nextStage <- ifM hasAnyoneWon + (return GameOver) + (return . head $ filter (stageAvailable game) (drop1 $ dropWhile (game ^. stage /=) stageCycle)) + + stage .= nextStage + boots .= Map.empty + passed .= False + + tell . stageMessages =<< get + +checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () +checkGameOver = whenM hasAnyoneWon $ stage .= GameOver >> get >>= tell . gameOverMessages diff --git a/app/Game/Werewolf/Messages.hs b/app/Game/Werewolf/Messages.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Messages.hs @@ -0,0 +1,661 @@ +{-| +Module : Game.Werewolf.Messages +Description : Suite of messages used throughout the game. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +A 'Message' is used to relay information back to either all players or a single player. This module +defines suite of messages used throughout the werewolf game, including both game play messages and +binary errors. + +@werewolf@ was designed to be ambivalent to the playing chat client. The response-message structure +reflects this by staying away from anything that could be construed as client-specific. This +includes features such as emoji support. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Game.Werewolf.Messages ( + -- * Generic messages + newGameMessages, stageMessages, gameOverMessages, playerQuitMessage, gameIsOverMessage, + playerKilledMessage, + + -- ** Error messages + playerDoesNotExistMessage, playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, + playerIsDeadMessage, targetIsDeadMessage, + + -- * Boot messages + playerVotedToBootMessage, playerBootedMessage, + + -- ** Error messages + playerHasAlreadyVotedToBootMessage, + + -- * Circle messages + circleMessage, + + -- * Ping messages + pingPlayerMessage, pingRoleMessage, + + -- * Status messages + currentStageMessages, rolesInGameMessage, playersInGameMessage, + + -- * Druid's turn messages + ferinaGruntsMessage, + + -- * Hunter's turn messages + playerShotMessage, + + -- * Oracle's turn messages + playerDivinedMessage, + + -- * Orphan's turn messages + orphanJoinedPackMessages, + + -- * Protector's turn messages + + -- ** Error messages + playerCannotProtectSamePlayerTwiceInARowMessage, + + -- * Scapegoat's turn messages + scapegoatChoseAllowedVotersMessage, + + -- ** Error messages + playerMustChooseAtLeastOneTargetMessage, playerCannotChooseJesterMessage, + + -- * Seer's turn messages + playerSeenMessage, + + -- * Village Drunk's turn messages + villageDrunkJoinedVillageMessage, villageDrunkJoinedPackMessages, + + -- * Villages' turn messages + playerMadeLynchVoteMessage, playerRescindedVoteMessage, playerLynchedMessage, + noPlayerLynchedMessage, jesterLynchedMessage, scapegoatLynchedMessage, + + -- ** Error messages + playerHasAlreadyVotedMessage, playerHasNotVotedMessage, + + -- * Werewolves' turn messages + playerMadeDevourVoteMessage, playerDevouredMessage, playerTurnedToStoneMessage, + noPlayerDevouredMessage, + + -- ** Error messages + playerCannotDevourAnotherWerewolfMessage, + + -- ** Error messages + playerCannotChooseSelfMessage, + + -- * Witch's turn messages + playerPoisonedMessage, + + -- ** Error messages + playerHasAlreadyHealedMessage, playerHasAlreadyPoisonedMessage, +) where + +import Control.Arrow +import Control.Lens +import Control.Lens.Extra + +import Data.List.Extra +import Data.String.Humanise +import Data.Text (Text) +import qualified Data.Text as T + +import Game.Werewolf.Game +import Game.Werewolf.Player +import Game.Werewolf.Response +import Game.Werewolf.Role hiding (name) +import qualified Game.Werewolf.Role as Role + +newGameMessages :: Game -> [Message] +newGameMessages game = concat + [ [newPlayersInGameMessage $ players' ^.. names] + , [rolesInGameMessage Nothing $ players' ^.. roles] + , map newPlayerMessage players' + , beholderMessages + , spitefulGhostMessages + , trueVillagerMessages + , fallenAngelMessages + , stageMessages game + ] + where + players' = game ^. players + beholderMessages = case (,) <$> players' ^? beholders <*> players' ^? seers of + Just (beholder, seer) -> [beholderMessage (beholder ^. name) (seer ^. name)] + _ -> [] + spitefulGhostMessages = case players' ^? spitefulGhosts of + Just spitefulGhost -> [spitefulGhostMessage (spitefulGhost ^. name) (players' \\ [spitefulGhost])] + _ -> [] + trueVillagerMessages = case players' ^? trueVillagers of + Just trueVillager -> [trueVillagerMessage $ trueVillager ^. name] + _ -> [] + fallenAngelMessages = if has fallenAngels players' + then [fallenAngelMessage] + else [] + +newPlayersInGameMessage :: [Text] -> Message +newPlayersInGameMessage playerNames = publicMessage $ T.concat + ["A new game of werewolf is starting with ", concatList playerNames, "!"] + +newPlayerMessage :: Player -> Message +newPlayerMessage player = privateMessage (player ^. name) $ T.intercalate "\n" + [ T.concat ["You're ", article playerRole, " ", playerRole ^. Role.name, "."] + , playerRole ^. description + , playerRole ^. rules + ] + where + playerRole = player ^. role + +beholderMessage :: Text -> Text -> Message +beholderMessage to seerName = privateMessage to $ T.concat + [ "The Seer has always been held in high regard among the Villagers. Few are as lucky as you to" + , " know the Seer, ", seerName, ", personally." + ] + +spitefulGhostMessage :: Text -> [Player] -> Message +spitefulGhostMessage to players = privateMessage to $ T.concat + [ "Being ethereal seldom has it's benefits. Perhaps however this knowledge of the townsfolks' " + , "natures will bring you some joy in the afterlife: ", playerNamesWithRoles, "." + ] + where + playerNamesWithRoles = concatList $ map + (\player -> T.concat [player ^. name, " (", player ^. role . Role.name, ")"]) + players + +trueVillagerMessage :: Text -> Message +trueVillagerMessage name = publicMessage $ T.unwords + [ "Unguarded advice is seldom given, for advice is a dangerous gift, even from the wise to the" + , "wise, and all courses may run ill. Yet as you feel like you need help, I begrudgingly leave" + , "you with this:", name, "is the True Villager." + ] + +fallenAngelMessage :: Message +fallenAngelMessage = publicMessage $ T.unwords + [ "Alas, again I regrettably yield advice: an angelic menace walks among you. Do not cast your" + , "votes lightly, for they will relish in this opportunity to be free from their terrible" + , "nightmare." + ] + +stageMessages :: Game -> [Message] +stageMessages game = case game ^. stage of + FerinasGrunt -> [] + GameOver -> [] + HuntersTurn1 -> huntersTurnMessages huntersName + HuntersTurn2 -> huntersTurnMessages huntersName + Lynching -> [] + OraclesTurn -> oraclesTurnMessages oraclesName + OrphansTurn -> orphansTurnMessages orphansName + ProtectorsTurn -> protectorsTurnMessages protectorsName + ScapegoatsTurn -> scapegoatsTurnMessages scapegoatsName + SeersTurn -> seersTurnMessages seersName + Sunrise -> [sunriseMessage] + Sunset -> [nightFallsMessage] + VillageDrunksTurn -> [villageDrunksTurnMessage] + VillagesTurn -> villagesTurnMessages + WerewolvesTurn -> if is firstRound game + then firstWerewolvesTurnMessages aliveWerewolfNames + else werewolvesTurnMessages aliveWerewolfNames + WitchsTurn -> witchsTurnMessages game + where + players' = game ^. players + huntersName = players' ^?! hunters . name + oraclesName = players' ^?! oracles . name + orphansName = players' ^?! orphans . name + protectorsName = players' ^?! protectors . name + scapegoatsName = players' ^?! scapegoats . name + seersName = players' ^?! seers . name + aliveWerewolfNames = players' ^.. werewolves . alive . name + +huntersTurnMessages :: Text -> [Message] +huntersTurnMessages huntersName = + [ publicMessage $ T.unwords ["Just before", huntersName, "was murdered they let off a shot."] + , privateMessage huntersName "Whom do you `choose` to kill with your last shot?" + ] + +oraclesTurnMessages :: Text -> [Message] +oraclesTurnMessages to = + [ publicMessage "The Oracle wakes up." + , privateMessage to "Whose role would you like to `divine`?" + ] + +orphansTurnMessages :: Text -> [Message] +orphansTurnMessages to = + [ publicMessage "The Orphan wakes up." + , privateMessage to "Whom do you `choose` to be your role model?" + ] + +protectorsTurnMessages :: Text -> [Message] +protectorsTurnMessages to = + [ publicMessage "The Protector wakes up." + , privateMessage to "Whom would you like to `protect`?" + ] + +scapegoatsTurnMessages :: Text -> [Message] +scapegoatsTurnMessages scapegoatsName = + [ publicMessage "Just before the Scapegoat burns to a complete crisp, they cry out a dying wish." + , publicMessage $ T.concat [scapegoatsName, ", which players do you `choose` to vote on the next day?"] + ] + +seersTurnMessages :: Text -> [Message] +seersTurnMessages to = + [ publicMessage "The Seer wakes up." + , privateMessage to "Whose allegiance would you like to `see`?" + ] + +villageDrunksTurnMessage :: Message +villageDrunksTurnMessage = publicMessage "The Village Drunk sobers up." + +sunriseMessage :: Message +sunriseMessage = publicMessage "The sun rises. Everybody wakes up and opens their eyes..." + +nightFallsMessage :: Message +nightFallsMessage = publicMessage "Night falls, the village is asleep." + +villagesTurnMessages :: [Message] +villagesTurnMessages = + [ publicMessage "As the village gathers in the square the Town Clerk calls for a vote." + , publicMessage "Whom would you like to `vote` to lynch?" + ] + +firstWerewolvesTurnMessages :: [Text] -> [Message] +firstWerewolvesTurnMessages tos = + [privateMessage to $ packMessage to | length tos > 1, to <- tos] + ++ werewolvesTurnMessages tos + where + packMessage werewolfName = T.unwords + [ "You feel restless, like an old curse is keeping you from sleep. It seems you're not" + , "the only one...", packNames werewolfName + , conjugateToBe (length tos - 1), "also emerging from their" + , tryPlural (length tos - 1) "home" + ] + packNames werewolfName = concatList $ tos \\ [werewolfName] + +werewolvesTurnMessages :: [Text] -> [Message] +werewolvesTurnMessages tos = + publicMessage "The Werewolves wake up, transform and choose a new victim." + : groupMessages tos "Whom would you like to `vote` to devour?" + +witchsTurnMessages :: Game -> [Message] +witchsTurnMessages game = concat + [ [wakeUpMessage] + , devourMessages + , healMessages + , poisonMessages + , [passMessage] + ] + where + witchsName = game ^?! players . witches . name + wakeUpMessage = publicMessage "The Witch wakes up." + passMessage = privateMessage witchsName "Type `pass` to end your turn." + devourMessages = case game ^? votee of + Just votee -> + [ privateMessage witchsName $ + T.unwords ["You see", votee ^. name, "sprawled outside bleeding uncontrollably."] + ] + _ -> [] + healMessages + | game ^. healUsed = [] + | hasn't votee game = [] + | otherwise = [privateMessage witchsName "Would you like to `heal` them?"] + poisonMessages + | game ^. poisonUsed = [] + | otherwise = [privateMessage witchsName "Would you like to `poison` anyone?"] + +gameOverMessages :: Game -> [Message] +gameOverMessages game + | hasFallenAngelWon game = concat + [ [publicMessage "You should have heeded my warning, for now the Fallen Angel has been set free!"] + , [publicMessage "The game is over! The Fallen Angel has won."] + , [playerRolesMessage] + , [playerWonMessage fallenAngelsName] + , map playerLostMessage (game ^.. players . names \\ [fallenAngelsName]) + ] + | hasVillagersWon game = concat + [ [publicMessage "The game is over! The Villagers have won."] + , [playerRolesMessage] + , playerWonMessages + , playerContributedMessages + , playerLostMessages + ] + | hasWerewolvesWon game = concat + [ [publicMessage "The game is over! The Werewolves have won."] + , [playerRolesMessage] + , playerWonMessages + , playerContributedMessages + , playerLostMessages + ] + | otherwise = undefined + where + playerRolesMessage = publicMessage $ T.concat + [ "As I know you're all wondering who lied to you, here's the role allocations: " + , concatList $ map + (\player -> T.concat [player ^. name, " (", player ^. role . Role.name, ")"]) + (game ^. players) + , "." + ] + + winningAllegiance + | hasVillagersWon game = Villagers + | hasWerewolvesWon game = Werewolves + | otherwise = undefined + + winningPlayers = game ^.. players . traverse . filteredBy (role . allegiance) winningAllegiance + losingPlayers = game ^. players \\ winningPlayers + + playerWonMessages = map playerWonMessage (winningPlayers ^.. traverse . alive . name) + playerContributedMessages = map playerContributedMessage (winningPlayers ^.. traverse . dead . name) + playerLostMessages = map playerLostMessage (losingPlayers ^.. names) + + fallenAngelsName = game ^?! players . fallenAngels . name + +playerWonMessage :: Text -> Message +playerWonMessage to = privateMessage to "Victory! You won!" + +playerContributedMessage :: Text -> Message +playerContributedMessage to = privateMessage to "Your team won, but you died. Congratulations?" + +playerLostMessage :: Text -> Message +playerLostMessage to = privateMessage to "Feck, you lost this time round." + +playerQuitMessage :: Player -> Message +playerQuitMessage player = publicMessage $ T.unwords [playerName, "the", playerRole, "has quit!"] + where + playerName = player ^. name + playerRole = player ^. role . Role.name + +gameIsOverMessage :: Text -> Message +gameIsOverMessage to = privateMessage to "The game is over!" + +playerKilledMessage :: Text -> Message +playerKilledMessage to = privateMessage to "Guh, you've been killed!" + +playerDoesNotExistMessage :: Text -> Text -> Message +playerDoesNotExistMessage to name = privateMessage to $ T.unwords ["Player", name, "does not exist."] + +playerCannotDoThatMessage :: Text -> Message +playerCannotDoThatMessage to = privateMessage to "You cannot do that!" + +playerCannotDoThatRightNowMessage :: Text -> Message +playerCannotDoThatRightNowMessage to = privateMessage to "You cannot do that right now!" + +playerIsDeadMessage :: Text -> Message +playerIsDeadMessage to = privateMessage to "Sshh, you're meant to be dead!" + +targetIsDeadMessage :: Text -> Text -> Message +targetIsDeadMessage to targetName = privateMessage to $ T.unwords [targetName, "is already dead!"] + +playerVotedToBootMessage :: Text -> Text -> Message +playerVotedToBootMessage playerName targetName = publicMessage $ T.concat + [playerName, " voted to boot ", targetName, "!"] + +playerBootedMessage :: Player -> Message +playerBootedMessage player = publicMessage $ T.unwords + [ playerName, "the", playerRole ^. Role.name + , "has been booted from the game!" + ] + where + playerName = player ^. name + playerRole = player ^. role + +playerHasAlreadyVotedToBootMessage :: Text -> Text -> Message +playerHasAlreadyVotedToBootMessage to targetName = privateMessage to $ T.concat + ["You've already voted to boot ", targetName, "!"] + +circleMessage :: Text -> [Player] -> Message +circleMessage to players = privateMessage to $ T.intercalate "\n" + [ "The players are sitting in the following order:" + , T.intercalate " <-> " (map playerName (players ++ [head players])) + ] + where + playerName player = T.concat [player ^. name, if is dead player then " (dead)" else ""] + +pingPlayerMessage :: Text -> Message +pingPlayerMessage to = privateMessage to "Waiting on you..." + +pingRoleMessage :: Text -> Message +pingRoleMessage roleName = publicMessage $ T.concat ["Waiting on the ", roleName, "..."] + +currentStageMessages :: Text -> Stage -> [Message] +currentStageMessages _ FerinasGrunt = [] +currentStageMessages to GameOver = [gameIsOverMessage to] +currentStageMessages _ Lynching = [] +currentStageMessages _ Sunrise = [] +currentStageMessages _ Sunset = [] +currentStageMessages to turn = [privateMessage to $ T.concat + [ "It's currently the ", humanise turn, "." + ]] + +rolesInGameMessage :: Maybe Text -> [Role] -> Message +rolesInGameMessage mTo roles = Message mTo $ T.concat + [ "The roles in play are " + , concatList $ map (\(role, count) -> + T.concat [role ^. Role.name, " (", T.pack $ show count, ")"]) + roleCounts + , " for a total balance of ", T.pack $ show totalBalance, "." + ] + where + roleCounts = map (head &&& length) (groupSortOn (view Role.name) roles) + totalBalance = sumOf (traverse . balance) roles + +playersInGameMessage :: Text -> [Player] -> Message +playersInGameMessage to players = privateMessage to . T.intercalate "\n" $ + alivePlayersText : [deadPlayersText | any (is dead) players] + where + alivePlayers = players ^.. traverse . alive + deadPlayers = players ^.. traverse . dead + + alivePlayersText = T.concat + [ "The following players are still alive: " + , concatList $ map (\player -> if is trueVillager player then playerNameWithRole player else player ^. name) alivePlayers, "." + ] + deadPlayersText = T.concat + [ "The following players are dead: " + , concatList $ map playerNameWithRole deadPlayers, "." + ] + playerNameWithRole player = T.concat [player ^. name, " (", player ^. role . Role.name, ")"] + +ferinaGruntsMessage :: Message +ferinaGruntsMessage = publicMessage + "Ferina wakes from her slumber, disturbed and on edge. She loudly grunts as she smells danger." + +playerShotMessage :: Player -> Message +playerShotMessage target = publicMessage $ T.unwords + [ targetName, "the", targetRole, "slumps down to the ground, hands clutching at their chest" + , "while blood slips between their fingers and pools around them." + ] + where + targetName = target ^. name + targetRole = target ^. role . Role.name + +playerDivinedMessage :: Text -> Player -> Message +playerDivinedMessage to player = privateMessage to $ T.concat + [playerName, " is ", article playerRole, " ", playerRole ^. Role.name, "."] + where + playerName = player ^. name + playerRole = player ^. role + +orphanJoinedPackMessages :: Text -> [Text] -> [Message] +orphanJoinedPackMessages orphansName werewolfNames = + privateMessage orphansName (T.unwords + [ "The death of your role model is distressing. Without second thought you abandon the" + , "Villagers and run off into the woods, towards a new home. As you arrive you see the" + , tryPlural (length werewolfNames) "face", "of" + , concatList werewolfNames, "waiting for you." + ]) + : groupMessages werewolfNames (T.unwords + [ orphansName, "the Orphan scampers off into the woods. Without their role model they have" + , "abandoned the village and are in search of a new home. You welcome them into your pack." + ]) + +playerCannotProtectSamePlayerTwiceInARowMessage :: Text -> Message +playerCannotProtectSamePlayerTwiceInARowMessage to = + privateMessage to "You cannot protect the same player twice in a row!" + +scapegoatChoseAllowedVotersMessage :: [Text] -> Message +scapegoatChoseAllowedVotersMessage allowedVoters = publicMessage $ T.unwords + [ "On the next day only", concatList allowedVoters, "shall be allowed to vote. The Town Crier," + , "realising how foolish it was to kill the Scapegoat, grants them this wish." + ] + +playerMustChooseAtLeastOneTargetMessage :: Text -> Message +playerMustChooseAtLeastOneTargetMessage to = + privateMessage to "You must choose at least 1 target!" + +playerCannotChooseJesterMessage :: Text -> Message +playerCannotChooseJesterMessage to = + privateMessage to "You cannot choose the Jester!" + +playerSeenMessage :: Text -> Player -> Message +playerSeenMessage to player = privateMessage to $ T.concat + [playerName, " is aligned with ", article, humanise allegiance', "."] + where + playerName = player ^. name + allegiance' + | is alphaWolf player = Villagers + | is lycan player = Werewolves + | otherwise = player ^. role . allegiance + article = if allegiance' == NoOne then "" else "the " + +villageDrunkJoinedVillageMessage :: Text -> Message +villageDrunkJoinedVillageMessage to = privateMessage to $ T.unwords + [ "Somehow you managed to avoid getting killed while in your drunken stupor. Thank God for" + , "that, maybe now you can actually help the village." + ] + +villageDrunkJoinedPackMessages :: Text -> [Text] -> [Message] +villageDrunkJoinedPackMessages villageDrunksName werewolfNames = + privateMessage villageDrunksName (T.concat + [ "As you start to feel sober for the first time in days a new thirst begins to take hold." + , " The bloodthirst starts to bring back memories, memories of your true home with " + , concatList werewolfNames, "." + ]) + : groupMessages werewolfNames (T.unwords + [ villageDrunksName + , "the Village Drunk has finally sobered up and remembered their true home." + ]) + +playerMadeLynchVoteMessage :: Maybe Text -> Text -> Text -> Message +playerMadeLynchVoteMessage mTo voterName targetName = Message mTo $ T.concat + [ voterName, " voted to lynch ", targetName, "." + ] + +playerRescindedVoteMessage :: Text -> Text -> Message +playerRescindedVoteMessage to voterName = privateMessage to $ T.unwords + [ voterName, "rescinded their vote." + ] + +playerLynchedMessage :: Player -> Message +playerLynchedMessage player + | is simpleWerewolf player + || is alphaWolf player = publicMessage $ T.concat + [ playerName, " is tied up to a pyre and set alight. As they scream their body starts to " + , "contort and writhe, transforming into ", article playerRole, " " + , playerRole ^. Role.name, ".", " Thankfully they go limp before breaking free of their " + , "restraints." + ] + | otherwise = publicMessage $ T.concat + [ playerName, " is tied up to a pyre and set alight. Eventually the screams start to die " + , "and with their last breath, they reveal themselves as ", article playerRole, " " + , playerRole ^. Role.name, "." + ] + where + playerName = player ^. name + playerRole = player ^. role + +noPlayerLynchedMessage :: Message +noPlayerLynchedMessage = publicMessage $ T.unwords + [ "Daylight is wasted as the townsfolk squabble over whom to tie up. Looks like no-one is being" + , "burned this day." + ] + +jesterLynchedMessage :: Text -> Message +jesterLynchedMessage name = publicMessage $ T.concat + [ "Just as the townsfolk tie ", name, " up to the pyre, a voice in the crowd yells out." + , " \"We can't burn ", name, "! He's the joke of the town!\" " + , name, " the Jester is quickly untied and apologised to." + ] + +scapegoatLynchedMessage :: Text -> Message +scapegoatLynchedMessage name = publicMessage $ T.unwords + [ "The townsfolk squabble over whom to tie up. Just as they are about to call it a day" + , "they notice that", name, "has been acting awfully suspicious." + , "Not wanting to take any chances,", name, "is promptly tied to a pyre and burned alive." + ] + +playerHasAlreadyVotedMessage :: Text -> Message +playerHasAlreadyVotedMessage to = privateMessage to "You've already voted!" + +playerHasNotVotedMessage :: Text -> Message +playerHasNotVotedMessage to = privateMessage to "You haven't voted yet!" + +playerMadeDevourVoteMessage :: Text -> Text -> Text -> Message +playerMadeDevourVoteMessage to voterName targetName = privateMessage to $ T.concat + [ voterName, " voted to devour ", targetName, "." + ] + +playerDevouredMessage :: Player -> Message +playerDevouredMessage player = publicMessage $ T.concat + [ "As you open them you notice a door broken down and " + , playerName, "'s guts half devoured and spilling out over the cobblestones." + , " From the look of their personal effects, you deduce they were " + , article playerRole, " ", playerRole ^. Role.name, "." + ] + where + playerName = player ^. name + playerRole = player ^. role + +playerTurnedToStoneMessage :: Player -> Message +playerTurnedToStoneMessage player = publicMessage $ T.unwords + [ "Next to them you see a stone", playerRole, "statue, cold to the touch.", playerName + , "must have looked into the eyes of the Medusa at the very end." + ] + where + playerName = player ^. name + playerRole = player ^. role . Role.name + +noPlayerDevouredMessage :: Message +noPlayerDevouredMessage = publicMessage $ T.unwords + [ "Surprisingly you see everyone present at the town square." + , "Perhaps the Werewolves have left Fougères?" + ] + +playerCannotDevourAnotherWerewolfMessage :: Text -> Message +playerCannotDevourAnotherWerewolfMessage to = privateMessage to "You cannot devour another Werewolf!" + +playerCannotChooseSelfMessage :: Text -> Message +playerCannotChooseSelfMessage to = privateMessage to "You cannot choose yourself!" + +playerPoisonedMessage :: Player -> Message +playerPoisonedMessage player = publicMessage $ T.unwords + [ "Upon further discovery, it looks like the Witch struck in the night." + , playerName, "the", playerRole, "is hanging over the side of their bed, poisoned." + ] + where + playerName = player ^. name + playerRole = player ^. role . Role.name + +playerHasAlreadyHealedMessage :: Text -> Message +playerHasAlreadyHealedMessage to = privateMessage to "You've already healed someone!" + +playerHasAlreadyPoisonedMessage :: Text -> Message +playerHasAlreadyPoisonedMessage to = privateMessage to "You've already poisoned someone!" + +article :: Role -> Text +article role + | role `elem` restrictedRoles = "the" + | otherwise = "a" + +concatList :: [Text] -> Text +concatList [] = "" +concatList [word] = word +concatList words = T.unwords [T.intercalate ", " (init words), "and", last words] + +conjugateToBe :: Int -> Text +conjugateToBe 1 = "is" +conjugateToBe _ = "are" + +tryPlural :: Int -> Text -> Text +tryPlural 1 word = word +tryPlural _ word = T.snoc word 's' diff --git a/app/Game/Werewolf/Util.hs b/app/Game/Werewolf/Util.hs new file mode 100644 --- /dev/null +++ b/app/Game/Werewolf/Util.hs @@ -0,0 +1,208 @@ +{-| +Module : Game.Werewolf.Util +Description : Utility functions for working in a ('MonadState' 'Game') environment. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Utility functions for woking in a ('MonadState' 'Game') environment. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} + +module Game.Werewolf.Util ( + -- * Game + + -- ** Manipulations + killPlayer, removePlayer, setPlayerAllegiance, getRandomAllegiance, + + -- ** Searches + findPlayerBy_, getAdjacentAlivePlayers, getFirstAdjacentAliveWerewolf, getPlayerVote, + getAllowedVoters, getPendingVoters, + + -- ** Queries + isGameOver, isHuntersTurn, isOraclesTurn, isOrphansTurn, isProtectorsTurn, isScapegoatsTurn, + isSeersTurn, isSunrise, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, + hasAnyoneWon, hasFallenAngelWon, hasVillagersWon, hasWerewolvesWon, + + -- * Player + + -- ** Queries + doesPlayerExist, + isPlayerHunter, isPlayerJester, isPlayerOracle, isPlayerOrphan, isPlayerProtector, + isPlayerScapegoat, isPlayerSeer, isPlayerWitch, + isPlayerWerewolf, + isPlayerAlive, isPlayerDead, +) where + +import Control.Lens hiding (isn't) +import Control.Lens.Extra +import Control.Monad.Extra +import Control.Monad.Random +import Control.Monad.State hiding (state) +import Control.Monad.Writer + +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) + +import Game.Werewolf.Game hiding (getAllowedVoters, getPendingVoters, hasAnyoneWon, + hasFallenAngelWon, hasVillagersWon, hasWerewolvesWon) +import qualified Game.Werewolf.Game as Game +import Game.Werewolf.Messages +import Game.Werewolf.Player +import Game.Werewolf.Response +import Game.Werewolf.Role hiding (name) + +import Prelude hiding (round) + +killPlayer :: (MonadState Game m, MonadWriter [Message] m) => Text -> m () +killPlayer name = do + tell [playerKilledMessage name] + + players . traverse . named name . state .= Dead + +removePlayer :: (MonadState Game m, MonadWriter [Message] m) => Text -> m () +removePlayer name' = do + killPlayer name' + + votes %= Map.delete name' + + player <- findPlayerBy_ name name' + + when (is orphan player) $ roleModel .= Nothing + when (is protector player) $ do + protect .= Nothing + priorProtect .= Nothing + when (is seer player) $ see .= Nothing + when (is witch player) $ do + healUsed .= False + poison .= Nothing + poisonUsed .= False + +-- | Fudges the player's allegiance. This function is useful for roles such as the Orphan where +-- they align themselves differently given some trigger. +setPlayerAllegiance :: MonadState Game m => Text -> Allegiance -> m () +setPlayerAllegiance name allegiance' = modify $ players . traverse . named name . role . allegiance .~ allegiance' + +-- | Get a random allegiance (either Villagers or Werewolves). +getRandomAllegiance :: MonadRandom m => m Allegiance +getRandomAllegiance = fromList [(Villagers, 0.5), (Werewolves, 0.5)] + +findPlayerBy_ :: (Eq a, MonadState Game m) => Lens' Player a -> a -> m Player +findPlayerBy_ lens value = fromJust <$> preuse (players . traverse . filteredBy lens value) + +getAdjacentAlivePlayers :: MonadState Game m => Text -> m [Player] +getAdjacentAlivePlayers name' = do + alivePlayers <- toListOf (players . traverse . alive) <$> get + let index = fromJust $ elemIndex name' (alivePlayers ^.. names) + + return $ adjacentElements index alivePlayers + where + adjacentElements 0 list = last list : take 2 list + adjacentElements index list = take 3 . drop (index - 1) $ cycle list + +getFirstAdjacentAliveWerewolf :: MonadState Game m => Text -> m (Maybe Player) +getFirstAdjacentAliveWerewolf name = do + players' <- toListOf (players . traverse) <$> get + let index = fromJust $ elemIndex name (players' ^.. names) + let filteredPlayers = dropWhile (isn't werewolf) (drop index (players' ++ players') ^.. traverse . alive) + + return $ listToMaybe filteredPlayers + +getPlayerVote :: MonadState Game m => Text -> m (Maybe Text) +getPlayerVote playerName = use $ votes . at playerName + +getAllowedVoters :: MonadState Game m => m [Player] +getAllowedVoters = gets Game.getAllowedVoters + +getPendingVoters :: MonadState Game m => m [Player] +getPendingVoters = gets Game.getPendingVoters + +isGameOver :: MonadState Game m => m Bool +isGameOver = hasuse $ stage . _GameOver + +isHuntersTurn :: MonadState Game m => m Bool +isHuntersTurn = orM + [ hasuse $ stage . _HuntersTurn1 + , hasuse $ stage . _HuntersTurn2 + ] + +isOraclesTurn :: MonadState Game m => m Bool +isOraclesTurn = hasuse $ stage . _OraclesTurn + +isOrphansTurn :: MonadState Game m => m Bool +isOrphansTurn = hasuse $ stage . _OrphansTurn + +isProtectorsTurn :: MonadState Game m => m Bool +isProtectorsTurn = hasuse $ stage . _ProtectorsTurn + +isScapegoatsTurn :: MonadState Game m => m Bool +isScapegoatsTurn = hasuse $ stage . _ScapegoatsTurn + +isSeersTurn :: MonadState Game m => m Bool +isSeersTurn = hasuse $ stage . _SeersTurn + +isSunrise :: MonadState Game m => m Bool +isSunrise = hasuse $ stage . _Sunrise + +isVillagesTurn :: MonadState Game m => m Bool +isVillagesTurn = hasuse $ stage . _VillagesTurn + +isWerewolvesTurn :: MonadState Game m => m Bool +isWerewolvesTurn = hasuse $ stage . _WerewolvesTurn + +isWitchsTurn :: MonadState Game m => m Bool +isWitchsTurn = hasuse $ stage . _WitchsTurn + +hasAnyoneWon :: MonadState Game m => m Bool +hasAnyoneWon = gets Game.hasAnyoneWon + +hasFallenAngelWon :: MonadState Game m => m Bool +hasFallenAngelWon = gets Game.hasFallenAngelWon + +hasVillagersWon :: MonadState Game m => m Bool +hasVillagersWon = gets Game.hasVillagersWon + +hasWerewolvesWon :: MonadState Game m => m Bool +hasWerewolvesWon = gets Game.hasWerewolvesWon + +doesPlayerExist :: MonadState Game m => Text -> m Bool +doesPlayerExist name = hasuse $ players . traverse . named name + +isPlayerHunter :: MonadState Game m => Text -> m Bool +isPlayerHunter name' = is hunter <$> findPlayerBy_ name name' + +isPlayerJester :: MonadState Game m => Text -> m Bool +isPlayerJester name' = is jester <$> findPlayerBy_ name name' + +isPlayerOracle :: MonadState Game m => Text -> m Bool +isPlayerOracle name' = is oracle <$> findPlayerBy_ name name' + +isPlayerOrphan :: MonadState Game m => Text -> m Bool +isPlayerOrphan name' = is orphan <$> findPlayerBy_ name name' + +isPlayerProtector :: MonadState Game m => Text -> m Bool +isPlayerProtector name' = is protector <$> findPlayerBy_ name name' + +isPlayerScapegoat :: MonadState Game m => Text -> m Bool +isPlayerScapegoat name' = is scapegoat <$> findPlayerBy_ name name' + +isPlayerSeer :: MonadState Game m => Text -> m Bool +isPlayerSeer name' = is seer <$> findPlayerBy_ name name' + +isPlayerWitch :: MonadState Game m => Text -> m Bool +isPlayerWitch name' = is witch <$> findPlayerBy_ name name' + +isPlayerWerewolf :: MonadState Game m => Text -> m Bool +isPlayerWerewolf name' = is werewolf <$> findPlayerBy_ name name' + +isPlayerAlive :: MonadState Game m => Text -> m Bool +isPlayerAlive name' = is alive <$> findPlayerBy_ name name' + +isPlayerDead :: MonadState Game m => Text -> m Bool +isPlayerDead name' = is dead <$> findPlayerBy_ name name' diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -23,6 +23,7 @@ import qualified Werewolf.Command.Boot as Boot import qualified Werewolf.Command.Choose as Choose import qualified Werewolf.Command.Circle as Circle +import qualified Werewolf.Command.Divine as Divine import qualified Werewolf.Command.End as End import qualified Werewolf.Command.Heal as Heal import qualified Werewolf.Command.Help as Help @@ -35,6 +36,7 @@ import qualified Werewolf.Command.See as See import qualified Werewolf.Command.Start as Start import qualified Werewolf.Command.Status as Status +import qualified Werewolf.Command.Unvote as Unvote import qualified Werewolf.Command.Version as Version import qualified Werewolf.Command.Vote as Vote import Werewolf.Options @@ -58,6 +60,7 @@ Choose options -> Choose.handle callerName tag options Boot options -> Boot.handle callerName tag options Circle options -> Circle.handle callerName tag options + Divine options -> Divine.handle callerName tag options End options -> End.handle callerName tag options Heal -> Heal.handle callerName tag Help options -> Help.handle callerName tag options @@ -70,5 +73,6 @@ See options -> See.handle callerName tag options Start options -> Start.handle callerName tag options Status -> Status.handle callerName tag + Unvote -> Unvote.handle callerName tag Version -> Version.handle callerName Vote options -> Vote.handle callerName tag options diff --git a/app/Werewolf/Command/Boot.hs b/app/Werewolf/Command/Boot.hs --- a/app/Werewolf/Command/Boot.hs +++ b/app/Werewolf/Command/Boot.hs @@ -26,10 +26,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Global +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { argTarget :: Text diff --git a/app/Werewolf/Command/Choose.hs b/app/Werewolf/Command/Choose.hs --- a/app/Werewolf/Command/Choose.hs +++ b/app/Werewolf/Command/Choose.hs @@ -29,12 +29,15 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Hunter as Hunter import Game.Werewolf.Command.Orphan as Orphan import Game.Werewolf.Command.Scapegoat as Scapegoat +import Game.Werewolf.Engine +import Game.Werewolf.Messages -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { args :: [Text] diff --git a/app/Werewolf/Command/Circle.hs b/app/Werewolf/Command/Circle.hs --- a/app/Werewolf/Command/Circle.hs +++ b/app/Werewolf/Command/Circle.hs @@ -25,10 +25,11 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Status -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { optIncludeDead :: Bool diff --git a/app/Werewolf/Command/Divine.hs b/app/Werewolf/Command/Divine.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Command/Divine.hs @@ -0,0 +1,53 @@ +{-| +Module : Werewolf.Command.Divine +Description : Options and handler for the divine subcommand. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Options and handler for the divine subcommand. +-} + +module Werewolf.Command.Divine ( + -- * Options + Options(..), + + -- * Handle + handle, +) where + +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Random +import Control.Monad.State +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Command.Oracle +import Game.Werewolf.Engine + +import Werewolf.Messages +import Werewolf.System + +data Options = Options + { argTarget :: Text + } deriving (Eq, Show) + +handle :: (MonadIO m, MonadRandom m) => Text -> Text -> Options -> m () +handle callerName tag (Options targetName) = do + unlessM (doesGameExist tag) $ exitWith failure + { messages = [noGameRunningMessage callerName] + } + + game <- readGame tag + + let command = divineCommand callerName targetName + + result <- runExceptT . runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game + case result of + Left errorMessages -> exitWith failure { messages = errorMessages } + Right (game', messages) -> writeOrDeleteGame tag game' >> exitWith success { messages = messages } diff --git a/app/Werewolf/Command/End.hs b/app/Werewolf/Command/End.hs --- a/app/Werewolf/Command/End.hs +++ b/app/Werewolf/Command/End.hs @@ -19,6 +19,7 @@ handle, ) where +import Control.Lens import Control.Monad.Extra import Control.Monad.IO.Class @@ -26,9 +27,10 @@ import qualified Data.Text as T import Game.Werewolf +import Game.Werewolf.Messages -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { optForce :: Bool @@ -41,11 +43,12 @@ unless force $ do game <- readGame tag - unless (doesPlayerExist callerName game) $ + unless (has (players . traverse . named callerName) game) $ exitWith failure { messages = [playerCannotDoThatMessage callerName] } deleteGame tag exitWith success { messages = [gameEndedMessage] } where + -- TODO (hjw): move this to Messages gameEndedMessage = publicMessage $ T.concat ["Game ended by ", callerName, "."] diff --git a/app/Werewolf/Command/Heal.hs b/app/Werewolf/Command/Heal.hs --- a/app/Werewolf/Command/Heal.hs +++ b/app/Werewolf/Command/Heal.hs @@ -25,10 +25,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Witch +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System handle :: (MonadIO m, MonadRandom m) => Text -> Text -> m () handle callerName tag = do diff --git a/app/Werewolf/Command/Help.hs b/app/Werewolf/Command/Help.hs --- a/app/Werewolf/Command/Help.hs +++ b/app/Werewolf/Command/Help.hs @@ -20,7 +20,6 @@ ) where import Control.Lens -import Control.Lens.Extra import Control.Monad.Extra import Control.Monad.IO.Class @@ -29,10 +28,10 @@ import Data.Text (Text) import qualified Data.Text as T -import Game.Werewolf hiding (Command) +import Game.Werewolf import qualified Game.Werewolf.Role as Role -import Werewolf.Game +import Werewolf.System data Options = Options { argCommand :: Maybe Command @@ -87,11 +86,16 @@ ] , [ "Standard commands:" , "- `vote PLAYER`" + , "- `unvote`" ] , whenPlayerHasRole callerName mGame hunterRole [ "Hunter commands:" , "- `choose PLAYER`" ] + , whenPlayerHasRole callerName mGame oracleRole + [ "Oracle commands:" + , "- `divine PLAYER`" + ] , whenPlayerHasRole callerName mGame orphanRole [ "Orphan commands:" , "- `choose PLAYER`" @@ -142,13 +146,7 @@ ] ] , filter (/= "") - [ T.concat - [ "A game begins at night and follows a standard cycle." - , whenRoleInPlay mGame fallenAngelRole - " (N.B., when the Fallen Angel is in play the game begins with the village vote.)" - ] - , whenRoleInPlay mGame fallenAngelRole - "- (When the Fallen Angel is in play) the village votes to lynch a suspect." + [ "A game begins at night and follows a standard cycle." , "- The village falls asleep." , whenRoleInPlay mGame orphanRole "- (First round only) the Orphan wakes up and chooses a role model." @@ -156,6 +154,8 @@ "- (Third round only) the Village Drunk sobers up and remembers their allegiance." , whenRoleInPlay mGame seerRole "- The Seer wakes up and sees someone's allegiance." + , whenRoleInPlay mGame oracleRole + "- The Oracle wakes up and divines someone's role." , whenRoleInPlay mGame protectorRole "- The Protector wakes up and protects someone." , "- The Werewolves wake up and vote to devour a victim." @@ -201,13 +201,13 @@ ] whenPlayerHasRole :: Monoid m => Text -> Maybe Game -> Role -> m -> m -whenPlayerHasRole _ Nothing _ m = m +whenPlayerHasRole _ Nothing _ m = m whenPlayerHasRole callerName (Just game) role' m - | hasn't (players . names . only callerName) game = mempty - | hasn't (role . only role') player = mempty - | otherwise = m + | hasn't (players . traverse . named callerName) game = mempty + | hasn't (role . only role') player = mempty + | otherwise = m where - player = game ^?! players . traverse . filteredBy name callerName + player = game ^?! players . traverse . named callerName ifRoleInPlay :: Maybe Game -> Role -> a -> a -> a ifRoleInPlay Nothing _ true _ = true diff --git a/app/Werewolf/Command/Pass.hs b/app/Werewolf/Command/Pass.hs --- a/app/Werewolf/Command/Pass.hs +++ b/app/Werewolf/Command/Pass.hs @@ -23,10 +23,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Witch +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System handle :: (MonadIO m, MonadRandom m) => Text -> Text -> m () handle callerName tag = do diff --git a/app/Werewolf/Command/Ping.hs b/app/Werewolf/Command/Ping.hs --- a/app/Werewolf/Command/Ping.hs +++ b/app/Werewolf/Command/Ping.hs @@ -22,10 +22,11 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Status -import Werewolf.Game import Werewolf.Messages +import Werewolf.System handle :: MonadIO m => Text -> Text -> m () handle callerName tag = do diff --git a/app/Werewolf/Command/Poison.hs b/app/Werewolf/Command/Poison.hs --- a/app/Werewolf/Command/Poison.hs +++ b/app/Werewolf/Command/Poison.hs @@ -26,10 +26,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Witch +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { argTarget :: Text diff --git a/app/Werewolf/Command/Protect.hs b/app/Werewolf/Command/Protect.hs --- a/app/Werewolf/Command/Protect.hs +++ b/app/Werewolf/Command/Protect.hs @@ -26,10 +26,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Protector +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { argTarget :: Text diff --git a/app/Werewolf/Command/Quit.hs b/app/Werewolf/Command/Quit.hs --- a/app/Werewolf/Command/Quit.hs +++ b/app/Werewolf/Command/Quit.hs @@ -23,10 +23,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Global +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System handle :: (MonadIO m, MonadRandom m) => Text -> Text -> m () handle callerName tag = do diff --git a/app/Werewolf/Command/See.hs b/app/Werewolf/Command/See.hs --- a/app/Werewolf/Command/See.hs +++ b/app/Werewolf/Command/See.hs @@ -26,10 +26,12 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Seer +import Game.Werewolf.Engine -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { argTarget :: Text diff --git a/app/Werewolf/Command/Start.hs b/app/Werewolf/Command/Start.hs --- a/app/Werewolf/Command/Start.hs +++ b/app/Werewolf/Command/Start.hs @@ -32,13 +32,14 @@ import Data.Text (Text) import qualified Data.Text as T -import Game.Werewolf hiding (name) -import Game.Werewolf.Role +import Game.Werewolf +import Game.Werewolf.Engine +import Game.Werewolf.Role as Role import System.Random.Shuffle -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { optExtraRoles :: ExtraRoles @@ -86,6 +87,26 @@ Nothing -> throwError [roleDoesNotExistMessage callerName roleName] findByName :: Text -> Maybe Role -findByName name' = restrictedRoles ^? traverse . filtered ((sanitise name' ==) . T.toLower . sanitise . view name) +findByName name' = restrictedRoles ^? traverse . filtered ((sanitise name' ==) . T.toLower . sanitise . view Role.name) where sanitise = T.replace " " "-" + +padRoles :: [Role] -> Int -> [Role] +padRoles roles n = roles ++ simpleVillagerRoles ++ simpleWerewolfRoles + where + goal = 3 + m = max (n - length roles) 0 + startingBalance = sumOf (traverse . balance) roles + simpleWerewolfBalance = simpleWerewolfRole ^. balance + + -- Little magic here to calculate how many Werewolves and Villagers we want. + -- This tries to ensure that the balance of the game is between -2 and 2. + simpleWerewolvesCount = (goal - m - startingBalance) `div` (simpleWerewolfBalance - 1) + 1 + simpleVillagersCount = m - simpleWerewolvesCount + + -- N.B., if roles is quite unbalanced then one list will be empty. + simpleVillagerRoles = replicate simpleVillagersCount simpleVillagerRole + simpleWerewolfRoles = replicate simpleWerewolvesCount simpleWerewolfRole + +createPlayers :: [Text] -> [Role] -> [Player] +createPlayers = zipWith newPlayer diff --git a/app/Werewolf/Command/Status.hs b/app/Werewolf/Command/Status.hs --- a/app/Werewolf/Command/Status.hs +++ b/app/Werewolf/Command/Status.hs @@ -22,10 +22,11 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Status -import Werewolf.Game import Werewolf.Messages +import Werewolf.System handle :: MonadIO m => Text -> Text -> m () handle callerName tag = do diff --git a/app/Werewolf/Command/Unvote.hs b/app/Werewolf/Command/Unvote.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/Command/Unvote.hs @@ -0,0 +1,54 @@ +{-| +Module : Werewolf.Command.Unvote +Description : Handler for the unvote subcommand. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +Handler for the unvote subcommand. +-} + +module Werewolf.Command.Unvote ( + -- * Handle + handle, +) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Random +import Control.Monad.State +import Control.Monad.Writer + +import Data.Text (Text) + +import Game.Werewolf +import Game.Werewolf.Command +import Game.Werewolf.Command.Villager as Villager +import Game.Werewolf.Command.Werewolf as Werewolf +import Game.Werewolf.Engine +import Game.Werewolf.Messages + +import Werewolf.Messages +import Werewolf.System + +handle :: (MonadIO m, MonadRandom m) => Text -> Text -> m () +handle callerName tag = do + unlessM (doesGameExist tag) $ exitWith failure + { messages = [noGameRunningMessage callerName] + } + + game <- readGame tag + + command <- case game ^. stage of + VillagesTurn -> return $ Villager.unvoteCommand callerName + WerewolvesTurn -> return $ Werewolf.unvoteCommand callerName + _ -> exitWith failure + { messages = [playerCannotDoThatRightNowMessage callerName] + } + + result <- runExceptT . runWriterT $ execStateT (apply command >> checkStage >> checkGameOver) game + case result of + Left errorMessages -> exitWith failure { messages = errorMessages } + Right (game', messages) -> writeOrDeleteGame tag game' >> exitWith success { messages = messages } diff --git a/app/Werewolf/Command/Vote.hs b/app/Werewolf/Command/Vote.hs --- a/app/Werewolf/Command/Vote.hs +++ b/app/Werewolf/Command/Vote.hs @@ -27,11 +27,14 @@ import Data.Text (Text) import Game.Werewolf +import Game.Werewolf.Command import Game.Werewolf.Command.Villager as Villager import Game.Werewolf.Command.Werewolf as Werewolf +import Game.Werewolf.Engine +import Game.Werewolf.Messages -import Werewolf.Game import Werewolf.Messages +import Werewolf.System data Options = Options { argTarget :: Text diff --git a/app/Werewolf/Game.hs b/app/Werewolf/Game.hs deleted file mode 100644 --- a/app/Werewolf/Game.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-| -Module : Werewolf.Game -Description : Game functions pertaining to binary calls. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -This module defines a few utility functions for working with a game state file. It also provides -functions for padding roles and shuffling them when creating players. --} - -module Werewolf.Game ( - -- * Game - - -- ** Creating anew - startGame, createPlayers, padRoles, - - -- ** Working with an existing - filePath, readGame, writeGame, deleteGame, writeOrDeleteGame, doesGameExist, -) where - -import Control.Lens hiding (cons) -import Control.Monad.Except - -import Data.List.Extra -import Data.Text (Text) -import qualified Data.Text as T - -import Game.Werewolf - -import Prelude hiding (round) - -import System.Directory -import System.FilePath - -createPlayers :: [Text] -> [Role] -> [Player] -createPlayers = zipWith newPlayer - -padRoles :: [Role] -> Int -> [Role] -padRoles roles n = roles ++ simpleVillagerRoles ++ simpleWerewolfRoles - where - goal = 3 - m = max (n - length roles) 0 - startingBalance = sumOf (traverse . balance) roles - simpleWerewolfBalance = simpleWerewolfRole ^. balance - - -- Little magic here to calculate how many Werewolves and Villagers we want. - -- This tries to ensure that the balance of the game is between -2 and 2. - simpleWerewolvesCount = (goal - m - startingBalance) `div` (simpleWerewolfBalance - 1) + 1 - simpleVillagersCount = m - simpleWerewolvesCount - - -- N.B., if roles is quite unbalanced then one list will be empty. - simpleVillagerRoles = replicate simpleVillagersCount simpleVillagerRole - simpleWerewolfRoles = replicate simpleWerewolvesCount simpleWerewolfRole - -filePath :: MonadIO m => Text -> m FilePath -filePath tag = ( ".werewolf" T.unpack tag) <$> liftIO getHomeDirectory - -readGame :: MonadIO m => Text -> m Game -readGame tag = liftIO . fmap read $ filePath tag >>= readFile - -writeGame :: MonadIO m => Text -> Game -> m () -writeGame tag game = liftIO $ filePath tag >>= \tag -> do - createDirectoryIfMissing True (dropFileName tag) - - writeFile tag (show game) - -deleteGame :: MonadIO m => Text -> m () -deleteGame tag = liftIO $ filePath tag >>= removeFile - -writeOrDeleteGame :: MonadIO m => Text -> Game -> m () -writeOrDeleteGame tag game - | has (stage . _GameOver) game = deleteGame tag - | otherwise = writeGame tag game - -doesGameExist :: MonadIO m => Text -> m Bool -doesGameExist tag = liftIO $ filePath tag >>= doesFileExist diff --git a/app/Werewolf/Messages.hs b/app/Werewolf/Messages.hs --- a/app/Werewolf/Messages.hs +++ b/app/Werewolf/Messages.hs @@ -17,7 +17,6 @@ -- ** Error messages noGameRunningMessage, gameAlreadyRunningMessage, roleDoesNotExistMessage, - playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, ) where import Data.Text (Text) @@ -38,9 +37,3 @@ roleDoesNotExistMessage :: Text -> Text -> Message roleDoesNotExistMessage to name = privateMessage to $ T.unwords ["Role", name, "does not exist."] - -playerCannotDoThatMessage :: Text -> Message -playerCannotDoThatMessage to = privateMessage to "You cannot do that!" - -playerCannotDoThatRightNowMessage :: Text -> Message -playerCannotDoThatRightNowMessage to = privateMessage to "You cannot do that right now!" diff --git a/app/Werewolf/Options.hs b/app/Werewolf/Options.hs --- a/app/Werewolf/Options.hs +++ b/app/Werewolf/Options.hs @@ -26,6 +26,7 @@ import qualified Werewolf.Command.Boot as Boot import qualified Werewolf.Command.Choose as Choose import qualified Werewolf.Command.Circle as Circle +import qualified Werewolf.Command.Divine as Divine import qualified Werewolf.Command.End as End import qualified Werewolf.Command.Help as Help import qualified Werewolf.Command.Interpret as Interpret @@ -48,6 +49,7 @@ = Boot Boot.Options | Choose Choose.Options | Circle Circle.Options + | Divine Divine.Options | End End.Options | Heal | Help Help.Options @@ -60,6 +62,7 @@ | See See.Options | Start Start.Options | Status + | Unvote | Version | Vote Vote.Options deriving (Eq, Show) @@ -96,6 +99,7 @@ [ command "boot" $ info (helper <*> boot) (fullDesc <> progDesc "Vote to boot a player") , command "choose" $ info (helper <*> choose) (fullDesc <> progDesc "Choose an allegiance or player(s)") , command "circle" $ info (helper <*> circle) (fullDesc <> progDesc "Get the game circle") + , command "divine" $ info (helper <*> divine) (fullDesc <> progDesc "Divine a player's role") , command "end" $ info (helper <*> end) (fullDesc <> progDesc "End the current game") , command "heal" $ info (helper <*> heal) (fullDesc <> progDesc "Heal the devoured player") , command "help" $ info (helper <*> help_) (fullDesc <> progDesc "Help documents") @@ -108,6 +112,7 @@ , command "see" $ info (helper <*> see) (fullDesc <> progDesc "See a player's allegiance") , command "start" $ info (helper <*> start) (fullDesc <> progDesc "Start a new game") , command "status" $ info (helper <*> status) (fullDesc <> progDesc "Get the status of the current game") + , command "unvote" $ info (helper <*> unvote) (fullDesc <> progDesc "Rescind a vote") , command "version" $ info (helper <*> version) (fullDesc <> progDesc "Show this engine's version") , command "vote" $ info (helper <*> vote) (fullDesc <> progDesc "Vote against a player") ]) @@ -125,6 +130,9 @@ , help "Include dead players" ]) +divine :: Parser Command +divine = Divine . Divine.Options <$> playerArgument + end :: Parser Command end = End . End.Options <$> switch (mconcat @@ -189,6 +197,9 @@ status :: Parser Command status = pure Status + +unvote :: Parser Command +unvote = pure Unvote version :: Parser Command version = pure Version diff --git a/app/Werewolf/System.hs b/app/Werewolf/System.hs new file mode 100644 --- /dev/null +++ b/app/Werewolf/System.hs @@ -0,0 +1,82 @@ +{-| +Module : Werewolf.System +Description : System functions for working with a game state file. + +Copyright : (c) Henry J. Wylde, 2016 +License : BSD3 +Maintainer : public@hjwylde.com + +This module defines a few system functions for working with a game state file. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Werewolf.System ( + -- * Game + + -- ** Creating anew + startGame, + + -- ** Working with an existing + filePath, readGame, writeGame, deleteGame, writeOrDeleteGame, doesGameExist, +) where + +import Control.Lens hiding (cons) +import Control.Lens.Extra +import Control.Monad.Except +import Control.Monad.Writer + +import Data.List +import Data.Text (Text) +import qualified Data.Text as T + +import Game.Werewolf +import Game.Werewolf.Messages +import Game.Werewolf.Role as Role + +import Prelude hiding (round) + +import System.Directory +import System.FilePath + +startGame :: (MonadError [Message] m, MonadWriter [Message] m) => Text -> [Player] -> m Game +startGame callerName players = do + -- TODO (hjw): move the messages to Messages + 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."] + forM_ restrictedRoles $ \role' -> + when (length (players ^.. traverse . filteredBy role role') > 1) $ + throwError [privateMessage callerName $ T.concat ["Cannot have more than 1 ", role' ^. Role.name, "."]] + + let game = newGame players + + tell $ newGameMessages game + + return game + where + playerNames = players ^.. names + +filePath :: MonadIO m => Text -> m FilePath +filePath tag = ( ".werewolf" T.unpack tag) <$> liftIO getHomeDirectory + +readGame :: MonadIO m => Text -> m Game +readGame tag = liftIO . fmap read $ filePath tag >>= readFile + +writeGame :: MonadIO m => Text -> Game -> m () +writeGame tag game = liftIO $ filePath tag >>= \tag -> do + createDirectoryIfMissing True (dropFileName tag) + + writeFile tag (show game) + +deleteGame :: MonadIO m => Text -> m () +deleteGame tag = liftIO $ filePath tag >>= removeFile + +writeOrDeleteGame :: MonadIO m => Text -> Game -> m () +writeOrDeleteGame tag game + | has (stage . _GameOver) game = deleteGame tag + | otherwise = writeGame tag game + +doesGameExist :: MonadIO m => Text -> m Bool +doesGameExist tag = liftIO $ filePath tag >>= doesFileExist diff --git a/src/Control/Lens/Extra.hs b/src/Control/Lens/Extra.hs --- a/src/Control/Lens/Extra.hs +++ b/src/Control/Lens/Extra.hs @@ -13,13 +13,14 @@ module Control.Lens.Extra ( -- * Folds - is, isn't, + is, isn't, hasuse, hasn'tuse, -- * Traversals filteredBy, ) where import Control.Lens hiding (isn't) +import Control.Monad.State import Data.Monoid @@ -34,6 +35,18 @@ -- @'isn't' = 'hasn't'@ isn't :: Getting All s a -> s -> Bool isn't = hasn't + +-- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries in the current state. +-- +-- @'hasuse' = 'gets' . 'has'@ +hasuse :: MonadState s m => Getting Any s a -> m Bool +hasuse = gets . has + +-- | Check to see if this 'Fold' or 'Traversal' has no matches in the current state. +-- +-- @'hasn'tuse' = 'gets' . 'hasn't'@ +hasn'tuse :: MonadState s m => Getting All s a -> m Bool +hasn'tuse = gets . hasn't -- | A companion to 'filtered' that, rather than using a predicate, filters on the given lens for -- matches. diff --git a/src/Game/Werewolf.hs b/src/Game/Werewolf.hs --- a/src/Game/Werewolf.hs +++ b/src/Game/Werewolf.hs @@ -8,8 +8,6 @@ Re-exports all of the public modules under /Game.Werewolf/. These are: -* "Game.Werewolf.Command" -* "Game.Werewolf.Engine" * "Game.Werewolf.Game" * "Game.Werewolf.Player" * "Game.Werewolf.Response" @@ -23,8 +21,6 @@ module Werewolf ) where -import Game.Werewolf.Command as Werewolf -import Game.Werewolf.Engine as Werewolf import Game.Werewolf.Game as Werewolf import Game.Werewolf.Player as Werewolf import Game.Werewolf.Response as Werewolf diff --git a/src/Game/Werewolf/Command.hs b/src/Game/Werewolf/Command.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-| -Module : Game.Werewolf.Command -Description : Command data structure. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Command data structures. --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} - -module Game.Werewolf.Command ( - -- * Command - Command(..), - - -- ** Instances - noopCommand, - - -- ** Validation - validatePlayer, -) where - -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.State hiding (state) -import Control.Monad.Writer - -import Data.Text (Text) - -import Game.Werewolf.Game hiding (doesPlayerExist, getPendingVoters, getVoteResult, killPlayer) -import Game.Werewolf.Messages -import Game.Werewolf.Response -import Game.Werewolf.Util - -data Command = Command { apply :: forall m . (MonadError [Message] m, MonadState Game m, MonadWriter [Message] m) => m () } - -noopCommand :: Command -noopCommand = Command $ return () - -validatePlayer :: (MonadError [Message] m, MonadState Game m) => Text -> Text -> m () -validatePlayer callerName name = do - whenM isGameOver $ throwError [gameIsOverMessage callerName] - unlessM (doesPlayerExist name) $ throwError [playerDoesNotExistMessage callerName name] - whenM (isPlayerDead name) $ throwError [if callerName == name then playerIsDeadMessage callerName else targetIsDeadMessage callerName name] diff --git a/src/Game/Werewolf/Command/Global.hs b/src/Game/Werewolf/Command/Global.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Global.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Global -Description : Global commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Global commands. --} - -module Game.Werewolf.Command.Global ( - -- * Commands - bootCommand, quitCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Writer - -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -bootCommand :: Text -> Text -> Command -bootCommand callerName targetName = Command $ do - validatePlayer callerName callerName - validatePlayer callerName targetName - whenM (uses (boots . at targetName) $ elem callerName . fromMaybe []) $ - throwError [playerHasAlreadyVotedToBootMessage callerName targetName] - - boots %= Map.insertWith (++) targetName [callerName] - - tell [playerVotedToBootMessage callerName targetName] - -quitCommand :: Text -> Command -quitCommand callerName = Command $ do - validatePlayer callerName callerName - - caller <- findPlayerBy_ name callerName - - tell [playerQuitMessage caller] - - removePlayer callerName diff --git a/src/Game/Werewolf/Command/Hunter.hs b/src/Game/Werewolf/Command/Hunter.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Hunter.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Hunter -Description : Hunter commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Hunter commands. --} - -module Game.Werewolf.Command.Hunter ( - -- * Commands - chooseCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Writer - -import Data.Text (Text) - -import Game.Werewolf hiding (doesPlayerExist, killPlayer) -import Game.Werewolf.Messages -import Game.Werewolf.Util - -chooseCommand :: Text -> Text -> Command -chooseCommand callerName targetName = Command $ do - whenM isGameOver $ throwError [gameIsOverMessage callerName] - unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] - unlessM (isPlayerHunter callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isHuntersTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - validatePlayer callerName targetName - - target <- findPlayerBy_ name targetName - - tell [playerShotMessage target] - killPlayer targetName - - hunterRetaliated .= True diff --git a/src/Game/Werewolf/Command/Orphan.hs b/src/Game/Werewolf/Command/Orphan.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Orphan.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Orphan -Description : Orphan commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Orphan commands. --} - -module Game.Werewolf.Command.Orphan ( - -- * Commands - chooseCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra - -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -chooseCommand :: Text -> Text -> Command -chooseCommand callerName targetName = Command $ do - validatePlayer callerName callerName - unlessM (isPlayerOrphan callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isOrphansTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - when (callerName == targetName) $ throwError [playerCannotChooseSelfMessage callerName] - validatePlayer callerName targetName - - roleModel .= Just targetName diff --git a/src/Game/Werewolf/Command/Protector.hs b/src/Game/Werewolf/Command/Protector.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Protector.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Protector -Description : Protector commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Protector commands. --} - -module Game.Werewolf.Command.Protector ( - -- * Commands - protectCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.State hiding (state) - -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -protectCommand :: Text -> Text -> Command -protectCommand callerName targetName = Command $ do - validatePlayer callerName callerName - unlessM (isPlayerProtector callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isProtectorsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - validatePlayer callerName targetName - whenM (has (priorProtect . traverse . only targetName) <$> get) $ throwError [playerCannotProtectSamePlayerTwiceInARowMessage callerName] - - priorProtect .= Just targetName - protect .= Just targetName diff --git a/src/Game/Werewolf/Command/Scapegoat.hs b/src/Game/Werewolf/Command/Scapegoat.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Scapegoat.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Scapegoat -Description : Scapegoat commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Scapegoat commands. --} - -module Game.Werewolf.Command.Scapegoat ( - -- * Commands - chooseCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra - -import Data.Text (Text) - -import Game.Werewolf hiding (doesPlayerExist) -import Game.Werewolf.Messages -import Game.Werewolf.Util - -chooseCommand :: Text -> [Text] -> Command -chooseCommand callerName targetNames = Command $ do - whenM isGameOver $ throwError [gameIsOverMessage callerName] - unlessM (doesPlayerExist callerName) $ throwError [playerDoesNotExistMessage callerName callerName] - unlessM (isPlayerScapegoat callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isScapegoatsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - when (null targetNames) $ throwError [playerMustChooseAtLeastOneTargetMessage callerName] - when (callerName `elem` targetNames) $ throwError [playerCannotChooseSelfMessage callerName] - forM_ targetNames $ validatePlayer callerName - whenM (use jesterRevealed &&^ anyM isPlayerJester targetNames) $ - throwError [playerCannotChooseJesterMessage callerName] - - allowedVoters .= targetNames - scapegoatBlamed .= False diff --git a/src/Game/Werewolf/Command/Seer.hs b/src/Game/Werewolf/Command/Seer.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Seer.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Seer -Description : Seer commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Seer commands. --} - -module Game.Werewolf.Command.Seer ( - -- * Commands - seeCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra - -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -seeCommand :: Text -> Text -> Command -seeCommand callerName targetName = Command $ do - validatePlayer callerName callerName - unlessM (isPlayerSeer callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isSeersTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - validatePlayer callerName targetName - - see .= Just targetName diff --git a/src/Game/Werewolf/Command/Status.hs b/src/Game/Werewolf/Command/Status.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Status.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Status -Description : Status commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Status commands. --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Game.Werewolf.Command.Status ( - -- * Commands - circleCommand, pingCommand, statusCommand, -) where - -import Control.Lens -import Control.Monad.Extra -import Control.Monad.State hiding (state) -import Control.Monad.Writer - -import Data.List -import Data.Text (Text) - -import Game.Werewolf hiding (doesPlayerExist, getPendingVoters) -import Game.Werewolf.Messages -import qualified Game.Werewolf.Role as Role -import Game.Werewolf.Util - -circleCommand :: Text -> Bool -> Command -circleCommand callerName includeDead = Command $ do - players' <- toListOf (players . traverse . if includeDead then id else alive) <$> get - - tell [circleMessage callerName players'] - -pingCommand :: Text -> Command -pingCommand callerName = Command $ use stage >>= \stage' -> case stage' of - FerinasGrunt -> return () - GameOver -> tell [gameIsOverMessage callerName] - HuntersTurn1 -> pingRole hunterRole - HuntersTurn2 -> pingRole hunterRole - Lynching -> return () - OrphansTurn -> pingRole orphanRole - ProtectorsTurn -> pingRole protectorRole - ScapegoatsTurn -> pingRole scapegoatRole - SeersTurn -> pingRole seerRole - Sunrise -> return () - Sunset -> return () - VillageDrunksTurn -> pingRole villageDrunkRole - VillagesTurn -> pingVillagers - WerewolvesTurn -> pingWerewolves - WitchsTurn -> pingRole witchRole - -pingRole :: (MonadState Game m, MonadWriter [Message] m) => Role -> m () -pingRole role' = do - player <- findPlayerBy_ role role' - - tell [pingRoleMessage $ role' ^. Role.name] - tell [pingPlayerMessage $ player ^. name] - -pingVillagers :: (MonadState Game m, MonadWriter [Message] m) => m () -pingVillagers = do - allowedVoterNames <- use allowedVoters - pendingVoterNames <- toListOf names <$> getPendingVoters - - tell [waitingOnMessage Nothing $ allowedVoterNames `intersect` pendingVoterNames] - tell $ map pingPlayerMessage (allowedVoterNames `intersect` pendingVoterNames) - -pingWerewolves :: (MonadState Game m, MonadWriter [Message] m) => m () -pingWerewolves = do - pendingVoters <- getPendingVoters - - tell [pingRoleMessage "Werewolves"] - tell $ map pingPlayerMessage (pendingVoters ^.. werewolves . name) - -statusCommand :: Text -> Command -statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of - FerinasGrunt -> return () - GameOver -> tell [gameIsOverMessage callerName] - Lynching -> return () - Sunrise -> return () - Sunset -> return () - VillagesTurn -> do - allowedVoterNames <- use allowedVoters - pendingVoterNames <- toListOf names <$> getPendingVoters - - tell . standardStatusMessages stage' =<< use players - tell [waitingOnMessage (Just callerName) (allowedVoterNames `intersect` pendingVoterNames)] - WerewolvesTurn -> do - pendingVoterNames <- toListOf (werewolves . name) <$> getPendingVoters - - tell . standardStatusMessages stage' =<< use players - whenM (doesPlayerExist callerName &&^ isPlayerWerewolf callerName) $ - tell [waitingOnMessage (Just callerName) pendingVoterNames] - _ -> tell . standardStatusMessages stage' =<< use players - where - standardStatusMessages stage players = - currentStageMessages callerName stage ++ - [ rolesInGameMessage (Just callerName) (players ^.. roles) - , playersInGameMessage callerName players - ] diff --git a/src/Game/Werewolf/Command/Villager.hs b/src/Game/Werewolf/Command/Villager.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Villager.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Villager -Description : Villager commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Villager commands. --} - -module Game.Werewolf.Command.Villager ( - -- * Commands - voteCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Writer - -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -voteCommand :: Text -> Text -> Command -voteCommand callerName targetName = Command $ do - validatePlayer callerName callerName - whenM (uses allowedVoters (callerName `notElem`)) $ throwError [playerCannotDoThatMessage callerName] - unlessM isVillagesTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - whenM (isJust <$> getPlayerVote callerName) $ throwError [playerHasAlreadyVotedMessage callerName] - validatePlayer callerName targetName - - votes %= Map.insert callerName targetName - - whenJustM (preuse $ players . crookedSenators . alive) $ \crookedSenator -> - tell [playerMadeLynchVoteMessage (Just $ crookedSenator ^. name) callerName targetName] diff --git a/src/Game/Werewolf/Command/Werewolf.hs b/src/Game/Werewolf/Command/Werewolf.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Werewolf.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Werewolf -Description : Werewolf commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Werewolf commands. --} - -module Game.Werewolf.Command.Werewolf ( - -- * Commands - voteCommand, - - -- ** Validation - validatePlayer, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.State hiding (state) -import Control.Monad.Writer - -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -voteCommand :: Text -> Text -> Command -voteCommand callerName targetName = Command $ do - validatePlayer callerName callerName - unlessM (isPlayerWerewolf callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isWerewolvesTurn $ throwError [playerCannotDoThatRightNowMessage callerName] - whenM (isJust <$> getPlayerVote callerName) $ throwError [playerHasAlreadyVotedMessage callerName] - validatePlayer callerName targetName - whenM (isPlayerWerewolf targetName) $ throwError [playerCannotDevourAnotherWerewolfMessage callerName] - - votes %= Map.insert callerName targetName - - aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get - - tell [playerMadeDevourVoteMessage werewolfName callerName targetName | werewolfName <- aliveWerewolfNames \\ [callerName]] diff --git a/src/Game/Werewolf/Command/Witch.hs b/src/Game/Werewolf/Command/Witch.hs deleted file mode 100644 --- a/src/Game/Werewolf/Command/Witch.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-| -Module : Game.Werewolf.Command.Witch -Description : Witch commands. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Witch commands. --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Game.Werewolf.Command.Witch ( - -- * Commands - healCommand, passCommand, poisonCommand, -) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.State hiding (state) - -import Data.Text (Text) - -import Game.Werewolf -import Game.Werewolf.Messages -import Game.Werewolf.Util - -healCommand :: Text -> Command -healCommand callerName = Command $ do - validateCommand callerName - whenM (use healUsed) $ throwError [playerHasAlreadyHealedMessage callerName] - whenM (hasn't (events . traverse . _DevourEvent) <$> get) $ throwError [playerCannotDoThatRightNowMessage callerName] - - heal .= True - healUsed .= True - -passCommand :: Text -> Command -passCommand callerName = Command $ do - validateCommand callerName - - passed .= True - -poisonCommand :: Text -> Text -> Command -poisonCommand callerName targetName = Command $ do - validateCommand callerName - whenM (use poisonUsed) $ throwError [playerHasAlreadyPoisonedMessage callerName] - validatePlayer callerName targetName - whenM (has (events . traverse . _DevourEvent . only targetName) <$> get) $ throwError [playerCannotDoThatMessage callerName] - - poison .= Just targetName - poisonUsed .= True - -validateCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m () -validateCommand callerName = do - validatePlayer callerName callerName - unlessM (isPlayerWitch callerName) $ throwError [playerCannotDoThatMessage callerName] - unlessM isWitchsTurn $ throwError [playerCannotDoThatRightNowMessage callerName] diff --git a/src/Game/Werewolf/Engine.hs b/src/Game/Werewolf/Engine.hs deleted file mode 100644 --- a/src/Game/Werewolf/Engine.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-| -Module : Game.Werewolf.Engine -Description : Engine functions. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Engine functions. --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Game.Werewolf.Engine ( - -- * Loop - checkStage, checkGameOver, - - -- * Game - startGame, -) where - -import Control.Lens hiding (cons, isn't) -import Control.Lens.Extra -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Random -import Control.Monad.State -import Control.Monad.Writer - -import Data.List.Extra -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T - -import Game.Werewolf.Game hiding (doesPlayerExist, getAllowedVoters, getPendingVoters, - getVoteResult, hasAnyoneWon, hasFallenAngelWon, - hasVillagersWon, hasWerewolvesWon, killPlayer) -import Game.Werewolf.Messages -import Game.Werewolf.Player -import Game.Werewolf.Response -import Game.Werewolf.Role hiding (name) -import qualified Game.Werewolf.Role as Role -import Game.Werewolf.Util - -import Prelude hiding (round) - -checkStage :: (MonadRandom m, MonadState Game m, MonadWriter [Message] m) => m () -checkStage = do - game <- get - checkBoots >> checkStage' >> checkEvents - game' <- get - - when (game /= game') checkStage - -checkBoots :: (MonadState Game m, MonadWriter [Message] m) => m () -checkBoots = do - alivePlayerCount <- length . toListOf (players . traverse . alive) <$> get - - booteeNames <- uses boots $ Map.keys . Map.filter (\voters -> length voters > alivePlayerCount `div` 2) - bootees <- mapM (findPlayerBy_ name) booteeNames - - forM_ (filter (is alive) bootees) $ \bootee -> do - tell [playerBootedMessage bootee] - - removePlayer (bootee ^. name) - -checkStage' :: (MonadRandom m, MonadState Game m, MonadWriter [Message] m) => m () -checkStage' = use stage >>= \stage' -> case stage' of - FerinasGrunt -> do - druid <- findPlayerBy_ role druidRole - players' <- filter (isn't alphaWolf) <$> getAdjacentAlivePlayers (druid ^. name) - - when (has werewolves players' || has lycans players') $ tell [ferinaGruntsMessage] - - advanceStage - - GameOver -> return () - - HuntersTurn1 -> whenM (use hunterRetaliated) advanceStage - - HuntersTurn2 -> whenM (use hunterRetaliated) advanceStage - - Lynching -> do - getVoteResult >>= lynchVotees - - allVoters <- ifM (use jesterRevealed) - (uses players $ filter (isn't jester)) - (use players) - allowedVoters .= allVoters ^.. traverse . alive . name - - votes .= Map.empty - - advanceStage - - OrphansTurn -> do - whenM (has (players . orphans . dead) <$> get) advanceStage - - whenM (isJust <$> use roleModel) advanceStage - - ProtectorsTurn -> do - whenM (has (players . protectors . dead) <$> get) advanceStage - - whenM (isJust <$> use protect) advanceStage - - ScapegoatsTurn -> unlessM (use scapegoatBlamed) $ do - allowedVoters' <- use allowedVoters - tell [scapegoatChoseAllowedVotersMessage allowedVoters'] - - advanceStage - - SeersTurn -> do - whenM (has (players . seers . dead) <$> get) advanceStage - - whenM (isJust <$> use see) advanceStage - - Sunrise -> do - round += 1 - - whenJustM (preuse $ players . fallenAngels . alive) $ \fallenAngel -> - unless (is villager fallenAngel) $ do - tell [fallenAngelJoinedVillagersMessage] - - setPlayerAllegiance (fallenAngel ^. name) Villagers - - whenJustM (preuse $ players . seers . alive) $ \seer -> do - target <- use see >>= findPlayerBy_ name . fromJust - - when (is alive target) $ tell [playerSeenMessage (seer ^. name) target] - - see .= Nothing - - advanceStage - - Sunset -> do - whenJustM (use roleModel) $ \roleModelsName -> do - orphan <- findPlayerBy_ role orphanRole - - whenM (isPlayerDead roleModelsName &&^ return (is alive orphan) &&^ return (is villager orphan)) $ do - aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get - - setPlayerAllegiance (orphan ^. name) Werewolves - - tell $ orphanJoinedPackMessages (orphan ^. name) aliveWerewolfNames - - advanceStage - - VillageDrunksTurn -> do - aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get - - randomAllegiance <- getRandomAllegiance - players . villageDrunks . role . allegiance .= randomAllegiance - - villageDrunk <- findPlayerBy_ role villageDrunkRole - - if is villager villageDrunk - then tell [villageDrunkJoinedVillageMessage $ villageDrunk ^. name] - else tell $ villageDrunkJoinedPackMessages (villageDrunk ^. name) aliveWerewolfNames - - advanceStage - - VillagesTurn -> whenM (null <$> liftM2 intersect getAllowedVoters getPendingVoters) $ do - tell . map (uncurry $ playerMadeLynchVoteMessage Nothing) =<< uses votes Map.toList - - advanceStage - - WerewolvesTurn -> whenM (none (is werewolf) <$> getPendingVoters) $ do - getVoteResult >>= devourVotees - - protect .= Nothing - votes .= Map.empty - - advanceStage - - WitchsTurn -> do - whenM (has (players . witches . dead) <$> get) advanceStage - - whenJustM (use poison) $ \targetName -> do - events %= (++ [PoisonEvent targetName]) - poison .= Nothing - - whenM (use heal) $ do - devourEvent <- fromJust <$> preuse (events . traverse . filtered (is _DevourEvent)) - - events %= cons NoDevourEvent . delete devourEvent - heal .= False - - whenM (use healUsed &&^ use poisonUsed) advanceStage - whenM (use passed) advanceStage - -lynchVotees :: (MonadState Game m, MonadWriter [Message] m) => [Player] -> m () -lynchVotees [votee] - | is jester votee = do - jesterRevealed .= True - - tell [jesterLynchedMessage $ votee ^. name] - | otherwise = do - killPlayer (votee ^. name) - tell [playerLynchedMessage votee] -lynchVotees _ = preuse (players . scapegoats . alive) >>= \mScapegoat -> case mScapegoat of - Just scapegoat -> do - scapegoatBlamed .= True - - killPlayer (scapegoat ^. name) - tell [scapegoatLynchedMessage (scapegoat ^. name)] - _ -> tell [noPlayerLynchedMessage] - -devourVotees :: (MonadState Game m, MonadWriter [Message] m) => [Player] -> m () -devourVotees [votee] = ifM (uses protect $ maybe False (== votee ^. name)) - (events %= cons NoDevourEvent) - (events %= cons (DevourEvent $ votee ^. name)) -devourVotees _ = events %= cons NoDevourEvent - -advanceStage :: (MonadState Game m, MonadWriter [Message] m) => m () -advanceStage = do - game <- get - nextStage <- ifM hasAnyoneWon - (return GameOver) - (return . head $ filter (stageAvailable game) (drop1 $ dropWhile (game ^. stage /=) stageCycle)) - - stage .= nextStage - boots .= Map.empty - passed .= False - - tell . stageMessages =<< get - -checkEvents :: (MonadState Game m, MonadWriter [Message] m) => m () -checkEvents = do - (available, pending) <- use events >>= partitionM eventAvailable - - events .= pending - - mapM_ applyEvent available - -eventAvailable :: MonadState Game m => Event -> m Bool -eventAvailable (DevourEvent _) = isSunrise -eventAvailable NoDevourEvent = isSunrise -eventAvailable (PoisonEvent _) = isSunrise - -applyEvent :: (MonadState Game m, MonadWriter [Message] m) => Event -> m () -applyEvent (DevourEvent targetName) = do - target <- findPlayerBy_ name targetName - - killPlayer targetName - tell [playerDevouredMessage target] -applyEvent NoDevourEvent = tell [noPlayerDevouredMessage] -applyEvent (PoisonEvent targetName) = do - target <- findPlayerBy_ name targetName - - killPlayer targetName - tell [playerPoisonedMessage target] - -checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () -checkGameOver = whenM hasAnyoneWon $ stage .= GameOver >> get >>= tell . gameOverMessages - -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."] - forM_ restrictedRoles $ \role' -> - when (length (players ^.. traverse . filteredBy role role') > 1) $ - throwError [privateMessage callerName $ T.concat ["Cannot have more than 1 ", role' ^. Role.name, "."]] - - let game = newGame players - - tell $ newGameMessages game - - return game - where - playerNames = players ^.. names diff --git a/src/Game/Werewolf/Game.hs b/src/Game/Werewolf/Game.hs --- a/src/Game/Werewolf/Game.hs +++ b/src/Game/Werewolf/Game.hs @@ -1,48 +1,45 @@ {-| Module : Game.Werewolf.Game -Description : Game data structure with functions for manipulating and querying the game state. +Description : Simplistic game data structure with lenses. Copyright : (c) Henry J. Wylde, 2016 License : BSD3 Maintainer : public@hjwylde.com A game is not quite as simple as players! Roughly speaking though, this engine is /stateful/. The -game state only changes when a /command/ is issued (see "Game.Werewolf.Command"). Thus, this module -defines the 'Game' data structure and any fields required to keep track of the current state. - -It also has a few additional functions for manipulating and querying the game state. +game state only changes when a /command/ is issued. Thus, this module defines the 'Game' data +structure and any fields required to keep track of the current state. -} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} module Game.Werewolf.Game ( -- * Game Game, - stage, round, players, events, boots, allowedVoters, heal, healUsed, hunterRetaliated, - jesterRevealed, passed, poison, poisonUsed, priorProtect, protect, roleModel, scapegoatBlamed, - see, votes, + stage, round, players, boots, allowedVoters, divine, fallenAngelLynched, healUsed, + hunterRetaliated, jesterRevealed, passed, poison, poisonUsed, priorProtect, protect, roleModel, + scapegoatBlamed, see, votes, Stage(..), - _FerinasGrunt, _GameOver, _HuntersTurn1, _HuntersTurn2, _Lynching, _OrphansTurn, + _FerinasGrunt, _GameOver, _HuntersTurn1, _HuntersTurn2, _Lynching, _OraclesTurn, _OrphansTurn, _ProtectorsTurn, _ScapegoatsTurn, _SeersTurn, _Sunrise, _Sunset, _VillageDrunksTurn, _VillagesTurn, _WerewolvesTurn, _WitchsTurn, allStages, stageCycle, stageAvailable, - Event(..), - _DevourEvent, _NoDevourEvent, _PoisonEvent, - newGame, - -- ** Manipulations - killPlayer, + -- ** Getters + votee, + -- ** Prisms + firstRound, secondRound, thirdRound, + -- ** Searches - getAllowedVoters, getPendingVoters, getVoteResult, + getAllowedVoters, getPendingVoters, -- ** Queries - isFirstRound, isThirdRound, - doesPlayerExist, hasAnyoneWon, hasFallenAngelWon, hasVillagersWon, hasWerewolvesWon, ) where @@ -64,56 +61,43 @@ -- | There are a few key pieces of information that a game always needs to hold. These are: -- -- * the 'stage', --- * the 'round' number, --- * the 'players' and --- * the 'events'. +-- * the 'round' number and +-- * the 'players'. -- -- Any further fields on the game are specific to one or more roles (and their respective turns!). -- Some of the additional fields are reset each round (e.g., the Seer's 'see') while others are -- kept around for the whole game (e.g., the Orphan's 'roleModel'). --- --- In order to advance a game's 'state', a 'Game.Werewolf.Command.Command' from a user needs to be --- received. Afterwards the following steps should be performed: --- --- 1. 'Game.Werewolf.Command.apply' the 'Game.Werewolf.Command.Command'. --- 2. run 'Game.Werewolf.Engine.checkStage'. --- 3. run 'Game.Werewolf.Engine.checkGameOver'. --- --- 'Game.Werewolf.Engine.checkStage' will perform any additional checks and manipulations to the --- game state before advancing the game's 'stage'. It also runs any relevant 'events'. --- 'Game.Werewolf.Engine.checkGameOver' will check to see if any of the win conditions are met and --- if so, advance the game's 'stage' to 'GameOver'. data Game = Game - { _stage :: Stage - , _round :: Int - , _players :: [Player] - , _events :: [Event] - , _boots :: Map Text [Text] - , _allowedVoters :: [Text] -- ^ Scapegoat - , _heal :: Bool -- ^ Witch - , _healUsed :: Bool -- ^ Witch - , _hunterRetaliated :: Bool -- ^ Hunter - , _jesterRevealed :: Bool -- ^ Jester - , _passed :: Bool -- ^ Witch - , _poison :: Maybe Text -- ^ Witch - , _poisonUsed :: Bool -- ^ Witch - , _priorProtect :: Maybe Text -- ^ Protector - , _protect :: Maybe Text -- ^ Protector - , _roleModel :: Maybe Text -- ^ Orphan - , _scapegoatBlamed :: Bool -- ^ Scapegoat - , _see :: Maybe Text -- ^ Seer - , _votes :: Map Text Text -- ^ Villagers and Werewolves + { _stage :: Stage + , _round :: Int + , _players :: [Player] + , _boots :: Map Text [Text] + , _allowedVoters :: [Text] -- ^ Jester, Scapegoat + , _divine :: Maybe Text -- ^ Oracle + , _fallenAngelLynched :: Bool -- ^ Fallen Angel + , _healUsed :: Bool -- ^ Witch + , _hunterRetaliated :: Bool -- ^ Hunter + , _jesterRevealed :: Bool -- ^ Jester + , _passed :: Bool -- ^ Witch + , _poison :: Maybe Text -- ^ Witch + , _poisonUsed :: Bool -- ^ Witch + , _priorProtect :: Maybe Text -- ^ Protector + , _protect :: Maybe Text -- ^ Protector + , _roleModel :: Maybe Text -- ^ Orphan + , _scapegoatBlamed :: Bool -- ^ Scapegoat + , _see :: Maybe Text -- ^ Seer + , _votes :: Map Text Text -- ^ Villagers and Werewolves } deriving (Eq, Read, Show) --- | Most of these are fairly self-sufficient (the turn stages). 'Sunrise' and 'Sunset' are provided --- as meaningful breaks between the day and night as, for example, a 'VillagesTurn' may not always --- be available (curse that retched Scapegoat). +-- | Most of these are fairly self-explainable (the turn stages). 'Sunrise' and 'Sunset' are +-- provided as meaningful breaks between the day and night as, for example, a 'VillagesTurn' may +-- not always be available (curse that retched Scapegoat). -- --- Once the game reaches a turn stage, it requires a 'Game.Werewolf.Command.Command' to help push --- it past. Often only certain roles and commands may be performed at any given stage. -data Stage = FerinasGrunt | GameOver | HuntersTurn1 | HuntersTurn2 | Lynching | OrphansTurn - | ProtectorsTurn | ScapegoatsTurn | SeersTurn | Sunrise | Sunset | VillageDrunksTurn - | VillagesTurn | WerewolvesTurn | WitchsTurn +-- Once the game reaches a turn stage, it requires a /command/ to help push it past. Often only +-- certain roles and commands may be performed at any given stage. +data Stage = FerinasGrunt | GameOver | HuntersTurn1 | HuntersTurn2 | Lynching | OraclesTurn + | OrphansTurn | ProtectorsTurn | ScapegoatsTurn | SeersTurn | Sunrise | Sunset + | VillageDrunksTurn | VillagesTurn | WerewolvesTurn | WitchsTurn deriving (Eq, Read, Show) instance Humanise Stage where @@ -122,6 +106,7 @@ humanise HuntersTurn1 = fromString "Hunter's turn" humanise HuntersTurn2 = fromString "Hunter's turn" humanise Lynching = fromString "Lynching" + humanise OraclesTurn = fromString "Oracle's turn" humanise OrphansTurn = fromString "Orphan's turn" humanise ProtectorsTurn = fromString "Protector's turn" humanise ScapegoatsTurn = fromString "Scapegoat's turn" @@ -133,42 +118,28 @@ humanise WerewolvesTurn = fromString "Werewolves' turn" humanise WitchsTurn = fromString "Witch's turn" --- TODO (hjw): remove events --- | Events occur /after/ a 'Stage' is advanced. This is automatically handled in --- 'Game.Werewolf.Engine.checkStage', while an event's specific behaviour is defined by --- 'Game.Werewolf.Engine.eventAvailable' and 'Game.Werewolf.Engine.applyEvent'. --- --- For the most part events are used to allow something to happen on a 'Stage' different to when --- it was triggered. E.g., the 'DeovurEvent' occurs after the village wakes up rather than when --- the Werewolves' vote, this gives the Witch a chance to heal the victim. -data Event = DevourEvent Text -- ^ Werewolves - | NoDevourEvent -- ^ Protector, Werewolves and Witch - | PoisonEvent Text -- ^ Witch - deriving (Eq, Read, Show) - makeLenses ''Game makePrisms ''Stage -makePrisms ''Event - -- | All of the 'Stage's in the order that they should occur. allStages :: [Stage] allStages = - [ VillagesTurn - , Lynching - , HuntersTurn1 - , ScapegoatsTurn - , Sunset + [ Sunset , OrphansTurn , VillageDrunksTurn , SeersTurn + , OraclesTurn , ProtectorsTurn , WerewolvesTurn , WitchsTurn , Sunrise , HuntersTurn2 , FerinasGrunt + , VillagesTurn + , Lynching + , HuntersTurn1 + , ScapegoatsTurn , GameOver ] @@ -191,6 +162,10 @@ has (players . hunters . dead) game && not (game ^. hunterRetaliated) stageAvailable game Lynching = Map.size (game ^. votes) > 0 +stageAvailable game OraclesTurn = has (players . oracles . alive) game +stageAvailable game OrphansTurn = + has (players . orphans . alive) game + && isNothing (game ^. roleModel) stageAvailable game ProtectorsTurn = has (players . protectors . alive) game stageAvailable game ScapegoatsTurn = game ^. scapegoatBlamed stageAvailable game SeersTurn = has (players . seers . alive) game @@ -198,103 +173,92 @@ stageAvailable _ Sunset = True stageAvailable game VillageDrunksTurn = has (players . villageDrunks . alive) game - && isThirdRound game -stageAvailable game VillagesTurn = - (has (players . fallenAngels . alive) game || not (isFirstRound game)) - && any (is alive) (getAllowedVoters game) + && is thirdRound game +stageAvailable game VillagesTurn = any (is alive) (getAllowedVoters game) stageAvailable game WerewolvesTurn = has (players . werewolves . alive) game -stageAvailable game OrphansTurn = - has (players . orphans . alive) game - && isNothing (game ^. roleModel) stageAvailable game WitchsTurn = has (players . witches . alive) game && (not (game ^. healUsed) || not (game ^. poisonUsed)) -- | Creates a new 'Game' with the given players. No validations are performed here, those are left --- to 'Game.Werewolf.Engine.startGame'. +-- to the binary. newGame :: [Player] -> Game -newGame players = game & stage .~ head (filter (stageAvailable game) stageCycle) - where - game = Game - { _stage = Sunset - , _round = 0 - , _players = players - , _events = [] - , _boots = Map.empty - , _passed = False - , _allowedVoters = players ^.. names - , _heal = False - , _healUsed = False - , _hunterRetaliated = False - , _jesterRevealed = False - , _poison = Nothing - , _poisonUsed = False - , _priorProtect = Nothing - , _protect = Nothing - , _roleModel = Nothing - , _scapegoatBlamed = False - , _see = Nothing - , _votes = Map.empty - } - --- | Kills the given player! This function should be used carefully as it doesn't clear any state --- that the player's role may use. If you're after just removing a player from a game for a test, --- try using a 'Game.Werewolf.Command.quitCommand' instead. -killPlayer :: Text -> Game -> Game -killPlayer name' = players . traverse . filteredBy name name' . state .~ Dead - --- | Gets all the 'allowedVoters' in a game (which is names only) and maps them to their player. -getAllowedVoters :: Game -> [Player] -getAllowedVoters game = - map (\name' -> game ^?! players . traverse . filteredBy name name') (game ^. allowedVoters) +newGame players = Game + { _stage = head stageCycle + , _round = 0 + , _players = players + , _boots = Map.empty + , _passed = False + , _allowedVoters = players ^.. names + , _divine = Nothing + , _fallenAngelLynched = False + , _healUsed = False + , _hunterRetaliated = False + , _jesterRevealed = False + , _poison = Nothing + , _poisonUsed = False + , _priorProtect = Nothing + , _protect = Nothing + , _roleModel = Nothing + , _scapegoatBlamed = False + , _see = Nothing + , _votes = Map.empty + } --- | Gets all 'Alive' players that have yet to vote. -getPendingVoters :: Game -> [Player] -getPendingVoters game = - game ^.. players . traverse . alive . filtered ((`Map.notMember` votes') . view name) - where - votes' = game ^. votes +-- | The traversal of the 'votes' victim. This is the player, if they exist, that received the +-- majority of the votes. +votee :: Fold Game Player +votee = folding $ (\players -> if length players == 1 then take 1 players else []) . getVoteResult -- | Gets all players that had /the/ highest vote count. This could be 1 or more players depending -- on whether the votes were in conflict. getVoteResult :: Game -> [Player] getVoteResult game | Map.null (game ^. votes) = [] - | otherwise = map (\name' -> game ^?! players . traverse . filteredBy name name') result + | otherwise = game ^.. players . traverse . filtered ((`elem` result) . view name) where votees = Map.elems $ game ^. votes result = last $ groupSortOn (length . (`elemIndices` votees)) (nub votees) --- | @'isFirstRound' game = game ^. 'round' == 0@ -isFirstRound :: Game -> Bool -isFirstRound game = game ^. round == 0 +-- | The traversal of 'Game's on the first round. +firstRound :: Prism' Game Game +firstRound = prism (set round 0) $ \game -> (if game ^. round == 0 then Right else Left) game --- | @'isThirdRound' game = game ^. 'round' == 2@ -isThirdRound :: Game -> Bool -isThirdRound game = game ^. round == 2 +-- | The traversal of 'Game's on the second round. +secondRound :: Prism' Game Game +secondRound = prism (set round 1) $ \game -> (if game ^. round == 1 then Right else Left) game --- | Queries whether the player is in the game. -doesPlayerExist :: Text -> Game -> Bool -doesPlayerExist name = has $ players . names . only name +-- | The traversal of 'Game's on the third round. +thirdRound :: Prism' Game Game +thirdRound = prism (set round 2) $ \game -> (if game ^. round == 2 then Right else Left) game +-- | Gets all the 'allowedVoters' in a game (which is names only) and maps them to their player. +getAllowedVoters :: Game -> [Player] +getAllowedVoters game = + map (\name -> game ^?! players . traverse . named name) (game ^. allowedVoters) + +-- | Gets all 'Alive' players that have yet to vote. +getPendingVoters :: Game -> [Player] +getPendingVoters game = + game ^.. players . traverse . alive . filtered ((`Map.notMember` votes') . view name) + where + votes' = game ^. votes + -- | Queries whether anyone has won. hasAnyoneWon :: Game -> Bool hasAnyoneWon game = any ($ game) [hasFallenAngelWon, hasVillagersWon, hasWerewolvesWon] -- | Queries whether the Fallen Angel has won. The Fallen Angel wins if they manage to get --- themselves killed on the first round. --- --- N.B., we check that the Fallen Angel isn't a 'villager' as the Fallen Angel's role is altered --- if they don't win. +-- themselves lynched by the Villagers. hasFallenAngelWon :: Game -> Bool -hasFallenAngelWon game = has (players . fallenAngels) game && is dead fallenAngel && isn't villager fallenAngel - where - fallenAngel = game ^?! players . fallenAngels +hasFallenAngelWon game = game ^. fallenAngelLynched -- | Queries whether the 'Villagers' have won. The 'Villagers' win if they are the only players -- surviving. +-- +-- N.B., the Fallen Angel is not considered when determining whether the 'Villagers' have won. hasVillagersWon :: Game -> Bool -hasVillagersWon = allOf (players . traverse . alive) (is villager) +hasVillagersWon = allOf (players . traverse . alive) (\player -> is villager player || is fallenAngel player) -- | Queries whether the 'Werewolves' have won. The 'Werewolves' win if they are the only players -- surviving. diff --git a/src/Game/Werewolf/Messages.hs b/src/Game/Werewolf/Messages.hs deleted file mode 100644 --- a/src/Game/Werewolf/Messages.hs +++ /dev/null @@ -1,621 +0,0 @@ -{-| -Module : Game.Werewolf.Messages -Description : Suite of messages used throughout the game. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -A 'Message' is used to relay information back to either all players or a single player. This module -defines suite of messages used throughout the werewolf game, including both game play messages and -binary errors. - -@werewolf@ was designed to be ambivalent to the playing chat client. The response-message structure -reflects this by staying away from anything that could be construed as client-specific. This -includes features such as emoji support. --} - -{-# LANGUAGE OverloadedStrings #-} - -module Game.Werewolf.Messages ( - -- * Generic messages - newGameMessages, stageMessages, gameOverMessages, playerQuitMessage, gameIsOverMessage, - - -- ** Error messages - playerDoesNotExistMessage, playerCannotDoThatMessage, playerCannotDoThatRightNowMessage, - playerIsDeadMessage, targetIsDeadMessage, - - -- * Boot messages - playerVotedToBootMessage, playerBootedMessage, - - -- ** Error messages - playerHasAlreadyVotedToBootMessage, - - -- * Circle messages - circleMessage, - - -- * Ping messages - pingPlayerMessage, pingRoleMessage, - - -- * Status messages - currentStageMessages, rolesInGameMessage, playersInGameMessage, waitingOnMessage, - - -- * Druid's turn messages - ferinaGruntsMessage, - - -- * Fallen Angel's turn messages - fallenAngelJoinedVillagersMessage, - - -- * Hunter's turn messages - playerShotMessage, - - -- * Orphan's turn messages - orphanJoinedPackMessages, - - -- * Protector's turn messages - - -- ** Error messages - playerCannotProtectSamePlayerTwiceInARowMessage, - - -- * Scapegoat's turn messages - scapegoatChoseAllowedVotersMessage, - - -- ** Error messages - playerMustChooseAtLeastOneTargetMessage, playerCannotChooseJesterMessage, - - -- * Seer's turn messages - playerSeenMessage, - - -- * Village Drunk's turn messages - villageDrunkJoinedVillageMessage, villageDrunkJoinedPackMessages, - - -- * Villages' turn messages - playerMadeLynchVoteMessage, playerLynchedMessage, noPlayerLynchedMessage, - jesterLynchedMessage, scapegoatLynchedMessage, - - -- ** Error messages - playerHasAlreadyVotedMessage, - - -- * Werewolves' turn messages - playerMadeDevourVoteMessage, playerDevouredMessage, noPlayerDevouredMessage, - - -- ** Error messages - playerCannotDevourAnotherWerewolfMessage, - - -- ** Error messages - playerCannotChooseSelfMessage, - - -- * Witch's turn messages - playerPoisonedMessage, - - -- ** Error messages - playerHasAlreadyHealedMessage, playerHasAlreadyPoisonedMessage, -) where - -import Control.Arrow -import Control.Lens -import Control.Lens.Extra - -import Data.List.Extra -import Data.String.Humanise -import Data.Text (Text) -import qualified Data.Text as T - -import Game.Werewolf.Game -import Game.Werewolf.Player -import Game.Werewolf.Response -import Game.Werewolf.Role hiding (name) -import qualified Game.Werewolf.Role as Role - -newGameMessages :: Game -> [Message] -newGameMessages game = concat - [ [newPlayersInGameMessage $ players' ^.. names] - , [rolesInGameMessage Nothing $ players' ^.. roles] - , map newPlayerMessage players' - , beholderMessages - , trueVillagerMessages - , stageMessages game - ] - where - players' = game ^. players - beholderMessages = case (,) <$> players' ^? beholders <*> players' ^? seers of - Just (beholder, seer) -> [beholderMessage (beholder ^. name) (seer ^. name)] - _ -> [] - trueVillagerMessages = case players' ^? trueVillagers of - Just trueVillager -> [trueVillagerMessage $ trueVillager ^. name] - _ -> [] - -newPlayersInGameMessage :: [Text] -> Message -newPlayersInGameMessage playerNames = publicMessage $ T.concat - ["A new game of werewolf is starting with ", concatList playerNames, "!"] - -newPlayerMessage :: Player -> Message -newPlayerMessage player = privateMessage (player ^. name) $ T.intercalate "\n" - [ T.concat ["You're ", article playerRole, " ", playerRole ^. Role.name, "."] - , playerRole ^. description - , playerRole ^. rules - ] - where - playerRole = player ^. role - -beholderMessage :: Text -> Text -> Message -beholderMessage to seerName = privateMessage to $ T.concat - [ "The Seer has always been held in high regard among the Villagers. Few are as lucky as you to" - , " know the Seer, ", seerName, ", personally." - ] - -trueVillagerMessage :: Text -> Message -trueVillagerMessage name = publicMessage $ T.unwords - [ "Unguarded advice is seldom given, for advice is a dangerous gift, even from the wise to the" - , "wise, and all courses may run ill. Yet as you feel like you need help, I begrudgingly leave" - , "you with this:", name, "is the True Villager." - ] - -stageMessages :: Game -> [Message] -stageMessages game = case game ^. stage of - FerinasGrunt -> [] - GameOver -> [] - HuntersTurn1 -> huntersTurnMessages huntersName - HuntersTurn2 -> huntersTurnMessages huntersName - Lynching -> [] - OrphansTurn -> orphansTurnMessages orphansName - ProtectorsTurn -> protectorsTurnMessages protectorsName - ScapegoatsTurn -> scapegoatsTurnMessages scapegoatsName - SeersTurn -> seersTurnMessages seersName - Sunrise -> [sunriseMessage] - Sunset -> [nightFallsMessage] - VillageDrunksTurn -> [villageDrunksTurnMessage] - VillagesTurn -> if isFirstRound game - then firstVillagesTurnMessages - else villagesTurnMessages - WerewolvesTurn -> if isFirstRound game - then firstWerewolvesTurnMessages aliveWerewolfNames - else werewolvesTurnMessages aliveWerewolfNames - WitchsTurn -> witchsTurnMessages game - where - players' = game ^. players - huntersName = players' ^?! hunters . name - orphansName = players' ^?! orphans . name - protectorsName = players' ^?! protectors . name - scapegoatsName = players' ^?! scapegoats . name - seersName = players' ^?! seers . name - aliveWerewolfNames = players' ^.. werewolves . alive . name - -huntersTurnMessages :: Text -> [Message] -huntersTurnMessages huntersName = - [ publicMessage $ T.unwords ["Just before", huntersName, "was murdered they let off a shot."] - , privateMessage huntersName "Whom do you `choose` to kill with your last shot?" - ] - -orphansTurnMessages :: Text -> [Message] -orphansTurnMessages to = - [ publicMessage "The Orphan wakes up." - , privateMessage to "Whom do you `choose` to be your role model?" - ] - -protectorsTurnMessages :: Text -> [Message] -protectorsTurnMessages to = - [ publicMessage "The Protector wakes up." - , privateMessage to "Whom would you like to `protect`?" - ] - -scapegoatsTurnMessages :: Text -> [Message] -scapegoatsTurnMessages scapegoatsName = - [ publicMessage "Just before the Scapegoat burns to a complete crisp, they cry out a dying wish." - , publicMessage $ T.concat [scapegoatsName, ", whom do you `choose` to vote on the next day?"] - ] - -seersTurnMessages :: Text -> [Message] -seersTurnMessages to = - [ publicMessage "The Seer wakes up." - , privateMessage to "Whose allegiance would you like to `see`?" - ] - -villageDrunksTurnMessage :: Message -villageDrunksTurnMessage = publicMessage "The Village Drunk sobers up." - -sunriseMessage :: Message -sunriseMessage = publicMessage "The sun rises. Everybody wakes up and opens their eyes..." - -nightFallsMessage :: Message -nightFallsMessage = publicMessage "Night falls, the village is asleep." - -firstVillagesTurnMessages :: [Message] -firstVillagesTurnMessages = fallenAngelInPlayMessage : villagesTurnMessages - where - fallenAngelInPlayMessage = publicMessage $ T.unwords - [ "Alas, again I regrettably yield advice: an angelic menace walks among you. Do not" - , "cast your votes lightly, for they will relish in this opportunity to be free from" - , "their terrible nightmare." - ] - -villagesTurnMessages :: [Message] -villagesTurnMessages = - [ publicMessage "As the village gathers in the square the Town Clerk calls for a vote." - , publicMessage "Whom would you like to `vote` to lynch?" - ] - -firstWerewolvesTurnMessages :: [Text] -> [Message] -firstWerewolvesTurnMessages tos = - [privateMessage to $ packMessage to | length tos > 1, to <- tos] - ++ werewolvesTurnMessages tos - where - packMessage werewolfName = T.unwords - [ "You feel restless, like an old curse is keeping you from sleep. It seems you're not" - , "the only one...", packNames werewolfName - , conjugateToBe (length tos - 1), "also emerging from their" - , tryPlural (length tos - 1) "home" - ] - packNames werewolfName = concatList $ tos \\ [werewolfName] - -werewolvesTurnMessages :: [Text] -> [Message] -werewolvesTurnMessages tos = - publicMessage "The Werewolves wake up, transform and choose a new victim." - : groupMessages tos "Whom would you like to `vote` to devour?" - -witchsTurnMessages :: Game -> [Message] -witchsTurnMessages game = concat - [ [wakeUpMessage] - , devourMessages - , healMessages - , poisonMessages - , [passMessage] - ] - where - witchsName = game ^?! players . witches . name - wakeUpMessage = publicMessage "The Witch wakes up." - passMessage = privateMessage witchsName "Type `pass` to end your turn." - devourMessages = case game ^? events . traverse . _DevourEvent of - Just targetName -> - [ privateMessage witchsName $ - T.unwords ["You see", targetName, "sprawled outside bleeding uncontrollably."] - ] - _ -> [] - healMessages - | game ^. healUsed = [] - | hasn't (events . traverse . _DevourEvent) game = [] - | otherwise = [privateMessage witchsName "Would you like to `heal` them?"] - poisonMessages - | game ^. poisonUsed = [] - | otherwise = [privateMessage witchsName "Would you like to `poison` anyone?"] - -gameOverMessages :: Game -> [Message] -gameOverMessages game - | hasFallenAngelWon game = concat - [ [publicMessage "You should have heeded my warning, for now the Fallen Angel has been set free!"] - , [publicMessage "The game is over! The Fallen Angel has won."] - , [playerRolesMessage] - , [playerWonMessage fallenAngelsName] - , map playerLostMessage (game ^.. players . names \\ [fallenAngelsName]) - ] - | hasVillagersWon game = concat - [ [publicMessage "The game is over! The Villagers have won."] - , [playerRolesMessage] - , playerWonMessages - , playerContributedMessages - , playerLostMessages - ] - | hasWerewolvesWon game = concat - [ [publicMessage "The game is over! The Werewolves have won."] - , [playerRolesMessage] - , playerWonMessages - , playerContributedMessages - , playerLostMessages - ] - | otherwise = undefined - where - playerRolesMessage = publicMessage $ T.concat - [ "As I know you're all wondering who lied to you, here's the role allocations: " - , concatList $ map - (\player -> T.concat [player ^. name, " (", player ^. role . Role.name, ")"]) - (game ^. players) - , "." - ] - - winningAllegiance - | hasVillagersWon game = Villagers - | hasWerewolvesWon game = Werewolves - | otherwise = undefined - - winningPlayers = game ^.. players . traverse . filteredBy (role . allegiance) winningAllegiance - losingPlayers = game ^. players \\ winningPlayers - - playerWonMessages = map playerWonMessage (winningPlayers ^.. traverse . alive . name) - playerContributedMessages = map playerContributedMessage (winningPlayers ^.. traverse . dead . name) - playerLostMessages = map playerLostMessage (losingPlayers ^.. names) - - fallenAngelsName = game ^?! players . fallenAngels . name - -playerWonMessage :: Text -> Message -playerWonMessage to = privateMessage to "Victory! You won!" - -playerContributedMessage :: Text -> Message -playerContributedMessage to = privateMessage to "Your team won, but you died. Congratulations?" - -playerLostMessage :: Text -> Message -playerLostMessage to = privateMessage to "Feck, you lost this time round." - -playerQuitMessage :: Player -> Message -playerQuitMessage player = publicMessage $ T.unwords [playerName, "the", playerRole, "has quit!"] - where - playerName = player ^. name - playerRole = player ^. role . Role.name - -gameIsOverMessage :: Text -> Message -gameIsOverMessage to = privateMessage to "The game is over!" - -playerDoesNotExistMessage :: Text -> Text -> Message -playerDoesNotExistMessage to name = privateMessage to $ T.unwords ["Player", name, "does not exist."] - -playerCannotDoThatMessage :: Text -> Message -playerCannotDoThatMessage to = privateMessage to "You cannot do that!" - -playerCannotDoThatRightNowMessage :: Text -> Message -playerCannotDoThatRightNowMessage to = privateMessage to "You cannot do that right now!" - -playerIsDeadMessage :: Text -> Message -playerIsDeadMessage to = privateMessage to "Sshh, you're meant to be dead!" - -targetIsDeadMessage :: Text -> Text -> Message -targetIsDeadMessage to targetName = privateMessage to $ T.unwords [targetName, "is already dead!"] - -playerVotedToBootMessage :: Text -> Text -> Message -playerVotedToBootMessage playerName targetName = publicMessage $ T.concat - [playerName, " voted to boot ", targetName, "!"] - -playerBootedMessage :: Player -> Message -playerBootedMessage player = publicMessage $ T.unwords - [ playerName, "the", playerRole ^. Role.name - , "has been booted from the game!" - ] - where - playerName = player ^. name - playerRole = player ^. role - -playerHasAlreadyVotedToBootMessage :: Text -> Text -> Message -playerHasAlreadyVotedToBootMessage to targetName = privateMessage to $ T.concat - ["You've already voted to boot ", targetName, "!"] - -circleMessage :: Text -> [Player] -> Message -circleMessage to players = privateMessage to $ T.intercalate "\n" - [ "The players are sitting in the following order:" - , T.intercalate " <-> " (map playerName (players ++ [head players])) - ] - where - playerName player = T.concat [player ^. name, if is dead player then " (dead)" else ""] - -pingPlayerMessage :: Text -> Message -pingPlayerMessage to = privateMessage to "Waiting on you..." - -pingRoleMessage :: Text -> Message -pingRoleMessage roleName = publicMessage $ T.concat ["Waiting on the ", roleName, "..."] - -currentStageMessages :: Text -> Stage -> [Message] -currentStageMessages _ FerinasGrunt = [] -currentStageMessages to GameOver = [gameIsOverMessage to] -currentStageMessages _ Lynching = [] -currentStageMessages _ Sunrise = [] -currentStageMessages _ Sunset = [] -currentStageMessages to turn = [privateMessage to $ T.concat - [ "It's currently the ", humanise turn, "." - ]] - -rolesInGameMessage :: Maybe Text -> [Role] -> Message -rolesInGameMessage mTo roles = Message mTo $ T.concat - [ "The roles in play are " - , concatList $ map (\(role, count) -> - T.concat [role ^. Role.name, " (", T.pack $ show count, ")"]) - roleCounts - , " for a total balance of ", T.pack $ show totalBalance, "." - ] - where - roleCounts = map (head &&& length) (groupSortOn (view Role.name) roles) - totalBalance = sumOf (traverse . balance) roles - -playersInGameMessage :: Text -> [Player] -> Message -playersInGameMessage to players = privateMessage to . T.intercalate "\n" $ - alivePlayersText : [deadPlayersText | any (is dead) players] - where - alivePlayers = players ^.. traverse . alive - deadPlayers = players ^.. traverse . dead - - alivePlayersText = T.concat - [ "The following players are still alive: " - , concatList $ map (\player -> if is trueVillager player then playerNameWithRole player else player ^. name) alivePlayers, "." - ] - deadPlayersText = T.concat - [ "The following players are dead: " - , concatList $ map playerNameWithRole deadPlayers, "." - ] - playerNameWithRole player = T.concat [player ^. name, " (", player ^. role . Role.name, ")"] - -waitingOnMessage :: Maybe Text -> [Text] -> Message -waitingOnMessage mTo playerNames = Message mTo $ T.concat - ["Waiting on ", concatList playerNames, "..."] - -ferinaGruntsMessage :: Message -ferinaGruntsMessage = publicMessage - "Ferina wakes from her slumber, disturbed and on edge. She loudly grunts as she smells danger." - -fallenAngelJoinedVillagersMessage :: Message -fallenAngelJoinedVillagersMessage = publicMessage $ T.unwords - [ "You hear the Fallen Angel wrought with anger off in the distance. They failed to attract the" - , "prejudiced vote of the village to leave this world. Now they are stuck here, doomed forever" - , "to live out a mortal life as a Villager." - ] - -playerShotMessage :: Player -> Message -playerShotMessage target = publicMessage $ T.unwords - [ targetName, "the", targetRole, "slumps down to the ground, hands clutching at their chest" - , "while blood slips between their fingers and pools around them." - ] - where - targetName = target ^. name - targetRole = target ^. role . Role.name - -orphanJoinedPackMessages :: Text -> [Text] -> [Message] -orphanJoinedPackMessages orphansName werewolfNames = - privateMessage orphansName (T.unwords - [ "The death of your role model is distressing. Without second thought you abandon the" - , "Villagers and run off into the woods, towards a new home. As you arrive you see the" - , tryPlural (length werewolfNames) "face", "of" - , concatList werewolfNames, "waiting for you." - ]) - : groupMessages werewolfNames (T.unwords - [ orphansName, "the Orphan scampers off into the woods. Without their role model they have" - , "abandoned the village and are in search of a new home. You welcome them into your pack." - ]) - -playerCannotProtectSamePlayerTwiceInARowMessage :: Text -> Message -playerCannotProtectSamePlayerTwiceInARowMessage to = - privateMessage to "You cannot protect the same player twice in a row!" - -scapegoatChoseAllowedVotersMessage :: [Text] -> Message -scapegoatChoseAllowedVotersMessage allowedVoters = publicMessage $ T.unwords - [ "On the next day only", concatList allowedVoters, "shall be allowed to vote. The Town Crier," - , "realising how foolish it was to kill the Scapegoat, grants them this wish." - ] - -playerMustChooseAtLeastOneTargetMessage :: Text -> Message -playerMustChooseAtLeastOneTargetMessage to = - privateMessage to "You must choose at least 1 target!" - -playerCannotChooseJesterMessage :: Text -> Message -playerCannotChooseJesterMessage to = - privateMessage to "You cannot choose the Jester!" - -playerSeenMessage :: Text -> Player -> Message -playerSeenMessage to target = privateMessage to $ T.concat - [targetName, " is aligned with ", article, humanise allegiance', "."] - where - targetName = target ^. name - allegiance' - | is alphaWolf target = Villagers - | is lycan target = Werewolves - | otherwise = target ^. role . allegiance - article = if allegiance' == NoOne then "" else "the " - -villageDrunkJoinedVillageMessage :: Text -> Message -villageDrunkJoinedVillageMessage to = privateMessage to $ T.unwords - [ "Somehow you managed to avoid getting killed while in your drunken stupor. Thank God for" - , "that, maybe now you can actually help the village." - ] - -villageDrunkJoinedPackMessages :: Text -> [Text] -> [Message] -villageDrunkJoinedPackMessages villageDrunksName werewolfNames = - privateMessage villageDrunksName (T.concat - [ "As you start to feel sober for the first time in days a new thirst begins to take hold." - , " The bloodthirst starts to bring back memories, memories of your true home with " - , concatList werewolfNames, "." - ]) - : groupMessages werewolfNames (T.unwords - [ villageDrunksName - , "the Village Drunk has finally sobered up and remembered their true home." - ]) - -playerMadeLynchVoteMessage :: Maybe Text -> Text -> Text -> Message -playerMadeLynchVoteMessage mTo voterName targetName = Message mTo $ T.concat - [ voterName, " voted to lynch ", targetName, "." - ] - -playerLynchedMessage :: Player -> Message -playerLynchedMessage player - | is simpleWerewolf player - || is alphaWolf player = publicMessage $ T.concat - [ playerName, " is tied up to a pyre and set alight. As they scream their body starts to " - , "contort and writhe, transforming into ", article playerRole, " " - , playerRole ^. Role.name, ".", " Thankfully they go limp before breaking free of their " - , "restraints." - ] - | otherwise = publicMessage $ T.concat - [ playerName, " is tied up to a pyre and set alight. Eventually the screams start to die " - , "and with their last breath, they reveal themselves as ", article playerRole, " " - , playerRole ^. Role.name, "." - ] - where - playerName = player ^. name - playerRole = player ^. role - -noPlayerLynchedMessage :: Message -noPlayerLynchedMessage = publicMessage $ T.unwords - [ "Daylight is wasted as the townsfolk squabble over whom to tie up. Looks like no-one is being" - , "burned this day." - ] - -jesterLynchedMessage :: Text -> Message -jesterLynchedMessage name = publicMessage $ T.concat - [ "Just as the townsfolk tie ", name, " up to the pyre, a voice in the crowd yells out." - , " \"We can't burn ", name, "! He's the joke of the town!\" " - , name, " the Jester is quickly untied and apologised to." - ] - -scapegoatLynchedMessage :: Text -> Message -scapegoatLynchedMessage name = publicMessage $ T.unwords - [ "The townsfolk squabble over whom to tie up. Just as they are about to call it a day" - , "they notice that", name, "has been acting awfully suspicious." - , "Not wanting to take any chances,", name, "is promptly tied to a pyre and burned alive." - ] - -playerHasAlreadyVotedMessage :: Text -> Message -playerHasAlreadyVotedMessage to = privateMessage to "You've already voted!" - -playerMadeDevourVoteMessage :: Text -> Text -> Text -> Message -playerMadeDevourVoteMessage to voterName targetName = privateMessage to $ T.concat - [ voterName, " voted to devour ", targetName, "." - ] - -playerDevouredMessage :: Player -> Message -playerDevouredMessage player = publicMessage $ T.concat - [ "As you open them you notice a door broken down and " - , playerName, "'s guts half devoured and spilling out over the cobblestones." - , " From the look of their personal effects, you deduce they were " - , article playerRole, " ", playerRole ^. Role.name, "." - ] - where - playerName = player ^. name - playerRole = player ^. role - -noPlayerDevouredMessage :: Message -noPlayerDevouredMessage = publicMessage $ T.unwords - [ "Surprisingly you see everyone present at the town square." - , "Perhaps the Werewolves have left Fougères?" - ] - -playerCannotDevourAnotherWerewolfMessage :: Text -> Message -playerCannotDevourAnotherWerewolfMessage to = privateMessage to "You cannot devour another Werewolf!" - -playerCannotChooseSelfMessage :: Text -> Message -playerCannotChooseSelfMessage to = privateMessage to "You cannot choose yourself!" - -playerPoisonedMessage :: Player -> Message -playerPoisonedMessage player = publicMessage $ T.unwords - [ "Upon further discovery, it looks like the Witch struck in the night." - , playerName, "the", playerRole, "is hanging over the side of their bed, poisoned." - ] - where - playerName = player ^. name - playerRole = player ^. role . Role.name - -playerHasAlreadyHealedMessage :: Text -> Message -playerHasAlreadyHealedMessage to = privateMessage to "You've already healed someone!" - -playerHasAlreadyPoisonedMessage :: Text -> Message -playerHasAlreadyPoisonedMessage to = privateMessage to "You've already poisoned someone!" - -article :: Role -> Text -article role - | role `elem` restrictedRoles = "the" - | otherwise = "a" - -concatList :: [Text] -> Text -concatList [] = "" -concatList [word] = word -concatList words = T.unwords [T.intercalate ", " (init words), "and", last words] - -conjugateToBe :: Int -> Text -conjugateToBe 1 = "is" -conjugateToBe _ = "are" - -tryPlural :: Int -> Text -> Text -tryPlural 1 word = word -tryPlural _ word = T.snoc word 's' diff --git a/src/Game/Werewolf/Player.hs b/src/Game/Werewolf/Player.hs --- a/src/Game/Werewolf/Player.hs +++ b/src/Game/Werewolf/Player.hs @@ -1,13 +1,12 @@ {-| Module : Game.Werewolf.Player -Description : Simplistic player data structure with functions for searching, filtering and querying +Description : Simplistic player data structure with lenses for searching, filtering and querying lists of players. Copyright : (c) Henry J. Wylde, 2016 License : BSD3 Maintainer : public@hjwylde.com -Players are quite simple in themselves. They have a 'name', 'role' and 'state'. Any complex -behaviour is handled in "Game.Werewolf.Command" and "Game.Werewolf.Engine". +Players are quite simple in themselves. They have a 'name', 'role' and 'state'. -} {-# LANGUAGE FlexibleContexts #-} @@ -25,17 +24,20 @@ newPlayer, -- ** Traversals - alphaWolf, beholder, crookedSenator, druid, fallenAngel, hunter, jester, lycan, orphan, - protector, scapegoat, seer, simpleVillager, simpleWerewolf, trueVillager, villageDrunk, witch, + alphaWolf, beholder, crookedSenator, druid, fallenAngel, hunter, jester, lycan, medusa, oracle, + orphan, protector, scapegoat, seer, simpleVillager, simpleWerewolf, spitefulGhost, trueVillager, + villageDrunk, witch, villager, werewolf, - -- | These are provided just as a bit of sugar to avoid continually writing @'traverse' .@. + -- | The following traversals are provided just as a bit of sugar to avoid continually writing + -- @'traverse' .@. names, roles, states, - -- | N.B., these are not legal traversals for the same reason 'filtered' isn't! + -- | N.B., the following traversals are not legal for the same reason 'filtered' isn't! + named, alphaWolves, beholders, crookedSenators, druids, fallenAngels, hunters, jesters, lycans, - orphans, protectors, scapegoats, seers, simpleVillagers, simpleWerewolves, trueVillagers, - villageDrunks, witches, + medusas, oracles, orphans, protectors, scapegoats, seers, simpleVillagers, simpleWerewolves, + spitefulGhosts, trueVillagers, villageDrunks, witches, villagers, werewolves, alive, dead, ) where @@ -69,11 +71,13 @@ makePrisms ''State --- | Creates a new 'Alive' player. +-- | Creates a new 'Alive' player, with one exception: a 'spitefulGhost' always starts 'Dead'. newPlayer :: Text -> Role -> Player -newPlayer name role = Player name role Alive +newPlayer name role = Player name role state + where + state = if role == spitefulGhostRole then Dead else Alive --- | The traversal of 'Player's with a 'alphaWolfRole'. +-- | The traversal of 'Player's with an 'alphaWolfRole'. -- -- @ -- 'alphaWolf' = 'role' . 'only' 'alphaWolfRole' @@ -105,7 +109,7 @@ druid :: Traversal' Player () druid = role . only druidRole --- | The traversal of 'Player's with an 'fallenAngelRole'. +-- | The traversal of 'Player's with a 'fallenAngelRole'. -- -- @ -- 'fallenAngel' = 'role' . 'only' 'fallenAngelRole' @@ -137,9 +141,25 @@ lycan :: Traversal' Player () lycan = role . only lycanRole --- | The traversal of 'Player's with a 'orphanRole'. +-- | The traversal of 'Player's with a 'medusaRole'. -- -- @ +-- 'medusa' = 'role' . 'only' 'medusaRole' +-- @ +medusa :: Traversal' Player () +medusa = role . only medusaRole + +-- | The traversal of 'Player's with a 'oracleRole'. +-- +-- @ +-- 'oracle' = 'role' . 'only' 'oracleRole' +-- @ +oracle :: Traversal' Player () +oracle = role . only oracleRole + +-- | The traversal of 'Player's with an 'orphanRole'. +-- +-- @ -- 'orphan' = 'role' . 'only' 'orphanRole' -- @ orphan :: Traversal' Player () @@ -185,6 +205,14 @@ simpleWerewolf :: Traversal' Player () simpleWerewolf = role . only simpleWerewolfRole +-- | The traversal of 'Player's with a 'spitefulGhostRole'. +-- +-- @ +-- 'spitefulGhost' = 'role' . 'only' 'spitefulGhostRole' +-- @ +spitefulGhost :: Traversal' Player () +spitefulGhost = role . only spitefulGhostRole + -- | The traversal of 'Player's with a 'trueVillagerRole'. -- -- @ @@ -249,6 +277,14 @@ states :: Traversable t => Traversal' (t Player) State states = traverse . state +-- | This 'Traversal' provides the traversal of 'Player's with the given name. +-- +-- @ +-- 'named' name' = filteredBy' . 'name' name' +-- @ +named :: Text -> Traversal' Player Player +named name' = filteredBy name name' + -- | This 'Traversal' provides the traversal of 'alphaWolf' 'Player's. -- -- @ @@ -313,6 +349,22 @@ lycans :: Traversable t => Traversal' (t Player) Player lycans = traverse . filtered (is lycan) +-- | This 'Traversal' provides the traversal of 'medusa' 'Player's. +-- +-- @ +-- 'medusas' = 'traverse' . 'filtered' ('is' 'medusa') +-- @ +medusas :: Traversable t => Traversal' (t Player) Player +medusas = traverse . filtered (is medusa) + +-- | This 'Traversal' provides the traversal of 'oracle' 'Player's. +-- +-- @ +-- 'oracles' = 'traverse' . 'filtered' ('is' 'oracle') +-- @ +oracles :: Traversable t => Traversal' (t Player) Player +oracles = traverse . filtered (is oracle) + -- | This 'Traversal' provides the traversal of 'orphan' 'Player's. -- -- @ @@ -360,6 +412,14 @@ -- @ simpleWerewolves :: Traversable t => Traversal' (t Player) Player simpleWerewolves = traverse . filtered (is simpleWerewolf) + +-- | This 'Traversal' provides the traversal of 'spitefulGhost' 'Player's. +-- +-- @ +-- 'spitefulGhosts' = 'traverse' . 'filtered' ('is' 'spitefulGhost') +-- @ +spitefulGhosts :: Traversable t => Traversal' (t Player) Player +spitefulGhosts = traverse . filtered (is spitefulGhost) -- | This 'Traversal' provides the traversal of 'trueVillager' 'Player's. -- diff --git a/src/Game/Werewolf/Response.hs b/src/Game/Werewolf/Response.hs --- a/src/Game/Werewolf/Response.hs +++ b/src/Game/Werewolf/Response.hs @@ -80,7 +80,7 @@ exitWith :: MonadIO m => Response -> m a exitWith response = liftIO $ T.putStrLn (T.decodeUtf8 $ encode response) >> Exit.exitSuccess --- | A message may be either public or private, indicated by it's @to@ field. +-- | A message may be either public or private, indicated by its @to@ field. -- -- Each message contains a single text field. This field is permitted to contain special -- characters such as new lines and tabs. diff --git a/src/Game/Werewolf/Role.hs b/src/Game/Werewolf/Role.hs --- a/src/Game/Werewolf/Role.hs +++ b/src/Game/Werewolf/Role.hs @@ -1,6 +1,6 @@ {-| Module : Game.Werewolf.Role -Description : Simplistic role data structure and instances. +Description : Simplistic role data structure with lenses and instances. Copyright : (c) Henry J. Wylde, 2016 License : BSD3 @@ -39,7 +39,7 @@ -- | The Loners look out for themselves and themselves alone. -- The Loners must complete their own objective. - fallenAngelRole, + fallenAngelRole, spitefulGhostRole, -- *** The Villagers -- | Fraught with fear of the unseen enemy, the Villagers must work together to determine the @@ -47,8 +47,9 @@ -- certain few have learnt some tricks over the years that may turn out rather useful. -- The Villagers must lynch all of the Werewolves. - beholderRole, crookedSenatorRole, druidRole, hunterRole, jesterRole, lycanRole, protectorRole, - scapegoatRole, seerRole, simpleVillagerRole, trueVillagerRole, witchRole, + beholderRole, crookedSenatorRole, druidRole, hunterRole, jesterRole, lycanRole, medusaRole, + oracleRole, protectorRole, scapegoatRole, seerRole, simpleVillagerRole, trueVillagerRole, + witchRole, -- *** The Werewolves -- | Hiding in plain sight, the Werewolves are not a small trifle. @@ -67,8 +68,6 @@ import qualified Data.Text as T -- | Role definitions require only a few pieces of information. --- Most of the game logic behind a role is implemented in "Game.Werewolf.Command" and --- "Game.Werewolf.Engine". -- -- The @balance@ attribute on a role indicates the allegiance it favours. For example, a Simple -- Werewolf has a balance of -4 while the Seer has a balance of 2. A balance of 0 means it favours @@ -112,12 +111,15 @@ , hunterRole , jesterRole , lycanRole + , medusaRole + , oracleRole , orphanRole , protectorRole , scapegoatRole , seerRole , simpleVillagerRole , simpleWerewolfRole + , spitefulGhostRole , trueVillagerRole , villageDrunkRole , witchRole @@ -199,11 +201,8 @@ -- /angels left on Earth. Nothing is worse punishment for them, the Fallen Angel yearns for death/ -- /to once again be free!/ -- --- When the Fallen Angel is in play, the game begins with the village's vote and then the first --- night. --- --- The Fallen Angel wins if they manage to get eliminated on the first round (day or night). If --- however they fail, they become a Villager for the rest of the game. +-- The Fallen Angel wins if they manage to get lynched by the Villagers before the end of the +-- game. fallenAngelRole :: Role fallenAngelRole = Role { _name = "Fallen Angel" @@ -216,18 +215,37 @@ , "now one of the few angels left on Earth. Nothing is worse punishment for them, the" , "Fallen Angel yearns for death to once again be free!" ] - , _rules = T.intercalate "\n" - [ T.unwords - [ "When the Fallen Angel is in play, the game begins with the village's vote and then" - , "the first night." - ] - , T.unwords - [ "The Fallen Angel wins if they manage to get eliminated on the first round (day or" - , "night). If however they fail, they become a Villager for the rest of the game." - ] + , _rules = T.unwords + [ "The Fallen Angel wins if they manage to get lynched by the Villagers before the end of" + , "the game." ] } +-- | /In this time of turmoil, it would seem unlikely for the Villagers of Fougères to unanimously/ +-- /agree on anything. Yet this is not so, for they all agree the village is haunted by a ghost./ +-- /The vindictive Spiteful Ghost never moved on, rather they remain with the sole purpose of/ +-- /haunting the village and ensuring that the Villagers never forget what they have done./ +-- +-- The Spiteful ghost is dead and cannot win, however they know the game's role allocations and +-- may haunt the village as they wish. +spitefulGhostRole :: Role +spitefulGhostRole = Role + { _name = "Spiteful Ghost" + , _allegiance = NoOne + , _balance = 0 + , _description = T.unwords + [ "In this time of turmoil, it would seem unlikely for the Villagers of Fougères to" + , "unanimously agree on anything. Yet this is not so, for they all agree the village is" + , "haunted by a ghost. The vindictive Spiteful Ghost never moved on, rather they remain" + , "with the sole purpose of haunting the village and ensuring that the Villagers never" + , "forget what they have done." + ] + , _rules = T.unwords + [ "The Spiteful ghost is dead and cannot win, however they know the game's role allocations" + , "and may haunt the village as they wish." + ] + } + -- | /Awareness comes easy to the Beholder. They listen to their senses and trust their hunches./ -- /Over the years the Beholder has grown to know a certain few of the village just by paying/ -- /attention. Little cues here and there, the way someone talks, the way they move - it all/ @@ -238,7 +256,7 @@ beholderRole = Role { _name = "Beholder" , _allegiance = Villagers - , _balance = 2 + , _balance = 1 , _description = T.unwords [ "Awareness comes easy to the Beholder. They listen to their senses and trust their" , "hunches. Over the years the Beholder has grown to know a certain few of the village just" @@ -275,7 +293,7 @@ -- /proximity! Listen for her grunt and heed her warning for she will not let you down./ -- -- Each morning when Ferina wakes from her slumber she will be alert and cautious. If the Druid is --- next to a Werewolf then Ferina will grunt in warning. +-- next to a Werewolf in the player `circle` then Ferina will grunt in warning. druidRole :: Role druidRole = Role { _name = "Druid" @@ -291,7 +309,7 @@ ] , _rules = T.unwords [ "Each morning when Ferina wakes from her slumber she will be alert and cautious. If the" - , "Druid is next to a Werewolf then Ferina will grunt in warning." + , "Druid is next to a Werewolf in the player `circle` then Ferina will grunt in warning." ] } @@ -368,6 +386,58 @@ ] } +-- | /A beautiful flirt, the Medusa is aligned with the Villagers but harbours a terrifying secret./ +-- /During the day they are well known in the village of Fougères for their stunning appearance/ +-- /which captures the eye and love of all the townsfolk. However when their secret takes ahold/ +-- /at sundown, their true self is revealed. Any who gaze upon her true form would see live/ +-- /snakes for hair and the few that further look into her eyes are turned to stone./ +-- +-- If Medusa attracts the attention of a Werewolf during the night and is devoured, the first +-- Werewolf to their left in the player `circle` will catch their gaze and turn to stone, +-- instantly killing the lupine predator. +medusaRole :: Role +medusaRole = Role + { _name = "Medusa" + , _allegiance = Villagers + , _balance = 4 + , _description = T.unwords + [ "A beautiful flirt, the Medusa is aligned with the Villagers but harbours a terrifying" + , "secret. During the day they are well known in the village of Fougères for their stunning" + , "appearance which captures the eye and love of all the townsfolk. However when their" + , "secret takes ahold at sundown, their true self is revealed. Any who gaze upon her true" + , "form would see live snakes for hair and the few that further look into her eyes are" + , "turned to stone." + ] + , _rules = T.unwords + [ "If Medusa attracts the attention of a Werewolf during the night and is devoured, the" + , "first Werewolf to their left in the player `circle` will catch their gaze and turn to" + , "stone, instantly killing the lupine predator." + ] + } + +-- | /Originally rejected by the townsfolk, the Oracle's prophetic divinations has earned trust/ +-- /within the village. With constant precognition - and concern for the future - the Oracle/ +-- /knows the village will only live if they work together./ +-- +-- Each night the Oracle chooses a player to divine. They are then informed of the player's role +-- the following morning. This wisdom is for the Oracle to use to ensure the future of Fougères. +oracleRole :: Role +oracleRole = Role + { _name = "Oracle" + , _allegiance = Villagers + , _balance = 2 + , _description = T.unwords + [ "Originally rejected by the townsfolk, the Oracle's prophetic divinations has earned" + , "trust within the village. With constant precognition - and concern for the future - the" + , "Oracle knows the village will only live if they work together." + ] + , _rules = T.unwords + [ "Each night the Oracle chooses a player to divine. They are then informed of the player's" + , "role the following morning. This wisdom is for the Oracle to use to ensure the future of" + , "Fougères." + ] + } + -- | /The Protector is one of the few pure of heart and altruistic Villagers; they are forever/ -- /putting others needs above their own. Each night they fight against the Werewolves with/ -- /naught but a sword and shield, potentially saving an innocents life./ @@ -442,7 +512,10 @@ , "always be true, but only for the present as not even the Seer knows what the future" , "holds." ] - , _rules = "Each night the Seer sees the allegiance of one player of their choice." + , _rules = T.unwords + [ "Each night the Seer chooses a player to see. They are then informed of the player's" + , "allegiance the following morning." + ] } -- | /A simple, ordinary townsperson in every way. Some may be cobblers, others bakers or even/ @@ -491,7 +564,7 @@ -- /one of which heals a victim of the Werewolves, the other poisons a player./ -- -- The Witch is called after the Werewolves. They are able to heal and poison one player per game. --- There is no restriction on using both potions in one night or to heal themself. +-- There is no restriction on using both potions in one night or on healing themself. witchRole :: Role witchRole = Role { _name = "Witch" @@ -506,7 +579,7 @@ ] , _rules = T.unwords [ "The Witch is called after the Werewolves. They are able to heal and poison one player" - , "per game. There is no restriction on using both potions in one night or to heal" + , "per game. There is no restriction on using both potions in one night or on healing" , "themself." ] } diff --git a/src/Game/Werewolf/Util.hs b/src/Game/Werewolf/Util.hs deleted file mode 100644 --- a/src/Game/Werewolf/Util.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-| -Module : Game.Werewolf.Util -Description : Utility functions for working in a ('MonadState' 'Game') environment. - -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com - -Utility functions for woking in a ('MonadState' 'Game') environment. --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} - -module Game.Werewolf.Util ( - -- * Game - - -- ** Manipulations - killPlayer, removePlayer, setPlayerAllegiance, getRandomAllegiance, - - -- ** Searches - findPlayerBy_, getAdjacentAlivePlayers, getPlayerVote, getAllowedVoters, getPendingVoters, - getVoteResult, - - -- ** Queries - isGameOver, isHuntersTurn, isOrphansTurn, isProtectorsTurn, isScapegoatsTurn, isSeersTurn, - isSunrise, isVillagesTurn, isWerewolvesTurn, isWitchsTurn, - hasAnyoneWon, hasFallenAngelWon, hasVillagersWon, hasWerewolvesWon, - - -- * Player - - -- ** Queries - doesPlayerExist, - isPlayerHunter, isPlayerJester, isPlayerOrphan, isPlayerProtector, isPlayerScapegoat, - isPlayerSeer, isPlayerWitch, - isPlayerWerewolf, - isPlayerAlive, isPlayerDead, -) where - -import Control.Lens -import Control.Lens.Extra -import Control.Monad.Extra -import Control.Monad.Random -import Control.Monad.State - -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) - -import Game.Werewolf.Game hiding (doesPlayerExist, getAllowedVoters, getPendingVoters, - getVoteResult, hasAnyoneWon, hasFallenAngelWon, - hasVillagersWon, hasWerewolvesWon, killPlayer) -import qualified Game.Werewolf.Game as Game -import Game.Werewolf.Player -import Game.Werewolf.Role hiding (name) - -import Prelude hiding (round) - -killPlayer :: MonadState Game m => Text -> m () -killPlayer name = modify $ Game.killPlayer name - -removePlayer :: MonadState Game m => Text -> m () -removePlayer name' = do - killPlayer name' - - votes %= Map.delete name' - - player <- findPlayerBy_ name name' - - when (is fallenAngel player) $ setPlayerAllegiance name' Villagers - when (is orphan player) $ roleModel .= Nothing - when (is protector player) $ do - protect .= Nothing - priorProtect .= Nothing - when (is seer player) $ see .= Nothing - when (is witch player) $ do - heal .= False - healUsed .= False - poison .= Nothing - poisonUsed .= False - --- | Fudges the player's allegiance. This function is useful for roles such as the Orphan where --- they align themselves differently given some trigger. -setPlayerAllegiance :: MonadState Game m => Text -> Allegiance -> m () -setPlayerAllegiance name' allegiance' = modify $ players . traverse . filteredBy name name' . role . allegiance .~ allegiance' - --- | Get a random allegiance (either Villagers or Werewolves). -getRandomAllegiance :: MonadRandom m => m Allegiance -getRandomAllegiance = fromList [(Villagers, 0.5), (Werewolves, 0.5)] - -findPlayerBy_ :: (Eq a, MonadState Game m) => Lens' Player a -> a -> m Player -findPlayerBy_ lens value = fromJust <$> preuse (players . traverse . filteredBy lens value) - -getAdjacentAlivePlayers :: MonadState Game m => Text -> m [Player] -getAdjacentAlivePlayers name' = do - alivePlayers <- toListOf (players . traverse . alive) <$> get - let index = fromJust $ elemIndex name' (alivePlayers ^.. names) - - return $ adjacentElements index alivePlayers - where - adjacentElements 0 list = last list : take 2 list - adjacentElements index list = take 3 $ drop (index - 1) (cycle list) - -getPlayerVote :: MonadState Game m => Text -> m (Maybe Text) -getPlayerVote playerName = use $ votes . at playerName - -getAllowedVoters :: MonadState Game m => m [Player] -getAllowedVoters = gets Game.getAllowedVoters - -getPendingVoters :: MonadState Game m => m [Player] -getPendingVoters = gets Game.getPendingVoters - -getVoteResult :: MonadState Game m => m [Player] -getVoteResult = gets Game.getVoteResult - -isGameOver :: MonadState Game m => m Bool -isGameOver = has (stage . _GameOver) <$> get - -isHuntersTurn :: MonadState Game m => m Bool -isHuntersTurn = orM - [ has (stage . _HuntersTurn1) <$> get - , has (stage . _HuntersTurn2) <$> get - ] - -isOrphansTurn :: MonadState Game m => m Bool -isOrphansTurn = has (stage . _OrphansTurn) <$> get - -isProtectorsTurn :: MonadState Game m => m Bool -isProtectorsTurn = has (stage . _ProtectorsTurn) <$> get - -isScapegoatsTurn :: MonadState Game m => m Bool -isScapegoatsTurn = has (stage . _ScapegoatsTurn) <$> get - -isSeersTurn :: MonadState Game m => m Bool -isSeersTurn = has (stage . _SeersTurn) <$> get - -isSunrise :: MonadState Game m => m Bool -isSunrise = has (stage . _Sunrise) <$> get - -isVillagesTurn :: MonadState Game m => m Bool -isVillagesTurn = has (stage . _VillagesTurn) <$> get - -isWerewolvesTurn :: MonadState Game m => m Bool -isWerewolvesTurn = has (stage . _WerewolvesTurn) <$> get - -isWitchsTurn :: MonadState Game m => m Bool -isWitchsTurn = has (stage . _WitchsTurn) <$> get - -hasAnyoneWon :: MonadState Game m => m Bool -hasAnyoneWon = gets Game.hasAnyoneWon - -hasFallenAngelWon :: MonadState Game m => m Bool -hasFallenAngelWon = gets Game.hasFallenAngelWon - -hasVillagersWon :: MonadState Game m => m Bool -hasVillagersWon = gets Game.hasVillagersWon - -hasWerewolvesWon :: MonadState Game m => m Bool -hasWerewolvesWon = gets Game.hasWerewolvesWon - -doesPlayerExist :: MonadState Game m => Text -> m Bool -doesPlayerExist name = gets $ Game.doesPlayerExist name - -isPlayerHunter :: MonadState Game m => Text -> m Bool -isPlayerHunter name' = is hunter <$> findPlayerBy_ name name' - -isPlayerJester :: MonadState Game m => Text -> m Bool -isPlayerJester name' = is jester <$> findPlayerBy_ name name' - -isPlayerOrphan :: MonadState Game m => Text -> m Bool -isPlayerOrphan name' = is orphan <$> findPlayerBy_ name name' - -isPlayerProtector :: MonadState Game m => Text -> m Bool -isPlayerProtector name' = is protector <$> findPlayerBy_ name name' - -isPlayerScapegoat :: MonadState Game m => Text -> m Bool -isPlayerScapegoat name' = is scapegoat <$> findPlayerBy_ name name' - -isPlayerSeer :: MonadState Game m => Text -> m Bool -isPlayerSeer name' = is seer <$> findPlayerBy_ name name' - -isPlayerWitch :: MonadState Game m => Text -> m Bool -isPlayerWitch name' = is witch <$> findPlayerBy_ name name' - -isPlayerWerewolf :: MonadState Game m => Text -> m Bool -isPlayerWerewolf name' = is werewolf <$> findPlayerBy_ name name' - -isPlayerAlive :: MonadState Game m => Text -> m Bool -isPlayerAlive name' = is alive <$> findPlayerBy_ name name' - -isPlayerDead :: MonadState Game m => Text -> m Bool -isPlayerDead name' = is dead <$> findPlayerBy_ name name' diff --git a/test/app/Main.hs b/test/app/Main.hs deleted file mode 100644 --- a/test/app/Main.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-| -Module : Main -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Main ( - -- * Main - main -) where - -import Game.Werewolf.Test.Command -import Game.Werewolf.Test.Engine - -import Test.Tasty -import Test.Tasty.QuickCheck - -main :: IO () -main = defaultMain . localOption (QuickCheckTests 20) =<< tests - -tests :: IO TestTree -tests = return . testGroup "Tests" $ allCommandTests ++ allEngineTests diff --git a/test/src/Game/Werewolf/Test/Arbitrary.hs b/test/src/Game/Werewolf/Test/Arbitrary.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Arbitrary.hs +++ /dev/null @@ -1,429 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Arbitrary -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Game.Werewolf.Test.Arbitrary ( - -- * Initial arbitraries - - -- ** Game - GameAtGameOver(..), GameAtHuntersTurn(..), GameAtOrphansTurn(..), GameAtProtectorsTurn(..), - GameAtScapegoatsTurn(..), GameAtSeersTurn(..), GameAtSunrise(..), GameAtVillagesTurn(..), - GameAtWerewolvesTurn(..), GameAtWitchsTurn(..), - - GameWithAllowedVoters(..), GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..), - GameWithJesterRevealedAtVillagesTurn(..), GameWithLynchVotes(..), GameWithMajorityVote(..), - GameWithPoison(..), GameWithProtect(..), - - -- ** Player - arbitraryPlayerSet, - - -- * Contextual arbitraries - - -- ** Command - arbitraryCommand, arbitraryHunterChooseCommand, arbitraryOrphanChooseCommand, - arbitraryScapegoatChooseCommand, arbitraryHealCommand, arbitraryPassCommand, - arbitraryPoisonCommand, arbitraryProtectCommand, arbitraryQuitCommand, arbitrarySeeCommand, - arbitraryWerewolfVoteCommand, arbitraryVillagerVoteCommand, - - runArbitraryCommands, - - -- ** Player - arbitraryPlayer, arbitraryWerewolf, -) where - -import Control.Lens hiding (elements, isn't) -import Control.Lens.Extra - -import Data.List.Extra -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T - -import Game.Werewolf -import Game.Werewolf.Command.Global -import Game.Werewolf.Command.Hunter as Hunter -import Game.Werewolf.Command.Orphan as Orphan -import Game.Werewolf.Command.Protector -import Game.Werewolf.Command.Scapegoat as Scapegoat -import Game.Werewolf.Command.Seer -import Game.Werewolf.Command.Villager as Villager -import Game.Werewolf.Command.Werewolf as Werewolf -import Game.Werewolf.Command.Witch -import Game.Werewolf.Test.Util - -import Prelude hiding (round) - -import Test.QuickCheck - -instance Arbitrary Game where - arbitrary = do - game <- newGame <$> arbitraryPlayerSet - stage' <- arbitrary - - return $ game & stage .~ stage' - -instance Arbitrary Stage where - arbitrary = elements . nub $ allStages \\ [GameOver, Sunrise, Sunset] - -instance Arbitrary Player where - arbitrary = newPlayer <$> arbitrary <*> arbitrary - -instance Arbitrary State where - arbitrary = elements [Alive, Dead] - -instance Arbitrary Role where - arbitrary = elements allRoles - -instance Arbitrary Allegiance where - arbitrary = elements [Villagers, Werewolves] - -instance Arbitrary Text where - arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) - -newtype GameAtGameOver = GameAtGameOver Game - deriving (Eq, Show) - -instance Arbitrary GameAtGameOver where - arbitrary = do - game <- arbitrary - - return $ GameAtGameOver (game & stage .~ GameOver) - -newtype GameAtHuntersTurn = GameAtHuntersTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtHuntersTurn where - arbitrary = do - game <- arbitrary - turn <- elements [HuntersTurn1, HuntersTurn2] - - return $ GameAtHuntersTurn (game & stage .~ turn) - -newtype GameAtOrphansTurn = GameAtOrphansTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtOrphansTurn where - arbitrary = do - game <- arbitrary - - return $ GameAtOrphansTurn (game & stage .~ OrphansTurn) - -newtype GameAtProtectorsTurn = GameAtProtectorsTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtProtectorsTurn where - arbitrary = do - game <- arbitrary - - return $ GameAtProtectorsTurn (game & stage .~ ProtectorsTurn) - -newtype GameAtScapegoatsTurn = GameAtScapegoatsTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtScapegoatsTurn where - arbitrary = do - (GameWithConflictingVote game) <- arbitrary - - return $ GameAtScapegoatsTurn (run_ checkStage game) - -newtype GameAtSeersTurn = GameAtSeersTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtSeersTurn where - arbitrary = do - game <- arbitrary - - return $ GameAtSeersTurn (game & stage .~ SeersTurn) - -newtype GameAtSunrise = GameAtSunrise Game - deriving (Eq, Show) - -instance Arbitrary GameAtSunrise where - arbitrary = do - game <- arbitrary - - return $ GameAtSunrise (game & stage .~ Sunrise) - -newtype GameAtVillagesTurn = GameAtVillagesTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtVillagesTurn where - arbitrary = do - game <- arbitrary - - return $ GameAtVillagesTurn (game & stage .~ VillagesTurn) - -newtype GameAtWerewolvesTurn = GameAtWerewolvesTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtWerewolvesTurn where - arbitrary = do - game <- arbitrary - - return $ GameAtWerewolvesTurn (game & stage .~ WerewolvesTurn) - -newtype GameAtWitchsTurn = GameAtWitchsTurn Game - deriving (Eq, Show) - -instance Arbitrary GameAtWitchsTurn where - arbitrary = do - game <- arbitrary - - return $ GameAtWitchsTurn (game & stage .~ WitchsTurn) - -newtype GameWithAllowedVoters = GameWithAllowedVoters Game - deriving (Eq, Show) - -instance Arbitrary GameWithAllowedVoters where - arbitrary = do - (GameAtScapegoatsTurn game) <- arbitrary - (Blind command) <- arbitraryScapegoatChooseCommand game - - return $ GameWithAllowedVoters (run_ (apply command) game) - -newtype GameWithConflictingVote = GameWithConflictingVote Game - deriving (Eq, Show) - -instance Arbitrary GameWithConflictingVote where - arbitrary = do - (GameWithLynchVotes game) <- suchThat arbitrary $ \(GameWithLynchVotes game) -> - length (getVoteResult game) > 1 - - return $ GameWithConflictingVote game - -newtype GameWithDevourEvent = GameWithDevourEvent Game - deriving (Eq, Show) - -instance Arbitrary GameWithDevourEvent where - arbitrary = do - (GameWithDevourVotes game) <- suchThat arbitrary $ \(GameWithDevourVotes game) -> - length (getVoteResult game) == 1 - - return $ GameWithDevourEvent (run_ checkStage game) - -newtype GameWithDevourVotes = GameWithDevourVotes Game - deriving (Eq, Show) - -instance Arbitrary GameWithDevourVotes where - arbitrary = do - game <- arbitrary - - GameWithDevourVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ WerewolvesTurn) - -newtype GameWithHeal = GameWithHeal Game - deriving (Eq, Show) - -instance Arbitrary GameWithHeal where - arbitrary = do - (GameWithDevourEvent game) <- arbitrary - (Blind command) <- arbitraryHealCommand game - - return $ GameWithHeal (run_ (apply command) game) - -newtype GameWithJesterRevealed = GameWithJesterRevealed Game - deriving (Eq, Show) - -instance Arbitrary GameWithJesterRevealed where - arbitrary = do - game <- arbitrary - let jestersName = game ^?! players . jesters . name - let game' = game & jesterRevealed .~ True & allowedVoters %~ delete jestersName - - return $ GameWithJesterRevealed game' - -newtype GameWithJesterRevealedAtVillagesTurn = GameWithJesterRevealedAtVillagesTurn Game - deriving (Eq, Show) - -instance Arbitrary GameWithJesterRevealedAtVillagesTurn where - arbitrary = do - (GameWithJesterRevealed game) <- arbitrary - - return $ GameWithJesterRevealedAtVillagesTurn (game & stage .~ VillagesTurn) - -newtype GameWithLynchVotes = GameWithLynchVotes Game - deriving (Eq, Show) - -instance Arbitrary GameWithLynchVotes where - arbitrary = do - game <- arbitrary - - GameWithLynchVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ VillagesTurn) - -newtype GameWithMajorityVote = GameWithMajorityVote Game - deriving (Eq, Show) - -instance Arbitrary GameWithMajorityVote where - arbitrary = do - (GameWithLynchVotes game) <- suchThat arbitrary $ \(GameWithLynchVotes game) -> - length (getVoteResult game) == 1 - - return $ GameWithMajorityVote game - -newtype GameWithPoison = GameWithPoison Game - deriving (Eq, Show) - -instance Arbitrary GameWithPoison where - arbitrary = do - game <- arbitrary - let game' = game & stage .~ WitchsTurn - (Blind command) <- arbitraryPoisonCommand game' - - return $ GameWithPoison (run_ (apply command) game') - -newtype GameWithProtect = GameWithProtect Game - deriving (Eq, Show) - -instance Arbitrary GameWithProtect where - arbitrary = do - game <- arbitrary - let game' = game & stage .~ ProtectorsTurn - (Blind command) <- arbitraryProtectCommand game' - - return $ GameWithProtect (run_ (apply command) game') - -arbitraryPlayerSet :: Gen [Player] -arbitraryPlayerSet = do - n <- choose (14, 30) - players <- nubOn (view name) <$> infiniteList - - let playersWithRestrictedRole = map (\role' -> players ^?! traverse . filteredBy role role') restrictedRoles - - let simpleWerewolves' = players ^.. taking (n `quot` 5 + 1) simpleWerewolves - let simpleVillagers' = players ^.. taking (n - length restrictedRoles - length simpleWerewolves') simpleVillagers - - return $ playersWithRestrictedRole ++ simpleVillagers' ++ simpleWerewolves' - -arbitraryCommand :: Game -> Gen (Blind Command) -arbitraryCommand game = case game ^. stage of - FerinasGrunt -> return $ Blind noopCommand - GameOver -> return $ Blind noopCommand - HuntersTurn1 -> arbitraryHunterChooseCommand game - HuntersTurn2 -> arbitraryHunterChooseCommand game - Lynching -> return $ Blind noopCommand - OrphansTurn -> arbitraryOrphanChooseCommand game - ProtectorsTurn -> arbitraryProtectCommand game - ScapegoatsTurn -> arbitraryScapegoatChooseCommand game - SeersTurn -> arbitrarySeeCommand game - Sunrise -> return $ Blind noopCommand - Sunset -> return $ Blind noopCommand - VillageDrunksTurn -> return $ Blind noopCommand - VillagesTurn -> arbitraryVillagerVoteCommand game - WerewolvesTurn -> arbitraryWerewolfVoteCommand game - WitchsTurn -> oneof - [ arbitraryHealCommand game - , arbitraryPassCommand game - , arbitraryPoisonCommand game - ] - -arbitraryHunterChooseCommand :: Game -> Gen (Blind Command) -arbitraryHunterChooseCommand game = do - let hunter = game ^?! players . hunters - target <- arbitraryPlayer game - - return . Blind $ Hunter.chooseCommand (hunter ^. name) (target ^. name) - -arbitraryOrphanChooseCommand :: Game -> Gen (Blind Command) -arbitraryOrphanChooseCommand game = do - let orphan = game ^?! players . orphans - target <- suchThat (arbitraryPlayer game) (orphan /=) - - return . Blind $ Orphan.chooseCommand (orphan ^. name) (target ^. name) - -arbitraryScapegoatChooseCommand :: Game -> Gen (Blind Command) -arbitraryScapegoatChooseCommand game = do - let scapegoatsName = game ^?! players . scapegoats . name - (NonEmpty players') <- NonEmpty <$> sublistOf (game ^.. players . traverse . alive) - - return . Blind $ Scapegoat.chooseCommand scapegoatsName (players' ^.. names) - -arbitraryHealCommand :: Game -> Gen (Blind Command) -arbitraryHealCommand game = do - let witchsName = game ^?! players . witches . name - - return . Blind $ if game ^. healUsed - then noopCommand - else healCommand witchsName - -arbitraryPassCommand :: Game -> Gen (Blind Command) -arbitraryPassCommand game = do - let witchsName = game ^?! players . witches . name - - return . Blind $ passCommand witchsName - -arbitraryPoisonCommand :: Game -> Gen (Blind Command) -arbitraryPoisonCommand game = do - let witchsName = game ^?! players . witches . name - target <- arbitraryPlayer game - - return $ if isJust (game ^. poison) - then Blind noopCommand - else Blind $ poisonCommand witchsName (target ^. name) - -arbitraryProtectCommand :: Game -> Gen (Blind Command) -arbitraryProtectCommand game = do - let protector = game ^?! players . protectors - -- TODO (hjw): add suchThat (/= priorProtect) - target <- suchThat (arbitraryPlayer game) (protector /=) - - return $ if isJust (game ^. protect) - then Blind noopCommand - else Blind $ protectCommand (protector ^. name) (target ^. name) - -arbitraryQuitCommand :: Game -> Gen (Blind Command) -arbitraryQuitCommand game = do - let applicableCallerNames = game ^.. players . traverse . alive . name - - if null applicableCallerNames - then return $ Blind noopCommand - else elements applicableCallerNames >>= \callersName -> - return . Blind $ quitCommand callersName - -arbitrarySeeCommand :: Game -> Gen (Blind Command) -arbitrarySeeCommand game = do - let seersName = game ^?! players . seers . name - target <- arbitraryPlayer game - - return $ if isJust (game ^. see) - then Blind noopCommand - else Blind $ seeCommand seersName (target ^. name) - -arbitraryWerewolfVoteCommand :: Game -> Gen (Blind Command) -arbitraryWerewolfVoteCommand game = do - let applicableCallerNames = getPendingVoters game ^.. werewolves . name - target <- suchThat (arbitraryPlayer game) $ isn't werewolf - - if null applicableCallerNames - then return $ Blind noopCommand - else elements applicableCallerNames >>= \callerName -> - return . Blind $ Werewolf.voteCommand callerName (target ^. name) - -arbitraryVillagerVoteCommand :: Game -> Gen (Blind Command) -arbitraryVillagerVoteCommand game = do - let applicableCallerNames = (game ^. allowedVoters) `intersect` (getPendingVoters game ^.. names) - target <- arbitraryPlayer game - - if null applicableCallerNames - then return $ Blind noopCommand - else elements applicableCallerNames >>= \callerName -> - return . Blind $ Villager.voteCommand callerName (target ^. name) - -runArbitraryCommands :: Int -> Game -> Gen Game -runArbitraryCommands n = iterateM n $ \game -> do - (Blind 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 - -arbitraryPlayer :: Game -> Gen Player -arbitraryPlayer game = elements $ game ^.. players . traverse . alive - -arbitraryWerewolf :: Game -> Gen Player -arbitraryWerewolf game = elements $ game ^.. players . werewolves . alive diff --git a/test/src/Game/Werewolf/Test/Command.hs b/test/src/Game/Werewolf/Test/Command.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command ( - -- * Tests - allCommandTests, -) where - -import Game.Werewolf.Test.Command.Choose -import Game.Werewolf.Test.Command.Heal -import Game.Werewolf.Test.Command.Pass -import Game.Werewolf.Test.Command.Poison -import Game.Werewolf.Test.Command.Protect -import Game.Werewolf.Test.Command.Quit -import Game.Werewolf.Test.Command.See -import Game.Werewolf.Test.Command.Vote - -import Test.Tasty - -allCommandTests :: [TestTree] -allCommandTests = concat - [ allChooseCommandTests - , allHealCommandTests - , allPassCommandTests - , allPoisonCommandTests - , allProtectCommandTests - , allQuitCommandTests - , allSeeCommandTests - , allVoteCommandTests - ] diff --git a/test/src/Game/Werewolf/Test/Command/Choose.hs b/test/src/Game/Werewolf/Test/Command/Choose.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Choose.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Choose -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -{-# LANGUAGE OverloadedStrings #-} - -module Game.Werewolf.Test.Command.Choose ( - -- * Tests - allChooseCommandTests, -) where - -import Control.Lens hiding (elements, isn't) -import Control.Lens.Extra - -import Game.Werewolf -import Game.Werewolf.Command.Hunter as Hunter -import Game.Werewolf.Command.Orphan as Orphan -import Game.Werewolf.Command.Scapegoat as Scapegoat -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allChooseCommandTests :: [TestTree] -allChooseCommandTests = - [ testProperty "hunter choose command errors when game is over" prop_hunterChooseCommandErrorsWhenGameIsOver - , testProperty "hunter choose command errors when caller does not exist" prop_hunterChooseCommandErrorsWhenCallerDoesNotExist - , testProperty "hunter choose command errors when any target does not exist" prop_hunterChooseCommandErrorsWhenTargetDoesNotExist - , testProperty "hunter choose command errors when any target is dead" prop_hunterChooseCommandErrorsWhenTargetIsDead - , testProperty "hunter choose command errors when not hunter's turn" prop_hunterChooseCommandErrorsWhenNotHuntersTurn - , testProperty "hunter choose command errors when caller not hunter" prop_hunterChooseCommandErrorsWhenCallerNotHunter - - , testProperty "orphan choose command errors when game is over" prop_orphanChooseCommandErrorsWhenGameIsOver - , testProperty "orphan choose command errors when caller does not exist" prop_orphanChooseCommandErrorsWhenCallerDoesNotExist - , testProperty "orphan choose command errors when target does not exist" prop_orphanChooseCommandErrorsWhenTargetDoesNotExist - , testProperty "orphan choose command errors when caller is dead" prop_orphanChooseCommandErrorsWhenCallerIsDead - , testProperty "orphan choose command errors when target is dead" prop_orphanChooseCommandErrorsWhenTargetIsDead - , testProperty "orphan choose command errors when target is caller" prop_orphanChooseCommandErrorsWhenTargetIsCaller - , testProperty "orphan choose command errors when not orphan's turn" prop_orphanChooseCommandErrorsWhenNotOrphansTurn - , testProperty "orphan choose command errors when caller not orphan" prop_orphanChooseCommandErrorsWhenCallerNotOrphan - - , testProperty "scapegoat choose command errors when game is over" prop_scapegoatChooseCommandErrorsWhenGameIsOver - , testProperty "scapegoat choose command errors when caller does not exist" prop_scapegoatChooseCommandErrorsWhenCallerDoesNotExist - , testProperty "scapegoat choose command errors when any target does not exist" prop_scapegoatChooseCommandErrorsWhenAnyTargetDoesNotExist - , testProperty "scapegoat choose command errors when any target is dead" prop_scapegoatChooseCommandErrorsWhenAnyTargetIsDead - , testProperty "scapegoat choose command errors when not scapegoat's turn" prop_scapegoatChooseCommandErrorsWhenNotScapegoatsTurn - , testProperty "scapegoat choose command errors when caller not scapegoat" prop_scapegoatChooseCommandErrorsWhenCallerNotScapegoat - ] - -prop_hunterChooseCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_hunterChooseCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryHunterChooseCommand game) $ verbose_runCommandErrors game . getBlind - -prop_hunterChooseCommandErrorsWhenCallerDoesNotExist :: GameAtHuntersTurn -> Player -> Property -prop_hunterChooseCommandErrorsWhenCallerDoesNotExist (GameAtHuntersTurn game) caller = - forAll (arbitraryPlayer game) $ \target -> do - let command = Hunter.chooseCommand (caller ^. name) (target ^. name) - - not (doesPlayerExist (caller ^. name) game) - ==> verbose_runCommandErrors game command - -prop_hunterChooseCommandErrorsWhenTargetDoesNotExist :: GameAtHuntersTurn -> Player -> Property -prop_hunterChooseCommandErrorsWhenTargetDoesNotExist (GameAtHuntersTurn game) target = do - let hunter = game ^?! players . hunters - let command = Hunter.chooseCommand (hunter ^. name) (target ^. name) - - not (doesPlayerExist (target ^. name) game) - ==> verbose_runCommandErrors game command - -prop_hunterChooseCommandErrorsWhenTargetIsDead :: GameAtHuntersTurn -> Property -prop_hunterChooseCommandErrorsWhenTargetIsDead (GameAtHuntersTurn game) = do - let hunter = game ^?! players . hunters - - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = Hunter.chooseCommand (hunter ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_hunterChooseCommandErrorsWhenNotHuntersTurn :: Game -> Property -prop_hunterChooseCommandErrorsWhenNotHuntersTurn game = - hasn't (stage . _HuntersTurn1) game && hasn't (stage . _HuntersTurn2) game - ==> forAll (arbitraryHunterChooseCommand game) $ verbose_runCommandErrors game . getBlind - -prop_hunterChooseCommandErrorsWhenCallerNotHunter :: GameAtHuntersTurn -> Property -prop_hunterChooseCommandErrorsWhenCallerNotHunter (GameAtHuntersTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't hunter)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = Hunter.chooseCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_orphanChooseCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_orphanChooseCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryOrphanChooseCommand game) $ verbose_runCommandErrors game . getBlind - -prop_orphanChooseCommandErrorsWhenCallerDoesNotExist :: GameAtOrphansTurn -> Player -> Property -prop_orphanChooseCommandErrorsWhenCallerDoesNotExist (GameAtOrphansTurn game) caller = - forAll (arbitraryPlayer game) $ \target -> do - let command = Orphan.chooseCommand (caller ^. name) (target ^. name) - - not (doesPlayerExist (caller ^. name) game) - ==> verbose_runCommandErrors game command - -prop_orphanChooseCommandErrorsWhenTargetDoesNotExist :: GameAtOrphansTurn -> Player -> Property -prop_orphanChooseCommandErrorsWhenTargetDoesNotExist (GameAtOrphansTurn game) target = do - let orphan = game ^?! players . orphans - let command = Orphan.chooseCommand (orphan ^. name) (target ^. name) - - not (doesPlayerExist (target ^. name) game) - ==> verbose_runCommandErrors game command - -prop_orphanChooseCommandErrorsWhenCallerIsDead :: GameAtOrphansTurn -> Property -prop_orphanChooseCommandErrorsWhenCallerIsDead (GameAtOrphansTurn game) = do - let orphan = game ^?! players . orphans - let game' = killPlayer (orphan ^. name) game - - forAll (arbitraryPlayer game') $ \target -> do - let command = Orphan.chooseCommand (orphan ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_orphanChooseCommandErrorsWhenTargetIsDead :: GameAtOrphansTurn -> Property -prop_orphanChooseCommandErrorsWhenTargetIsDead (GameAtOrphansTurn game) = do - let orphan = game ^?! players . orphans - - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = Orphan.chooseCommand (orphan ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_orphanChooseCommandErrorsWhenTargetIsCaller :: GameAtOrphansTurn -> Property -prop_orphanChooseCommandErrorsWhenTargetIsCaller (GameAtOrphansTurn game) = do - let orphan = game ^?! players . orphans - let command = Orphan.chooseCommand (orphan ^. name) (orphan ^. name) - - verbose_runCommandErrors game command - -prop_orphanChooseCommandErrorsWhenNotOrphansTurn :: Game -> Property -prop_orphanChooseCommandErrorsWhenNotOrphansTurn game = - hasn't (stage . _OrphansTurn) game - ==> forAll (arbitraryOrphanChooseCommand game) $ verbose_runCommandErrors game . getBlind - -prop_orphanChooseCommandErrorsWhenCallerNotOrphan :: GameAtOrphansTurn -> Property -prop_orphanChooseCommandErrorsWhenCallerNotOrphan (GameAtOrphansTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't orphan)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = Orphan.chooseCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_scapegoatChooseCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_scapegoatChooseCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryScapegoatChooseCommand game) $ verbose_runCommandErrors game . getBlind - -prop_scapegoatChooseCommandErrorsWhenCallerDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property -prop_scapegoatChooseCommandErrorsWhenCallerDoesNotExist (GameAtScapegoatsTurn game) caller = - forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do - let command = Scapegoat.chooseCommand (caller ^. name) (targets ^.. names) - - not (doesPlayerExist (caller ^. name) game) - ==> verbose_runCommandErrors game command - -prop_scapegoatChooseCommandErrorsWhenAnyTargetDoesNotExist :: GameAtScapegoatsTurn -> Player -> Property -prop_scapegoatChooseCommandErrorsWhenAnyTargetDoesNotExist (GameAtScapegoatsTurn game) target = do - let scapegoat = game ^?! players . scapegoats - let command = Scapegoat.chooseCommand (scapegoat ^. name) [target ^. name] - - not (doesPlayerExist (target ^. name) game) - ==> verbose_runCommandErrors game command - -prop_scapegoatChooseCommandErrorsWhenAnyTargetIsDead :: GameAtScapegoatsTurn -> Property -prop_scapegoatChooseCommandErrorsWhenAnyTargetIsDead (GameAtScapegoatsTurn game) = do - let scapegoat = game ^?! players . scapegoats - - forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> - forAll (elements targets) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = Scapegoat.chooseCommand (scapegoat ^. name) (targets ^.. names) - - verbose_runCommandErrors game' command - -prop_scapegoatChooseCommandErrorsWhenNotScapegoatsTurn :: Game -> Property -prop_scapegoatChooseCommandErrorsWhenNotScapegoatsTurn game = - hasn't (stage . _ScapegoatsTurn) game - ==> forAll (arbitraryScapegoatChooseCommand game) $ verbose_runCommandErrors game . getBlind - -prop_scapegoatChooseCommandErrorsWhenCallerNotScapegoat :: GameAtScapegoatsTurn -> Property -prop_scapegoatChooseCommandErrorsWhenCallerNotScapegoat (GameAtScapegoatsTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't scapegoat)) $ \caller -> - forAll (NonEmpty <$> sublistOf (game ^.. players . traverse . alive)) $ \(NonEmpty targets) -> do - let command = Scapegoat.chooseCommand (caller ^. name) (targets ^.. names) - - verbose_runCommandErrors game command diff --git a/test/src/Game/Werewolf/Test/Command/Heal.hs b/test/src/Game/Werewolf/Test/Command/Heal.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Heal.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Heal -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.Heal ( - -- * Tests - allHealCommandTests, -) where - -import Control.Lens hiding (isn't) -import Control.Lens.Extra - -import Game.Werewolf -import Game.Werewolf.Command.Witch -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allHealCommandTests :: [TestTree] -allHealCommandTests = - [ testProperty "heal command errors when game is over" prop_healCommandErrorsWhenGameIsOver - , testProperty "heal command errors when caller does not exist" prop_healCommandErrorsWhenCallerDoesNotExist - , testProperty "heal command errors when caller is dead" prop_healCommandErrorsWhenCallerIsDead - , testProperty "heal command errors when no target is devoured" prop_healCommandErrorsWhenNoTargetIsDevoured - , testProperty "heal command errors when not witch's turn" prop_healCommandErrorsWhenNotWitchsTurn - , testProperty "heal command errors when caller has healed" prop_healCommandErrorsWhenCallerHasHealed - , testProperty "heal command errors when caller not witch" prop_healCommandErrorsWhenCallerNotWitch - ] - -prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = verbose_runHealCommandErrors game - -prop_healCommandErrorsWhenCallerDoesNotExist :: GameWithDevourEvent -> Player -> Property -prop_healCommandErrorsWhenCallerDoesNotExist (GameWithDevourEvent game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> verbose_runCommandErrors game (healCommand (caller ^. name)) - -prop_healCommandErrorsWhenCallerIsDead :: GameWithDevourEvent -> Property -prop_healCommandErrorsWhenCallerIsDead (GameWithDevourEvent game) = - forAll (arbitraryPlayer game) $ \caller -> do - let game' = killPlayer (caller ^. name) game - let command = healCommand (caller ^. name) - - verbose_runCommandErrors game' command - -prop_healCommandErrorsWhenNoTargetIsDevoured :: GameAtWitchsTurn -> Property -prop_healCommandErrorsWhenNoTargetIsDevoured (GameAtWitchsTurn game) = verbose_runHealCommandErrors game - -prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property -prop_healCommandErrorsWhenNotWitchsTurn game = - hasn't (stage . _WitchsTurn) game - ==> verbose_runHealCommandErrors game - -prop_healCommandErrorsWhenCallerHasHealed :: GameWithHeal -> Property -prop_healCommandErrorsWhenCallerHasHealed (GameWithHeal game) = verbose_runHealCommandErrors game - -prop_healCommandErrorsWhenCallerNotWitch :: GameWithDevourEvent -> Property -prop_healCommandErrorsWhenCallerNotWitch (GameWithDevourEvent game) = - forAll (suchThat (arbitraryPlayer game) (isn't witch)) $ \caller -> do - let command = healCommand (caller ^. name) - - verbose_runCommandErrors game command - -verbose_runHealCommandErrors :: Game -> Property -verbose_runHealCommandErrors game = do - let witch = game ^?! players . witches - let command = healCommand $ witch ^. name - - verbose_runCommandErrors game command diff --git a/test/src/Game/Werewolf/Test/Command/Pass.hs b/test/src/Game/Werewolf/Test/Command/Pass.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Pass.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Pass -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.Pass ( - -- * Tests - allPassCommandTests, -) where - -import Control.Lens hiding (isn't) - -import Game.Werewolf -import Game.Werewolf.Command.Witch -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allPassCommandTests :: [TestTree] -allPassCommandTests = - [ testProperty "witch pass command errors when game is over" prop_witchPassCommandErrorsWhenGameIsOver - , testProperty "witch pass command errors when caller does not exist" prop_witchPassCommandErrorsWhenCallerDoesNotExist - , testProperty "witch pass command errors when caller is dead" prop_witchPassCommandErrorsWhenCallerIsDead - , testProperty "witch pass command errors when not witch's turn" prop_witchPassCommandErrorsWhenNotWitchsTurn - ] - -prop_witchPassCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_witchPassCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind - -prop_witchPassCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property -prop_witchPassCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> verbose_runCommandErrors game (passCommand $ caller ^. name) - -prop_witchPassCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property -prop_witchPassCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do - let witchsName = game ^?! players . witches . name - let game' = killPlayer witchsName game - let command = passCommand witchsName - - verbose_runCommandErrors game' command - -prop_witchPassCommandErrorsWhenNotWitchsTurn :: Game -> Property -prop_witchPassCommandErrorsWhenNotWitchsTurn game = - hasn't (stage . _WitchsTurn) game - ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind diff --git a/test/src/Game/Werewolf/Test/Command/Poison.hs b/test/src/Game/Werewolf/Test/Command/Poison.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Poison.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Poison -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.Poison ( - -- * Tests - allPoisonCommandTests, -) where - -import Control.Lens hiding (isn't) -import Control.Lens.Extra - -import Game.Werewolf -import Game.Werewolf.Command.Witch -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allPoisonCommandTests :: [TestTree] -allPoisonCommandTests = - [ testProperty "poison command errors when game is over" prop_poisonCommandErrorsWhenGameIsOver - , testProperty "poison command errors when caller does not exist" prop_poisonCommandErrorsWhenCallerDoesNotExist - , testProperty "poison command errors when target does not exist" prop_poisonCommandErrorsWhenTargetDoesNotExist - , testProperty "poison command errors when caller is dead" prop_poisonCommandErrorsWhenCallerIsDead - , testProperty "poison command errors when target is dead" prop_poisonCommandErrorsWhenTargetIsDead - , testProperty "poison command errors when target is devoured" prop_poisonCommandErrorsWhenTargetIsDevoured - , testProperty "poison command errors when not witch's turn" prop_poisonCommandErrorsWhenNotWitchsTurn - , testProperty "poison command errors when caller has poisoned" prop_poisonCommandErrorsWhenCallerHasPoisoned - , testProperty "poison command errors when caller not witch" prop_poisonCommandErrorsWhenCallerNotWitch - ] - -prop_poisonCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_poisonCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind - -prop_poisonCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property -prop_poisonCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> forAll (arbitraryPlayer game) $ \target -> do - let command = poisonCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_poisonCommandErrorsWhenTargetDoesNotExist :: GameAtWitchsTurn -> Player -> Property -prop_poisonCommandErrorsWhenTargetDoesNotExist (GameAtWitchsTurn game) target = do - let witch = game ^?! players . witches - let command = poisonCommand (witch ^. name) (target ^. name) - - not (doesPlayerExist (target ^. name) game) - ==> verbose_runCommandErrors game command - -prop_poisonCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property -prop_poisonCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do - let witch = game ^?! players . witches - - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (witch ^. name) game - let command = poisonCommand (witch ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_poisonCommandErrorsWhenTargetIsDead :: GameAtWitchsTurn -> Property -prop_poisonCommandErrorsWhenTargetIsDead (GameAtWitchsTurn game) = do - let witch = game ^?! players . witches - - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = poisonCommand (witch ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_poisonCommandErrorsWhenTargetIsDevoured :: GameWithDevourEvent -> Property -prop_poisonCommandErrorsWhenTargetIsDevoured (GameWithDevourEvent game) = do - let witchsName = game ^?! players . witches . name - let targetName = game ^?! events . traverse . _DevourEvent - let command = poisonCommand witchsName targetName - - verbose_runCommandErrors game command - -prop_poisonCommandErrorsWhenNotWitchsTurn :: Game -> Property -prop_poisonCommandErrorsWhenNotWitchsTurn game = - hasn't (stage . _WitchsTurn) game - ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind - -prop_poisonCommandErrorsWhenCallerHasPoisoned :: GameWithPoison -> Property -prop_poisonCommandErrorsWhenCallerHasPoisoned (GameWithPoison game) = do - let witch = game ^?! players . witches - - forAll (arbitraryPlayer game) $ \target -> do - let command = poisonCommand (witch ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_poisonCommandErrorsWhenCallerNotWitch :: GameAtWitchsTurn -> Property -prop_poisonCommandErrorsWhenCallerNotWitch (GameAtWitchsTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't witch)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = poisonCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command diff --git a/test/src/Game/Werewolf/Test/Command/Protect.hs b/test/src/Game/Werewolf/Test/Command/Protect.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Protect.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Protect -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.Protect ( - -- * Tests - allProtectCommandTests, -) where - -import Control.Lens hiding (isn't) -import Control.Lens.Extra - -import Data.Maybe - -import Game.Werewolf -import Game.Werewolf.Command.Protector -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allProtectCommandTests :: [TestTree] -allProtectCommandTests = - [ testProperty "protect command errors when game is over" prop_protectCommandErrorsWhenGameIsOver - , testProperty "protect command errors when caller does not exist" prop_protectCommandErrorsWhenCallerDoesNotExist - , testProperty "protect command errors when target does not exist" prop_protectCommandErrorsWhenTargetDoesNotExist - , testProperty "protect command errors when caller is dead" prop_protectCommandErrorsWhenCallerIsDead - , testProperty "protect command errors when target is dead" prop_protectCommandErrorsWhenTargetIsDead - , testProperty "protect command errors when not protector's turn" prop_protectCommandErrorsWhenNotProtectorsTurn - , testProperty "protect command errors when caller not protector" prop_protectCommandErrorsWhenCallerNotProtector - , testProperty "protect command errors when target is prior protect" prop_protectCommandErrorsWhenTargetIsPriorProtect - ] - -prop_protectCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_protectCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind - -prop_protectCommandErrorsWhenCallerDoesNotExist :: GameAtProtectorsTurn -> Player -> Property -prop_protectCommandErrorsWhenCallerDoesNotExist (GameAtProtectorsTurn game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> forAll (arbitraryPlayer game) $ \target -> do - let command = protectCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_protectCommandErrorsWhenTargetDoesNotExist :: GameAtProtectorsTurn -> Player -> Property -prop_protectCommandErrorsWhenTargetDoesNotExist (GameAtProtectorsTurn game) target = do - let protector = game ^?! players . protectors - let command = protectCommand (protector ^. name) (target ^. name) - - not (doesPlayerExist (target ^. name) game) - ==> verbose_runCommandErrors game command - -prop_protectCommandErrorsWhenCallerIsDead :: GameAtProtectorsTurn -> Property -prop_protectCommandErrorsWhenCallerIsDead (GameAtProtectorsTurn game) = do - let protector = game ^?! players . protectors - let game' = killPlayer (protector ^. name) game - - forAll (arbitraryPlayer game') $ \target -> do - let command = protectCommand (protector ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_protectCommandErrorsWhenTargetIsDead :: GameAtProtectorsTurn -> Property -prop_protectCommandErrorsWhenTargetIsDead (GameAtProtectorsTurn game) = do - let protector = game ^?! players . protectors - - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = protectCommand (protector ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_protectCommandErrorsWhenNotProtectorsTurn :: Game -> Property -prop_protectCommandErrorsWhenNotProtectorsTurn game = - hasn't (stage . _ProtectorsTurn) game - ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind - -prop_protectCommandErrorsWhenCallerNotProtector :: GameAtProtectorsTurn -> Property -prop_protectCommandErrorsWhenCallerNotProtector (GameAtProtectorsTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't protector)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = protectCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_protectCommandErrorsWhenTargetIsPriorProtect :: GameWithProtect -> Property -prop_protectCommandErrorsWhenTargetIsPriorProtect (GameWithProtect game) = do - let game' = game & protect .~ Nothing - - let protector = game ^?! players . protectors - let command = protectCommand (protector ^. name) (fromJust $ game' ^. priorProtect) - - verbose_runCommandErrors game' command diff --git a/test/src/Game/Werewolf/Test/Command/Quit.hs b/test/src/Game/Werewolf/Test/Command/Quit.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Quit.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Quit -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.Quit ( - -- * Tests - allQuitCommandTests, -) where - -import Control.Lens - -import Game.Werewolf -import Game.Werewolf.Command.Global -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allQuitCommandTests :: [TestTree] -allQuitCommandTests = - [ testProperty "quit command errors when game is over" prop_quitCommandErrorsWhenGameIsOver - , testProperty "quit command errors when caller does not exist" prop_quitCommandErrorsWhenCallerDoesNotExist - , testProperty "quit command errors when caller is dead" prop_quitCommandErrorsWhenCallerIsDead - ] - -prop_quitCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_quitCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game . getBlind - -prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_quitCommandErrorsWhenCallerDoesNotExist game caller = - not (doesPlayerExist (caller ^. name) game) - ==> verbose_runCommandErrors game (quitCommand $ caller ^. name) - -prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property -prop_quitCommandErrorsWhenCallerIsDead game = - forAll (arbitraryPlayer game) $ \caller -> do - let game' = killPlayer (caller ^. name) game - let command = quitCommand $ caller ^. name - - verbose_runCommandErrors game' command diff --git a/test/src/Game/Werewolf/Test/Command/See.hs b/test/src/Game/Werewolf/Test/Command/See.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/See.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.See -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.See ( - -- * Tests - allSeeCommandTests, -) where - -import Control.Lens hiding (isn't) -import Control.Lens.Extra - -import Game.Werewolf -import Game.Werewolf.Command.Seer -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allSeeCommandTests :: [TestTree] -allSeeCommandTests = - [ testProperty "see command errors when game is over" prop_seeCommandErrorsWhenGameIsOver - , testProperty "see command errors when caller does not exist" prop_seeCommandErrorsWhenCallerDoesNotExist - , testProperty "see command errors when target does not exist" prop_seeCommandErrorsWhenTargetDoesNotExist - , testProperty "see command errors when caller is dead" prop_seeCommandErrorsWhenCallerIsDead - , testProperty "see command errors when target is dead" prop_seeCommandErrorsWhenTargetIsDead - , testProperty "see command errors when not seer's turn" prop_seeCommandErrorsWhenNotSeersTurn - , testProperty "see command errors when caller not seer" prop_seeCommandErrorsWhenCallerNotSeer - ] - -prop_seeCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_seeCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind - -prop_seeCommandErrorsWhenCallerDoesNotExist :: GameAtSeersTurn -> Player -> Property -prop_seeCommandErrorsWhenCallerDoesNotExist (GameAtSeersTurn game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> forAll (arbitraryPlayer game) $ \target -> do - let command = seeCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_seeCommandErrorsWhenTargetDoesNotExist :: GameAtSeersTurn -> Player -> Property -prop_seeCommandErrorsWhenTargetDoesNotExist (GameAtSeersTurn game) target = do - let seer = game ^?! players . seers - let command = seeCommand (seer ^. name) (target ^. name) - - not (doesPlayerExist (target ^. name) game) - ==> verbose_runCommandErrors game command - -prop_seeCommandErrorsWhenCallerIsDead :: GameAtSeersTurn -> Property -prop_seeCommandErrorsWhenCallerIsDead (GameAtSeersTurn game) = do - let seer = game ^?! players . seers - let game' = killPlayer (seer ^. name) game - - forAll (arbitraryPlayer game') $ \target -> do - let command = seeCommand (seer ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_seeCommandErrorsWhenTargetIsDead :: GameAtSeersTurn -> Property -prop_seeCommandErrorsWhenTargetIsDead (GameAtSeersTurn game) = do - let seer = game ^?! players . seers - - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = seeCommand (seer ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property -prop_seeCommandErrorsWhenNotSeersTurn game = - hasn't (stage . _SeersTurn) game - ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind - -prop_seeCommandErrorsWhenCallerNotSeer :: GameAtSeersTurn -> Property -prop_seeCommandErrorsWhenCallerNotSeer (GameAtSeersTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't seer)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = seeCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command diff --git a/test/src/Game/Werewolf/Test/Command/Vote.hs b/test/src/Game/Werewolf/Test/Command/Vote.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Command/Vote.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Command.Vote -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Command.Vote ( - -- * Tests - allVoteCommandTests, -) where - -import Control.Lens hiding (isn't) -import Control.Lens.Extra - -import Game.Werewolf -import Game.Werewolf.Command.Villager as Villager -import Game.Werewolf.Command.Werewolf as Werewolf -import Game.Werewolf.Test.Arbitrary -import Game.Werewolf.Test.Util - -import Test.Tasty -import Test.Tasty.QuickCheck - -allVoteCommandTests :: [TestTree] -allVoteCommandTests = - [ testProperty "werewolf vote command errors when game is over" prop_werewolfVoteCommandErrorsWhenGameIsOver - , testProperty "werewolf vote command errors when caller does not exist" prop_werewolfVoteCommandErrorsWhenCallerDoesNotExist - , testProperty "werewolf vote command errors when target does not exist" prop_werewolfVoteCommandErrorsWhenTargetDoesNotExist - , testProperty "werewolf vote command errors when caller is dead" prop_werewolfVoteCommandErrorsWhenCallerIsDead - , testProperty "werewolf vote command errors when target is dead" prop_werewolfVoteCommandErrorsWhenTargetIsDead - , testProperty "werewolf vote command errors when not werewolves turn" prop_werewolfVoteCommandErrorsWhenNotWerewolvesTurn - , testProperty "werewolf vote command errors when caller not werewolf" prop_werewolfVoteCommandErrorsWhenCallerNotWerewolf - , testProperty "werewolf vote command errors when caller has voted" prop_werewolfVoteCommandErrorsWhenCallerHasVoted - , testProperty "werewolf vote command errors when target werewolf" prop_werewolfVoteCommandErrorsWhenTargetWerewolf - - , testProperty "villager vote command errors when game is over" prop_villagerVoteCommandErrorsWhenGameIsOver - , testProperty "villager vote command errors when caller does not exist" prop_villagerVoteCommandErrorsWhenCallerDoesNotExist - , testProperty "villager vote command errors when target does not exist" prop_villagerVoteCommandErrorsWhenTargetDoesNotExist - , testProperty "villager vote command errors when caller is dead" prop_villagerVoteCommandErrorsWhenCallerIsDead - , testProperty "villager vote command errors when target is dead" prop_villagerVoteCommandErrorsWhenTargetIsDead - , testProperty "villager vote command errors when not villages turn" prop_villagerVoteCommandErrorsWhenNotVillagesTurn - , testProperty "villager vote command errors when caller has voted" prop_villagerVoteCommandErrorsWhenCallerHasVoted - , testProperty "villager vote command errors when caller is not in allowed voters" prop_villagerVoteCommandErrorsWhenCallerIsNotInAllowedVoters - , testProperty "villager vote command errors when caller is known jester" prop_villagerVoteCommandErrorsWhenCallerIsKnownJester - ] - -prop_werewolfVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_werewolfVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryWerewolfVoteCommand game) $ verbose_runCommandErrors game . getBlind - -prop_werewolfVoteCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property -prop_werewolfVoteCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> forAll (arbitraryPlayer game) $ \target -> do - let command = Werewolf.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_werewolfVoteCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property -prop_werewolfVoteCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target = - not (doesPlayerExist (target ^. name) game) - ==> forAll (arbitraryWerewolf game) $ \caller -> do - let command = Werewolf.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_werewolfVoteCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property -prop_werewolfVoteCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) = - forAll (arbitraryWerewolf game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (caller ^. name) game - let command = Werewolf.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_werewolfVoteCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property -prop_werewolfVoteCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) = - forAll (arbitraryWerewolf game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = Werewolf.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_werewolfVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property -prop_werewolfVoteCommandErrorsWhenNotWerewolvesTurn game = - hasn't (stage . _WerewolvesTurn) game - ==> forAll (arbitraryWerewolfVoteCommand game) $ verbose_runCommandErrors game . getBlind - -prop_werewolfVoteCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property -prop_werewolfVoteCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) = - forAll (suchThat (arbitraryPlayer game) (isn't werewolf)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = Werewolf.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_werewolfVoteCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property -prop_werewolfVoteCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) = - forAll (arbitraryWerewolf game) $ \caller -> - forAll (suchThat (arbitraryPlayer game) (isn't werewolf)) $ \target -> do - let command = Werewolf.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_werewolfVoteCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property -prop_werewolfVoteCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) = - forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryWerewolf game) $ \target -> - verbose_runCommandErrors game (Werewolf.voteCommand (caller ^. name) (target ^. name)) - -prop_villagerVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property -prop_villagerVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) = - forAll (arbitraryVillagerVoteCommand game) $ verbose_runCommandErrors game . getBlind - -prop_villagerVoteCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property -prop_villagerVoteCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller = - not (doesPlayerExist (caller ^. name) game) - ==> forAll (arbitraryPlayer game) $ \target -> do - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_villagerVoteCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property -prop_villagerVoteCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target = - not (doesPlayerExist (target ^. name) game) - ==> forAll (arbitraryPlayer game) $ \caller -> do - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_villagerVoteCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property -prop_villagerVoteCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) = - forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (caller ^. name) game - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_villagerVoteCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property -prop_villagerVoteCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) = - forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer (target ^. name) game - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game' command - -prop_villagerVoteCommandErrorsWhenNotVillagesTurn :: Game -> Property -prop_villagerVoteCommandErrorsWhenNotVillagesTurn game = - hasn't (stage . _VillagesTurn) game - ==> forAll (arbitraryVillagerVoteCommand game) $ verbose_runCommandErrors game . getBlind - -prop_villagerVoteCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property -prop_villagerVoteCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) = - forAll (arbitraryPlayer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - -prop_villagerVoteCommandErrorsWhenCallerIsNotInAllowedVoters :: GameWithAllowedVoters -> Property -prop_villagerVoteCommandErrorsWhenCallerIsNotInAllowedVoters (GameWithAllowedVoters game) = - forAll (suchThat (arbitraryPlayer game') (`notElem` getAllowedVoters game')) $ \caller -> - forAll (arbitraryPlayer game') $ \target -> do - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game' command - where - game' = run_ checkStage game - -prop_villagerVoteCommandErrorsWhenCallerIsKnownJester :: GameWithJesterRevealedAtVillagesTurn -> Property -prop_villagerVoteCommandErrorsWhenCallerIsKnownJester (GameWithJesterRevealedAtVillagesTurn game) = - forAll (arbitraryPlayer game) $ \target -> do - let command = Villager.voteCommand (caller ^. name) (target ^. name) - - verbose_runCommandErrors game command - where - caller = game ^?! players . jesters diff --git a/test/src/Game/Werewolf/Test/Engine.hs b/test/src/Game/Werewolf/Test/Engine.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Engine.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Engine -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -{-# LANGUAGE OverloadedStrings #-} - -module Game.Werewolf.Test.Engine ( - -- * Tests - allEngineTests, -) where - -import Control.Lens hiding (elements) -import Control.Lens.Extra -import Control.Monad.Except -import Control.Monad.Writer - -import Data.Either.Extra - -import Game.Werewolf -import Game.Werewolf.Test.Arbitrary () - -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.QuickCheck - -allEngineTests :: [TestTree] -allEngineTests = - [ testProperty "start game errors unless unique player names" prop_startGameErrorsUnlessUniquePlayerNames - , testProperty "start game errors when less than 7 players" prop_startGameErrorsWhenLessThan7Players - , testProperty "start game errors when more than 1 of a restricted role" prop_startGameErrorsWhenMoreThan1OfARestrictedRole - ] - -prop_startGameErrorsUnlessUniquePlayerNames :: Game -> Property -prop_startGameErrorsUnlessUniquePlayerNames game = - forAll (elements players') $ \player -> - isLeft (runExcept . runWriterT $ startGame "" (player:players')) - where - players' = game ^. players - -prop_startGameErrorsWhenLessThan7Players :: [Player] -> Property -prop_startGameErrorsWhenLessThan7Players players = once $ - length players < 7 - ==> isLeft . runExcept . runWriterT $ startGame "" players - -prop_startGameErrorsWhenMoreThan1OfARestrictedRole :: [Player] -> Property -prop_startGameErrorsWhenMoreThan1OfARestrictedRole players = - any (\role' -> length (players ^.. traverse . filteredBy role role') > 1) restrictedRoles - ==> isLeft . runExcept . runWriterT $ startGame "" players diff --git a/test/src/Game/Werewolf/Test/Util.hs b/test/src/Game/Werewolf/Test/Util.hs deleted file mode 100644 --- a/test/src/Game/Werewolf/Test/Util.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-| -Module : Game.Werewolf.Test.Util -Copyright : (c) Henry J. Wylde, 2016 -License : BSD3 -Maintainer : public@hjwylde.com --} - -module Game.Werewolf.Test.Util ( - -- * Utility functions - run, run_, verbose_runCommandErrors, -) where - -import Control.Monad.Except -import Control.Monad.Random -import Control.Monad.State hiding (State) -import Control.Monad.Writer - -import Data.Either.Extra - -import Game.Werewolf - -import Test.QuickCheck - -run :: StateT Game (WriterT [Message] (ExceptT [Message] (Rand StdGen))) a -> Game -> Either [Message] (Game, [Message]) -run action game = evalRand (runExceptT . runWriterT $ execStateT action game) (mkStdGen 0) - -run_ :: StateT Game (WriterT [Message] (ExceptT [Message] (Rand StdGen))) a -> Game -> Game -run_ action = fst . fromRight . run action - -verbose_runCommandErrors :: Game -> Command -> Property -verbose_runCommandErrors game command = whenFail (mapM_ putStrLn data_) (isLeft result) - where - result = run (apply command) game - data_ = [show game, show $ fromRight result] diff --git a/werewolf.cabal b/werewolf.cabal --- a/werewolf.cabal +++ b/werewolf.cabal @@ -1,5 +1,5 @@ name: werewolf -version: 1.0.2.2 +version: 1.1.0.0 author: Henry J. Wylde maintainer: public@hjwylde.com @@ -9,7 +9,7 @@ description: A game engine for playing werewolf within an arbitrary chat client. Werewolf is a well known social party game, commonly also called Mafia. See the for a - rundown on it's gameplay and history. + rundown on its gameplay and history. license: BSD3 license-file: LICENSE @@ -29,10 +29,26 @@ hs-source-dirs: app/ ghc-options: -threaded -with-rtsopts=-N other-modules: + Game.Werewolf.Command + Game.Werewolf.Command.Global + Game.Werewolf.Command.Hunter + Game.Werewolf.Command.Oracle + Game.Werewolf.Command.Orphan + Game.Werewolf.Command.Protector + Game.Werewolf.Command.Scapegoat + Game.Werewolf.Command.Seer + Game.Werewolf.Command.Status + Game.Werewolf.Command.Villager + Game.Werewolf.Command.Werewolf + Game.Werewolf.Command.Witch + Game.Werewolf.Engine + Game.Werewolf.Messages + Game.Werewolf.Util Paths_werewolf Werewolf.Command.Boot Werewolf.Command.Choose Werewolf.Command.Circle + Werewolf.Command.Divine Werewolf.Command.End Werewolf.Command.Heal Werewolf.Command.Help @@ -45,21 +61,24 @@ Werewolf.Command.See Werewolf.Command.Start Werewolf.Command.Status + Werewolf.Command.Unvote Werewolf.Command.Version Werewolf.Command.Vote - Werewolf.Game Werewolf.Messages Werewolf.Options + Werewolf.System Werewolf.Version default-language: Haskell2010 other-extensions: FlexibleContexts, MultiParamTypeClasses, - OverloadedStrings + OverloadedStrings, + Rank2Types build-depends: aeson >= 0.8 && < 0.12, base >= 4.8 && < 5, + containers == 0.5.*, directory == 1.2.*, extra == 1.4.*, filepath == 1.4.*, @@ -78,32 +97,16 @@ Control.Lens.Extra Data.String.Humanise Game.Werewolf - Game.Werewolf.Command - Game.Werewolf.Command.Global - Game.Werewolf.Command.Hunter - Game.Werewolf.Command.Orphan - Game.Werewolf.Command.Protector - Game.Werewolf.Command.Scapegoat - Game.Werewolf.Command.Seer - Game.Werewolf.Command.Status - Game.Werewolf.Command.Villager - Game.Werewolf.Command.Werewolf - Game.Werewolf.Command.Witch - Game.Werewolf.Engine Game.Werewolf.Game Game.Werewolf.Player Game.Werewolf.Response Game.Werewolf.Role - other-modules: - Game.Werewolf.Messages - Game.Werewolf.Util default-language: Haskell2010 other-extensions: CPP, DeriveGeneric, FlexibleContexts, - MultiParamTypeClasses, OverloadedStrings, Rank2Types, TemplateHaskell @@ -111,46 +114,8 @@ aeson >= 0.8 && < 0.12, base >= 4.8 && < 5, containers == 0.5.*, - directory == 1.2.*, extra == 1.4.*, - filepath == 1.4.*, lens >= 4.12 && < 4.15, - MonadRandom == 0.4.*, mtl == 2.2.*, text == 1.2.*, transformers == 0.4.* - -test-suite werewolf-test - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/app/, test/src/ - ghc-options: -threaded -with-rtsopts=-N - other-modules: - Game.Werewolf.Test.Arbitrary - Game.Werewolf.Test.Command - Game.Werewolf.Test.Command.Choose - Game.Werewolf.Test.Command.Heal - Game.Werewolf.Test.Command.Pass - Game.Werewolf.Test.Command.Poison - Game.Werewolf.Test.Command.Protect - Game.Werewolf.Test.Command.Quit - Game.Werewolf.Test.Command.See - Game.Werewolf.Test.Command.Vote - Game.Werewolf.Test.Engine - Game.Werewolf.Test.Util - - default-language: Haskell2010 - other-extensions: - OverloadedStrings - build-depends: - base >= 4.8 && < 5, - containers == 0.5.*, - extra == 1.4.*, - lens >= 4.12 && < 4.15, - MonadRandom == 0.4.*, - mtl == 2.2.*, - QuickCheck == 2.8.*, - tasty >= 0.10 && < 0.12, - tasty-quickcheck == 0.8.*, - text == 1.2.*, - werewolf