module Game.Werewolf.Command (
Command(..),
bootCommand, chooseAllegianceCommand, choosePlayerCommand, choosePlayersCommand, circleCommand,
healCommand, noopCommand, passDevotedServantsTurnCommand, passWitchsTurnCommand, pingCommand,
poisonCommand, protectCommand, quitCommand, revealCommand, seeCommand, statusCommand,
voteDevourCommand, voteLynchCommand,
) 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 qualified Data.Text as T
import Game.Werewolf.Game hiding (doesPlayerExist, getPendingVoters, getVoteResult,
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
data Command = Command { apply :: forall m . (MonadError [Message] m, MonadState Game m, MonadWriter [Message] m) => m () }
bootCommand :: Text -> Text -> Command
bootCommand callerName targetName = Command $ do
validatePlayer callerName callerName
validatePlayer callerName targetName
whenM (uses (boots . at targetName) $ elem callerName . maybe [] id) $
throwError [playerHasAlreadyVotedToBootMessage callerName targetName]
boots %= Map.insertWith (++) targetName [callerName]
tell [playerVotedToBootMessage callerName targetName]
chooseAllegianceCommand :: Text -> Text -> Command
chooseAllegianceCommand callerName allegianceName = Command $ do
validatePlayer callerName callerName
unlessM (isPlayerWolfHound callerName) $ throwError [playerCannotDoThatMessage callerName]
unlessM isWolfHoundsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]
when (isNothing mAllegiance) $ throwError [allegianceDoesNotExistMessage callerName allegianceName]
allegianceChosen .= mAllegiance
where
mAllegiance = case T.toLower allegianceName of
"villagers" -> Just Villagers
"werewolves" -> Just Werewolves
_ -> Nothing
choosePlayerCommand :: Text -> Text -> Command
choosePlayerCommand callerName targetName = Command $ do
validatePlayer callerName callerName
unlessM (isPlayerWildChild callerName) $ throwError [playerCannotDoThatMessage callerName]
unlessM isWildChildsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]
when (callerName == targetName) $ throwError [playerCannotChooseSelfMessage callerName]
validatePlayer callerName targetName
roleModel .= Just targetName
choosePlayersCommand :: Text -> [Text] -> Command
choosePlayersCommand 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 villageIdiotRevealed &&^ anyM isPlayerVillageIdiot targetNames) $
throwError [playerCannotChooseVillageIdiotMessage callerName]
allowedVoters .= targetNames
scapegoatBlamed .= False
circleCommand :: Text -> Bool -> Command
circleCommand callerName includeDead = Command $ do
players' <- toListOf (players . traverse . if includeDead then id else alive) <$> get
tell [circleMessage callerName players']
healCommand :: Text -> Command
healCommand callerName = Command $ do
validateWitchsCommand callerName
whenM (use healUsed) $ throwError [playerHasAlreadyHealedMessage callerName]
whenM (hasn't (events . traverse . _DevourEvent) <$> get) $ throwError [playerCannotDoThatRightNowMessage callerName]
heal .= True
healUsed .= True
noopCommand :: Command
noopCommand = Command $ return ()
passDevotedServantsTurnCommand :: Text -> Command
passDevotedServantsTurnCommand callerName = Command $ do
validateDevotedServantsCommand callerName
passes %= nub . cons callerName
passWitchsTurnCommand :: Text -> Command
passWitchsTurnCommand callerName = Command $ do
validateWitchsCommand callerName
passes %= nub . cons callerName
pingCommand :: Text -> Command
pingCommand callerName = Command $ use stage >>= \stage' -> case stage' of
DefendersTurn -> do
defender <- findPlayerBy_ role defenderRole
tell [pingRoleMessage $ defenderRole ^. Role.name]
tell [pingPlayerMessage $ defender ^. name]
DevotedServantsTurn -> do
devotedServant <- findPlayerBy_ role devotedServantRole
tell [pingRoleMessage $ devotedServantRole ^. Role.name]
tell [pingPlayerMessage $ devotedServant ^. name]
GameOver -> tell [gameIsOverMessage callerName]
Lynching -> return ()
ScapegoatsTurn -> do
scapegoat <- findPlayerBy_ role scapegoatRole
tell [pingRoleMessage $ scapegoatRole ^. Role.name]
tell [pingPlayerMessage $ scapegoat ^. name]
SeersTurn -> do
seer <- findPlayerBy_ role seerRole
tell [pingRoleMessage $ seerRole ^. Role.name]
tell [pingPlayerMessage $ seer ^. name]
Sunrise -> return ()
Sunset -> return ()
UrsussGrunt -> return ()
VillagesTurn -> do
allowedVoterNames <- use allowedVoters
pendingVoterNames <- toListOf names <$> getPendingVoters
tell [waitingOnMessage Nothing $ allowedVoterNames `intersect` pendingVoterNames]
tell $ map pingPlayerMessage (allowedVoterNames `intersect` pendingVoterNames)
WerewolvesTurn -> do
pendingVoters <- getPendingVoters
tell [pingRoleMessage "Werewolves"]
tell $ map pingPlayerMessage (pendingVoters ^.. werewolves . name)
WildChildsTurn -> do
wildChild <- findPlayerBy_ role wildChildRole
tell [pingRoleMessage $ wildChildRole ^. Role.name]
tell [pingPlayerMessage $ wildChild ^. name]
WitchsTurn -> do
witch <- findPlayerBy_ role witchRole
tell [pingRoleMessage $ witchRole ^. Role.name]
tell [pingPlayerMessage $ witch ^. name]
WolfHoundsTurn -> do
wolfHound <- findPlayerBy_ role wolfHoundRole
tell [pingRoleMessage $ wolfHoundRole ^. Role.name]
tell [pingPlayerMessage $ wolfHound ^. name]
poisonCommand :: Text -> Text -> Command
poisonCommand callerName targetName = Command $ do
validateWitchsCommand 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
protectCommand :: Text -> Text -> Command
protectCommand callerName targetName = Command $ do
validatePlayer callerName callerName
unlessM (isPlayerDefender callerName) $ throwError [playerCannotDoThatMessage callerName]
unlessM isDefendersTurn $ throwError [playerCannotDoThatRightNowMessage callerName]
validatePlayer callerName targetName
whenM (has (priorProtect . traverse . only targetName) <$> get) $ throwError [playerCannotProtectSamePlayerTwiceInARowMessage callerName]
priorProtect .= Just targetName
protect .= Just targetName
quitCommand :: Text -> Command
quitCommand callerName = Command $ do
validatePlayer callerName callerName
caller <- findPlayerBy_ name callerName
tell [playerQuitMessage caller]
removePlayer callerName
revealCommand :: Text -> Command
revealCommand callerName = Command $ do
validateDevotedServantsCommand callerName
target <- head <$> getVoteResult
let targetRole = target ^. role
let targetName = target ^. name
setPlayerRole callerName targetRole
setPlayerRole targetName devotedServantRole
tell [devotedServantRevealedMessage callerName]
resetRole targetRole
where
resetRole role
| role == simpleWerewolfRole = do
aliveWerewolfNames <- toListOf (players . werewolves . alive . name) <$> get
tell $ devotedServantJoinedPackMessages callerName aliveWerewolfNames
| role == villageIdiotRole = villageIdiotRevealed .= False
| role == wildChildRole = roleModel .= Nothing
| role == witchRole = healUsed .= False >> poisonUsed .= False
| role == wolfHoundRole = allegianceChosen .= Nothing
| otherwise = return ()
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
statusCommand :: Text -> Command
statusCommand callerName = Command $ use stage >>= \stage' -> case stage' of
GameOver -> tell [gameIsOverMessage callerName]
Lynching -> return ()
Sunrise -> return ()
Sunset -> return ()
UrsussGrunt -> 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
]
voteDevourCommand :: Text -> Text -> Command
voteDevourCommand 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]]
voteLynchCommand :: Text -> Text -> Command
voteLynchCommand 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
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]
validateDevotedServantsCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m ()
validateDevotedServantsCommand callerName = do
validatePlayer callerName callerName
unlessM (isPlayerDevotedServant callerName) $ throwError [playerCannotDoThatMessage callerName]
unlessM isDevotedServantsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]
validateWitchsCommand :: (MonadError [Message] m, MonadState Game m) => Text -> m ()
validateWitchsCommand callerName = do
validatePlayer callerName callerName
unlessM (isPlayerWitch callerName) $ throwError [playerCannotDoThatMessage callerName]
unlessM isWitchsTurn $ throwError [playerCannotDoThatRightNowMessage callerName]