diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,12 +2,19 @@ #### Upcoming -#### v0.4.3.2 +#### v0.4.4.0 +*Minor* + +* Removed `playerHealedMessage` and replaced with the generic `noPlayerDevouredMessage`. ([#80](https://github.com/hjwylde/werewolf/issues/80)) +* Removed `playerProtectedMessage` and replaced with the generic `noPlayerDevouredMessage`. ([#80](https://github.com/hjwylde/werewolf/issues/80)) + *Revisions* -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) -* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82)) +* Privatised underscore methods and changed old uses to using lens. ([#20](https://github.com/hjwylde/werewolf/issues/20)) +* Tidied up arbitrary instances by using `newtype`'s. ([#78](https://github.com/hjwylde/werewolf/issues/78)) +* Fixed the `noPlayerDevouredMessage` to be displayed after sunrise. ([#80](https://github.com/hjwylde/werewolf/issues/80)) +* Removed `Show` instance for `Command` and used `Blind`. ([#78](https://github.com/hjwylde/werewolf/issues/78)) #### v0.4.3.1 @@ -21,13 +28,6 @@ * Added the Defender role. ([#38](https://github.com/hjwylde/werewolf/issues/38)) -#### v0.4.2.3 - -*Revisions* - -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) -* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82)) - #### v0.4.2.2 *Revisions* @@ -46,13 +46,6 @@ * Added the Villager-Villager role. ([#37](https://github.com/hjwylde/werewolf/issues/37)) -#### v0.4.1.3 - -*Revisions* - -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) -* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82)) - #### v0.4.1.2 *Revisions* @@ -70,12 +63,6 @@ *Minor* * Added the Witch role. ([#5](https://github.com/hjwylde/werewolf/issues/5)) - -#### v0.4.0.1 - -*Revisions* - -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83)) #### v0.4.0.0 diff --git a/app/Werewolf/Commands/Help.hs b/app/Werewolf/Commands/Help.hs --- a/app/Werewolf/Commands/Help.hs +++ b/app/Werewolf/Commands/Help.hs @@ -62,7 +62,7 @@ commandsMessages :: [Text] commandsMessages = [ "end - ends the current game." - , "heal - heal a devoured player." + , "heal PLAYER - heal a devoured player." , "pass - pass on healing or poisoning a player." , "ping - pings the status of the current game publicly." , "poison PLAYER - poison a player." diff --git a/app/Werewolf/Commands/Start.hs b/app/Werewolf/Commands/Start.hs --- a/app/Werewolf/Commands/Start.hs +++ b/app/Werewolf/Commands/Start.hs @@ -17,6 +17,7 @@ handle, ) where +import Control.Lens import Control.Monad.Except import Control.Monad.Extra import Control.Monad.State @@ -60,4 +61,4 @@ findByName :: Text -> Maybe Role -findByName name = find ((name ==) . T.toLower . _name) allRoles +findByName name' = find ((name' ==) . T.toLower . view name) allRoles diff --git a/src/Game/Werewolf/Command.hs b/src/Game/Werewolf/Command.hs --- a/src/Game/Werewolf/Command.hs +++ b/src/Game/Werewolf/Command.hs @@ -53,7 +53,7 @@ votes %= Map.insert callerName targetName - aliveWerewolfNames <- uses players $ map _name . filterAlive . filterWerewolves + aliveWerewolfNames <- uses players $ map (view name) . filterAlive . filterWerewolves tell $ map (\werewolfName -> playerMadeDevourVoteMessage werewolfName callerName targetName) (aliveWerewolfNames \\ [callerName]) @@ -107,12 +107,12 @@ pendingVoters <- getPendingVoters tell [waitingOnMessage Nothing pendingVoters] - tell $ map (pingPlayerMessage . _name) pendingVoters + tell $ map (pingPlayerMessage . view name) pendingVoters WerewolvesTurn -> do pendingVoters <- getPendingVoters tell [pingWerewolvesMessage] - tell $ map (pingPlayerMessage . _name) (filterWerewolves pendingVoters) + tell $ map (pingPlayerMessage . view name) (filterWerewolves pendingVoters) WitchsTurn -> do witch <- uses players $ head . filterWitches @@ -208,7 +208,7 @@ where standardStatusMessages stage players = currentStageMessages callerName stage ++ [ - rolesInGameMessage (Just callerName) $ map _role players, + rolesInGameMessage (Just callerName) $ map (view role) players, playersInGameMessage callerName players ] diff --git a/src/Game/Werewolf/Engine.hs b/src/Game/Werewolf/Engine.hs --- a/src/Game/Werewolf/Engine.hs +++ b/src/Game/Werewolf/Engine.hs @@ -67,7 +67,7 @@ import Game.Werewolf.Player hiding (doesPlayerExist) import qualified Game.Werewolf.Player as Player import Game.Werewolf.Response -import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Role hiding (name) import qualified Game.Werewolf.Role as Role import System.Directory @@ -125,9 +125,9 @@ getVoteResult >>= \votees -> case votees of [target] -> ifM (uses protect $ maybe False (== target ^. name)) - (events %= cons (ProtectEvent $ target ^. name)) + (events %= cons NoDevourEvent) (events %= cons (DevourEvent $ target ^. name)) - _ -> tell [noPlayerDevouredMessage] + _ -> events %= cons NoDevourEvent protect .= Nothing @@ -138,6 +138,12 @@ events %= (++ [PoisonEvent targetName]) poison .= Nothing + whenM (use heal) $ do + devourEvent <- uses events $ \events -> head [event | event@(DevourEvent _) <- events] + + events %= cons NoDevourEvent . delete devourEvent + heal .= False + witch <- uses players (head . filterWitches) whenM (use healUsed &&^ use poisonUsed) advanceStage @@ -149,7 +155,7 @@ stage' <- use stage alivePlayers <- uses players filterAlive - let nextStage = if length (nub $ map (_allegiance . _role) alivePlayers) <= 1 + let nextStage = if length (nub $ map (view $ role . allegiance) alivePlayers) <= 1 then GameOver else head $ filter (stageAvailable game) (drop1 $ dropWhile (stage' /=) stageCycle) @@ -169,33 +175,28 @@ mapM_ applyEvent available eventAvailable :: MonadState Game m => Event -> m Bool -eventAvailable (DevourEvent _) = gets isSunrise -eventAvailable (PoisonEvent _) = gets isSunrise -eventAvailable (ProtectEvent _) = gets isSunrise +eventAvailable (DevourEvent _) = gets isSunrise +eventAvailable NoDevourEvent = gets isSunrise +eventAvailable (PoisonEvent _) = gets isSunrise applyEvent :: (MonadState Game m, MonadWriter [Message] m) => Event -> m () applyEvent (DevourEvent targetName) = do - player <- uses players $ findByName_ targetName - heal' <- use heal + player <- uses players $ findByName_ targetName - if heal' - then tell [playerHealedMessage $ player ^. name] - else do - killPlayer player - tell [playerDevouredMessage player] + killPlayer player - heal .= False -applyEvent (PoisonEvent name) = do + tell [playerDevouredMessage player] +applyEvent NoDevourEvent = tell [noPlayerDevouredMessage] +applyEvent (PoisonEvent name) = do player <- uses players $ findByName_ name killPlayer player tell [playerPoisonedMessage player] -applyEvent (ProtectEvent name) = tell [playerProtectedMessage name] checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do - aliveAllegiances <- uses players $ nub . map (_allegiance . _role) . filterAlive + aliveAllegiances <- uses players $ nub . map (view $ role . allegiance) . filterAlive when (length aliveAllegiances <= 1) $ stage .= GameOver >> get >>= tell . gameOverMessages @@ -204,8 +205,9 @@ when (playerNames /= nub playerNames) $ throwError [privateMessage callerName "Player names must be unique."] when (length players < 7) $ throwError [privateMessage callerName "Must have at least 7 players."] when (length players > 24) $ throwError [privateMessage callerName "Cannot have more than 24 players."] - forM_ restrictedRoles $ \role -> - when (length (filter ((role ==) . _role) players) > 1) $ throwError [privateMessage callerName $ T.concat ["Cannot have more than 1 ", role ^. Role.name, "."]] + forM_ restrictedRoles $ \role' -> + when (length (filter ((role' ==) . view role) players) > 1) $ + throwError [privateMessage callerName $ T.concat ["Cannot have more than 1 ", role' ^. Role.name, "."]] let game = newGame players @@ -213,7 +215,7 @@ return game where - playerNames = map _name players + playerNames = map (view name) players restrictedRoles = [defenderRole, scapegoatRole, seerRole, villagerVillagerRole, witchRole] killPlayer :: MonadState Game m => Player -> m () @@ -297,8 +299,8 @@ randomiseRoles :: MonadIO m => [Role] -> Int -> m [Role] randomiseRoles extraRoles n = liftIO . evalRandIO . shuffleM $ extraRoles ++ werewolfRoles ++ villagerRoles where - extraWerewolfRoles = filter ((==) Role.Werewolves . _allegiance) extraRoles - extraVillagerRoles = filter ((==) Role.Villagers . _allegiance) extraRoles + extraWerewolfRoles = filter ((==) Role.Werewolves . view allegiance) extraRoles + extraVillagerRoles = filter ((==) Role.Villagers . view allegiance) extraRoles werewolfRoles = replicate (n `quot` 6 + 1 - length extraWerewolfRoles) werewolfRole villagerRoles = replicate (n - length (extraVillagerRoles ++ werewolfRoles)) villagerRole diff --git a/src/Game/Werewolf/Game.hs b/src/Game/Werewolf/Game.hs --- a/src/Game/Werewolf/Game.hs +++ b/src/Game/Werewolf/Game.hs @@ -13,7 +13,7 @@ module Game.Werewolf.Game ( -- * Game - Game(..), stage, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect, + Game, stage, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect, protect, see, votes, newGame, @@ -64,7 +64,7 @@ | WerewolvesTurn | WitchsTurn deriving (Eq, Read, Show) -data Event = DevourEvent Text | PoisonEvent Text | ProtectEvent Text +data Event = DevourEvent Text | NoDevourEvent | PoisonEvent Text deriving (Eq, Read, Show) makeLenses ''Game @@ -72,7 +72,7 @@ makeLenses ''Stage newGame :: [Player] -> Game -newGame players = game { _stage = head $ filter (stageAvailable game) stageCycle } +newGame players = game & stage .~ head (filter (stageAvailable game) stageCycle) where game = Game { _stage = Sunset @@ -126,7 +126,7 @@ getPlayerVote playerName game = game ^. votes . at playerName getPendingVoters :: Game -> [Player] -getPendingVoters game = filter (flip Map.notMember votes' . _name) alivePlayers +getPendingVoters game = filter (flip Map.notMember votes' . view name) alivePlayers where votes' = game ^. votes alivePlayers = filterAlive $ game ^. players @@ -151,7 +151,7 @@ stageAvailable _ VillagesTurn = True stageAvailable game WerewolvesTurn = any isWerewolf (filterAlive $ game ^. players) stageAvailable game WitchsTurn = - (any isWitch (filterAlive $ game ^. players)) + any isWitch (filterAlive $ game ^. players) && (not (game ^. healUsed) || not (game ^. poisonUsed)) getDevourEvent :: Game -> Maybe Event 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 @@ -13,7 +13,7 @@ module Game.Werewolf.Player ( -- * Player - Player(..), name, role, state, + Player, name, role, state, newPlayer, -- ** Searches @@ -40,7 +40,7 @@ import Data.Maybe import Data.Text (Text) -import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Role hiding (name) data Player = Player { _name :: Text @@ -57,7 +57,7 @@ newPlayer name role = Player name role Alive findByName :: Text -> [Player] -> Maybe Player -findByName name = find ((name ==) . _name) +findByName name' = find ((name' ==) . view name) findByName_ :: Text -> [Player] -> Player findByName_ name = fromJust . findByName name 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 @@ -40,9 +40,6 @@ -- ** Status messages currentStageMessages, rolesInGameMessage, playersInGameMessage, waitingOnMessage, - -- ** Defender's turn messages - playerProtectedMessage, - -- ** Seer's turn messages playerSeenMessage, @@ -54,7 +51,7 @@ playerMadeDevourVoteMessage, playerDevouredMessage, noPlayerDevouredMessage, -- ** Witch's turn messages - playerHealedMessage, playerPoisonedMessage, + playerPoisonedMessage, -- ** Generic error messages gameIsOverMessage, playerDoesNotExistMessage, playerCannotDoThatMessage, @@ -89,7 +86,7 @@ import Game.Werewolf.Game import Game.Werewolf.Player -import Game.Werewolf.Role (Allegiance (..), Role, allegiance, description, _allegiance) +import Game.Werewolf.Role (Allegiance (..), Role, allegiance, description) import qualified Game.Werewolf.Role as Role import GHC.Generics @@ -148,7 +145,7 @@ newGameMessages :: Game -> [Message] newGameMessages game = [ newPlayersInGameMessage players', - rolesInGameMessage Nothing $ map _role players' + rolesInGameMessage Nothing $ map (view role) players' ] ++ map (newPlayerMessage players') players' ++ villagerVillagerMessages ++ stageMessages game @@ -162,7 +159,7 @@ newPlayersInGameMessage :: [Player] -> Message newPlayersInGameMessage players = publicMessage $ T.concat [ "A new game of werewolf is starting with ", - T.intercalate ", " (map _name players), "!" + T.intercalate ", " (map (view name) players), "!" ] newPlayerMessage :: [Player] -> Player -> Message @@ -173,7 +170,7 @@ where packMessage | length (filterWerewolves players) <= 1 = "." - | otherwise = T.concat [", along with ", T.intercalate ", " (map _name $ filterWerewolves players \\ [player]), "."] + | otherwise = T.concat [", along with ", T.intercalate ", " (map (view name) $ filterWerewolves players \\ [player]), "."] villagerVillagerMessage :: Text -> Message villagerVillagerMessage name = publicMessage $ T.unwords [ @@ -186,12 +183,12 @@ stageMessages :: Game -> [Message] stageMessages game = case game ^. stage of GameOver -> [] - DefendersTurn -> defendersTurnMessages (_name . head . filterDefenders $ game ^. players) - SeersTurn -> seersTurnMessages (_name . head . filterSeers $ game ^. players) + DefendersTurn -> defendersTurnMessages (view name . head . filterDefenders $ game ^. players) + SeersTurn -> seersTurnMessages (view name . head . filterSeers $ game ^. players) Sunrise -> [sunriseMessage] Sunset -> [nightFallsMessage] VillagesTurn -> villagesTurnMessages - WerewolvesTurn -> werewolvesTurnMessages (map _name . filterAlive . filterWerewolves $ game ^. players) + WerewolvesTurn -> werewolvesTurnMessages (map (view name) . filterAlive . filterWerewolves $ game ^. players) WitchsTurn -> witchsTurnMessages game defendersTurnMessages :: Text -> [Message] @@ -245,15 +242,15 @@ gameOverMessages :: Game -> [Message] gameOverMessages game = case aliveAllegiances of - [allegiance] -> concat [ - [publicMessage $ T.unwords ["The game is over! The", T.pack $ show allegiance, "have won."]], - map (playerWonMessage . _name) (filter ((allegiance ==) . _allegiance . _role) players'), - map (playerLostMessage . _name) (filter ((allegiance /=) . _allegiance . _role) players') + [allegiance'] -> concat [ + [publicMessage $ T.unwords ["The game is over! The", T.pack $ show allegiance', "have won."]], + map (playerWonMessage . view name) (filter ((allegiance' ==) . view (role . allegiance)) players'), + map (playerLostMessage . view name) (filter ((allegiance' /=) . view (role . allegiance)) players') ] - _ -> publicMessage "The game is over! Everyone died...":map (playerLostMessage . _name) players' + _ -> publicMessage "The game is over! Everyone died...":map (playerLostMessage . view name) players' where players' = game ^. players - aliveAllegiances = nub $ map (_allegiance . _role) (filterAlive players') + aliveAllegiances = nub $ map (view $ role . allegiance) (filterAlive players') playerWonMessage :: Text -> Message playerWonMessage to = privateMessage to "Victory! You won!" @@ -283,19 +280,10 @@ currentStageMessages to GameOver = [gameIsOverMessage to] currentStageMessages _ Sunrise = [] currentStageMessages _ Sunset = [] + -- TODO (hjw): pluralise this correctly for the Seer currentStageMessages to turn = [privateMessage to $ T.concat [ - "It's currently the ", showTurn turn, " turn." + "It's currently the ", T.pack $ show turn, "' turn." ]] - where - showTurn :: Stage -> Text - showTurn DefendersTurn = "Defender's" - showTurn GameOver = undefined - showTurn SeersTurn = "Seer's" - showTurn Sunrise = undefined - showTurn Sunset = undefined - showTurn VillagesTurn = "Village's" - showTurn WerewolvesTurn = "Werewolves'" - showTurn WitchsTurn = "Witch's" rolesInGameMessage :: Maybe Text -> [Role] -> Message rolesInGameMessage mTo roles = Message mTo $ T.concat [ @@ -306,7 +294,7 @@ "." ] where - roleCounts = map (\list -> (head list, length list)) (groupSortOn Role._name roles) + roleCounts = map (\list -> (head list, length list)) (groupSortOn (view Role.name) roles) playersInGameMessage :: Text -> [Player] -> Message playersInGameMessage to players = privateMessage to . T.intercalate "\n" $ [ @@ -315,7 +303,7 @@ where alivePlayersText = T.concat [ "The following players are still alive: ", - T.intercalate ", " (map _name $ filterAlive players), "." + T.intercalate ", " (map (view name) $ filterAlive players), "." ] deadPlayersText = T.concat [ "The following players are dead: ", @@ -327,13 +315,7 @@ "Waiting on ", T.intercalate ", " playerNames, "..." ] where - playerNames = map _name players - -playerProtectedMessage :: Text -> Message -playerProtectedMessage name = publicMessage $ T.unwords - [ "As you emerge from your home you see", name, "outside waving a wolf paw around." - , "Some poor Werewolf must have tried to attack them while the Defender was on watch." - ] + playerNames = map (view name) players playerSeenMessage :: Text -> Player -> Message playerSeenMessage to target = privateMessage to $ T.concat [ @@ -388,13 +370,6 @@ noPlayerDevouredMessage = publicMessage $ T.unwords [ "Surprisingly you see everyone present at the town square.", "Perhaps the Werewolves have left Miller's Hollow?" - ] - -playerHealedMessage :: Text -> Message -playerHealedMessage name = publicMessage $ T.unwords [ - "As you open them you notice a door broken down and blood over the cobblestones.", - name, "hobbles over, clutching the bandages round their stomach.", - "The Witch must have seen their body and healed them..." ] playerPoisonedMessage :: Player -> Message 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 @@ -14,7 +14,7 @@ module Game.Werewolf.Role ( -- * Role - Role(..), name, allegiance, description, advice, + Role, name, allegiance, description, advice, -- ** Instances allRoles, defenderRole, scapegoatRole, seerRole, villagerRole, villagerVillagerRole, @@ -47,7 +47,7 @@ , _allegiance = Villagers , _description = T.unwords [ "A knight living in Miller's Hollow." - , "The Defender has the ability to protect one player each night." + , "The Defender has the ability to protect one player, except themself, each night." ] , _advice = "Be careful when you choose to protect someone, you cannot protect them 2 nights in a row." diff --git a/test/app/Main.hs b/test/app/Main.hs --- a/test/app/Main.hs +++ b/test/app/Main.hs @@ -75,6 +75,8 @@ , 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 + -- TODO (hjw) + --, testProperty "poison command errors when caller devoured and not healed" prop_poisonCommandErrorsWhenCallerDevouredAndNotHealed , testProperty "poison command sets poison" prop_poisonCommandSetsPoison , testProperty "poison command sets poison used" prop_poisonCommandSetsPoisonUsed @@ -121,8 +123,12 @@ , testProperty "check stage does nothing when game over" prop_checkStageDoesNothingWhenGameOver , testProperty "check defender's turn advances to werewolves' turn" prop_checkDefendersTurnAdvancesToWerewolvesTurn + -- TODO (hjw) + --, testProperty "check defender's turn advances when no defender" prop_checkDefendersTurnAdvancesWhenNoDefender , testProperty "check seer's turn advances to defender's turn" prop_checkSeersTurnAdvancesToDefendersTurn + -- TODO (hjw) + --, testProperty "check seer's turn advances when no seer" prop_checkSeersTurnAdvancesWhenNoSeer , testProperty "check seer's turn resets sees" prop_checkSeersTurnResetsSee , testProperty "check seer's turn does nothing unless seen" prop_checkSeersTurnDoesNothingUnlessSeen @@ -134,7 +140,6 @@ , testProperty "check villages' turn does nothing unless all voted" prop_checkVillagesTurnDoesNothingUnlessAllVoted , testProperty "check werewolves' turn advances to witch's turn" prop_checkWerewolvesTurnAdvancesToWitchsTurn - , testProperty "check werewolves' turn doesn't skip witch's turn when witch devoured" prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured , testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned , testProperty "check werewolves' turn kills one player when consensus" prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus , testProperty "check werewolves' turn kills no one when conflicted" prop_checkWerewolvesTurnKillsNoOneWhenConflicted @@ -144,6 +149,8 @@ , testProperty "check werewolves' turn does nothing unless all voted" prop_checkWerewolvesTurnDoesNothingUnlessAllVoted , testProperty "check witch's turn advances to villages' turn" prop_checkWitchsTurnAdvancesToVillagesTurn + -- TODO (hjw) + --, testProperty "check witch's turn advances when no witch" prop_checkWitchsTurnAdvancesWhenNoWitch , testProperty "check witch's turn heals devouree when healed" prop_checkWitchsTurnHealsDevoureeWhenHealed , testProperty "check witch's turn kills one player when poisoned" prop_checkWitchsTurnKillsOnePlayerWhenPoisoned , testProperty "check witch's turn does nothing when passed" prop_checkWitchsTurnDoesNothingWhenPassed diff --git a/test/src/Game/Werewolf/Test/Arbitrary.hs b/test/src/Game/Werewolf/Test/Arbitrary.hs --- a/test/src/Game/Werewolf/Test/Arbitrary.hs +++ b/test/src/Game/Werewolf/Test/Arbitrary.hs @@ -12,8 +12,10 @@ -- * Initial arbitraries -- ** Game - arbitraryNewGame, arbitraryGameWithDevourVotes, arbitraryGameWithDevourEventForVillager, - arbitraryGameWithProtect, arbitraryGameWithProtectAndDevourVotes, + GameAtDefendersTurn(..), GameAtGameOver(..), GameAtVillagesTurn(..), GameAtWerewolvesTurn(..), + GameAtWitchsTurn(..), GameAtSeersTurn(..), + GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..), GameWithLynchVotes(..), + GameWithPoison(..), GameWithProtect(..), GameWithProtectAndDevourVotes(..), GameWithSee(..), -- ** Player arbitraryPlayerSet, @@ -26,7 +28,7 @@ arbitrarySeeCommand, runArbitraryCommands, -- ** Player - arbitraryPlayer, arbitraryDefender, arbitrarySeer, arbitraryWerewolf, arbitraryWitch, + arbitraryPlayer, arbitraryWerewolf, ) where import Control.Lens hiding (elements) @@ -40,20 +42,17 @@ import Game.Werewolf.Engine (checkStage) import Game.Werewolf.Game import Game.Werewolf.Player -import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Role hiding (name) import Game.Werewolf.Test.Util import Test.QuickCheck -instance Show Command where - show _ = "command" - instance Arbitrary Game where arbitrary = do - game <- arbitraryNewGame - stage <- arbitrary + game <- newGame <$> arbitraryPlayerSet + stage' <- arbitrary - return $ game { _stage = stage } + return $ game & stage .~ stage' instance Arbitrary Stage where arbitrary = elements @@ -71,37 +70,145 @@ instance Arbitrary Text where arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) -arbitraryNewGame :: Gen Game -arbitraryNewGame = newGame <$> arbitraryPlayerSet +newtype GameAtDefendersTurn = GameAtDefendersTurn Game + deriving (Eq, Show) -arbitraryGameWithDevourVotes :: Gen Game -arbitraryGameWithDevourVotes = arbitrary >>= runArbitraryDevourVoteCommands +instance Arbitrary GameAtDefendersTurn where + arbitrary = do + game <- arbitrary -arbitraryGameWithDevourEvent :: Gen Game -arbitraryGameWithDevourEvent = do - game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) == 1 + return $ GameAtDefendersTurn (game & stage .~ DefendersTurn) - return $ run_ checkStage game +newtype GameAtGameOver = GameAtGameOver Game + deriving (Eq, Show) -arbitraryGameWithDevourEventForVillager :: Gen Game -arbitraryGameWithDevourEventForVillager = - suchThat arbitraryGameWithDevourEvent $ \game -> all isVillager (filterDead $ game ^. players) +instance Arbitrary GameAtGameOver where + arbitrary = do + game <- arbitrary -arbitraryGameWithProtect :: Gen Game -arbitraryGameWithProtect = do - game <- arbitrary - let game' = game { _stage = DefendersTurn } - command <- arbitraryProtectCommand game' + return $ GameAtGameOver (game & stage .~ GameOver) - return $ run_ (apply command) game' +newtype GameAtVillagesTurn = GameAtVillagesTurn Game + deriving (Eq, Show) -arbitraryGameWithProtectAndDevourVotes :: Gen Game -arbitraryGameWithProtectAndDevourVotes = arbitraryGameWithProtect >>= runArbitraryDevourVoteCommands +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 GameAtSeersTurn = GameAtSeersTurn Game + deriving (Eq, Show) + +instance Arbitrary GameAtSeersTurn where + arbitrary = do + game <- arbitrary + + return $ GameAtSeersTurn (game & stage .~ SeersTurn) + +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 GameWithLynchVotes = GameWithLynchVotes Game + deriving (Eq, Show) + +instance Arbitrary GameWithLynchVotes where + arbitrary = do + game <- arbitrary + + GameWithLynchVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ VillagesTurn) + +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 .~ DefendersTurn + (Blind command) <- arbitraryProtectCommand game' + + return $ GameWithProtect (run_ (apply command) game') + +newtype GameWithProtectAndDevourVotes = GameWithProtectAndDevourVotes Game + deriving (Eq, Show) + +instance Arbitrary GameWithProtectAndDevourVotes where + arbitrary = do + (GameWithProtect game) <- arbitrary + let game' = run_ checkStage game + + GameWithProtectAndDevourVotes <$> runArbitraryCommands (length $ game' ^. players) game' + +newtype GameWithSee = GameWithSee Game + deriving (Eq, Show) + +instance Arbitrary GameWithSee where + arbitrary = do + game <- arbitrary + let game' = game & stage .~ SeersTurn + (Blind command) <- arbitrarySeeCommand game' + + return $ GameWithSee (run_ (apply command) game') + arbitraryPlayerSet :: Gen [Player] arbitraryPlayerSet = do n <- choose (10, 24) - players <- nubOn _name <$> infiniteList + players <- nubOn (view name) <$> infiniteList let defender = head $ filterDefenders players let scapegoat = head $ filterScapegoats players @@ -114,12 +221,12 @@ return $ defender:scapegoat:seer:villagerVillager:witch:werewolves ++ villagers -arbitraryCommand :: Game -> Gen Command +arbitraryCommand :: Game -> Gen (Blind Command) arbitraryCommand game = case game ^. stage of - GameOver -> return noopCommand + GameOver -> return $ Blind noopCommand DefendersTurn -> arbitraryProtectCommand game - Sunrise -> return noopCommand - Sunset -> return noopCommand + Sunrise -> return $ Blind noopCommand + Sunset -> return $ Blind noopCommand SeersTurn -> arbitrarySeeCommand game VillagesTurn -> arbitraryLynchVoteCommand game WerewolvesTurn -> arbitraryDevourVoteCommand game @@ -129,103 +236,89 @@ arbitraryPoisonCommand game ] -arbitraryDevourVoteCommand :: Game -> Gen Command +arbitraryDevourVoteCommand :: Game -> Gen (Blind Command) arbitraryDevourVoteCommand game = do let applicableCallers = filterWerewolves $ getPendingVoters game target <- suchThat (arbitraryPlayer game) $ not . isWerewolf if null applicableCallers - then return noopCommand + then return $ Blind noopCommand else elements applicableCallers >>= \caller -> - return $ devourVoteCommand (caller ^. name) (target ^. name) + return . Blind $ devourVoteCommand (caller ^. name) (target ^. name) -arbitraryLynchVoteCommand :: Game -> Gen Command +arbitraryLynchVoteCommand :: Game -> Gen (Blind Command) arbitraryLynchVoteCommand game = do let applicableCallers = getPendingVoters game target <- arbitraryPlayer game if null applicableCallers - then return noopCommand + then return $ Blind noopCommand else elements applicableCallers >>= \caller -> - return $ lynchVoteCommand (caller ^. name) (target ^. name) + return . Blind $ lynchVoteCommand (caller ^. name) (target ^. name) -arbitraryHealCommand :: Game -> Gen Command +arbitraryHealCommand :: Game -> Gen (Blind Command) arbitraryHealCommand game = do let witch = head . filterWitches $ game ^. players return $ if game ^. healUsed - then noopCommand - else seq (fromJust (getDevourEvent game)) $ healCommand (witch ^. name) + then Blind noopCommand + else seq (fromJust $ getDevourEvent game) (Blind $ healCommand (witch ^. name)) -arbitraryPassCommand :: Game -> Gen Command +arbitraryPassCommand :: Game -> Gen (Blind Command) arbitraryPassCommand game = do - witch <- arbitraryWitch game + let witch = head . filterWitches $ game ^. players - return $ passCommand (witch ^. name) + return . Blind $ passCommand (witch ^. name) -arbitraryPoisonCommand :: Game -> Gen Command +arbitraryPoisonCommand :: Game -> Gen (Blind Command) arbitraryPoisonCommand game = do let witch = head . filterWitches $ game ^. players target <- arbitraryPlayer game return $ if isJust (game ^. poison) - then noopCommand - else poisonCommand (witch ^. name) (target ^. name) + then Blind noopCommand + else Blind $ poisonCommand (witch ^. name) (target ^. name) -arbitraryProtectCommand :: Game -> Gen Command +arbitraryProtectCommand :: Game -> Gen (Blind Command) arbitraryProtectCommand game = do let defender = head . filterDefenders $ game ^. players + -- TODO (hjw): suchThat (/= priorProtect) target <- suchThat (arbitraryPlayer game) (defender /=) return $ if isJust (game ^. protect) - then noopCommand - else protectCommand (defender ^. name) (target ^. name) + then Blind noopCommand + else Blind $ protectCommand (defender ^. name) (target ^. name) -arbitraryQuitCommand :: Game -> Gen Command +arbitraryQuitCommand :: Game -> Gen (Blind Command) arbitraryQuitCommand game = do let applicableCallers = filterAlive $ game ^. players if null applicableCallers - then return noopCommand - else elements applicableCallers >>= \caller -> return $ quitCommand (caller ^. name) + then return $ Blind noopCommand + else elements applicableCallers >>= \caller -> + return . Blind $ quitCommand (caller ^. name) -arbitrarySeeCommand :: Game -> Gen Command +arbitrarySeeCommand :: Game -> Gen (Blind Command) arbitrarySeeCommand game = do let seer = head . filterSeers $ game ^. players target <- arbitraryPlayer game return $ if isJust (game ^. see) - then noopCommand - else seeCommand (seer ^. name) (target ^. name) + then Blind noopCommand + else Blind $ seeCommand (seer ^. name) (target ^. name) runArbitraryCommands :: Int -> Game -> Gen Game runArbitraryCommands n = iterateM n $ \game -> do - command <- arbitraryCommand game + (Blind command) <- arbitraryCommand game return $ run_ (apply command) game -runArbitraryDevourVoteCommands :: Game -> Gen Game -runArbitraryDevourVoteCommands game = do - let game' = game { _stage = WerewolvesTurn } - let n = length . filterWerewolves $ game' ^. players - - runArbitraryCommands n 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 = elements . filterAlive . _players - -arbitraryDefender :: Game -> Gen Player -arbitraryDefender = elements . filterAlive . filterDefenders . _players - -arbitrarySeer :: Game -> Gen Player -arbitrarySeer = elements . filterAlive . filterSeers . _players +arbitraryPlayer = elements . filterAlive . view players arbitraryWerewolf :: Game -> Gen Player -arbitraryWerewolf = elements . filterAlive . filterWerewolves . _players - -arbitraryWitch :: Game -> Gen Player -arbitraryWitch = elements . filterAlive . filterWitches . _players +arbitraryWerewolf = elements . filterAlive . filterWerewolves . view players diff --git a/test/src/Game/Werewolf/Test/Command.hs b/test/src/Game/Werewolf/Test/Command.hs --- a/test/src/Game/Werewolf/Test/Command.hs +++ b/test/src/Game/Werewolf/Test/Command.hs @@ -75,7 +75,6 @@ import Data.Maybe import Game.Werewolf.Command -import Game.Werewolf.Engine (checkStage) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Test.Arbitrary @@ -83,26 +82,28 @@ import Test.QuickCheck -prop_devourVoteCommandErrorsWhenGameIsOver :: Game -> Property -prop_devourVoteCommandErrorsWhenGameIsOver game = - forAll (arbitraryDevourVoteCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } +prop_devourVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_devourVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_devourVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_devourVoteCommandErrorsWhenCallerDoesNotExist game caller = +prop_devourVoteCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property +prop_devourVoteCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller = not (doesPlayerExist (caller ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitraryPlayer game) $ \target -> do + let command = devourVoteCommand (caller ^. name) (target ^. name) -prop_devourVoteCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_devourVoteCommandErrorsWhenTargetDoesNotExist game target = + verbose_runCommandErrors game command + +prop_devourVoteCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property +prop_devourVoteCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target = not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitraryWerewolf game) $ \caller -> - verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitraryWerewolf game) $ \caller -> do + let command = devourVoteCommand (caller ^. name) (target ^. name) -prop_devourVoteCommandErrorsWhenCallerIsDead :: Game -> Property -prop_devourVoteCommandErrorsWhenCallerIsDead game = + verbose_runCommandErrors game command + +prop_devourVoteCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property +prop_devourVoteCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) = forAll (arbitraryWerewolf game) $ \caller -> forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game caller @@ -110,8 +111,8 @@ verbose_runCommandErrors game' command -prop_devourVoteCommandErrorsWhenTargetIsDead :: Game -> Property -prop_devourVoteCommandErrorsWhenTargetIsDead game = +prop_devourVoteCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property +prop_devourVoteCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) = forAll (arbitraryWerewolf game) $ \caller -> forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game target @@ -122,119 +123,117 @@ prop_devourVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property prop_devourVoteCommandErrorsWhenNotWerewolvesTurn game = not (isWerewolvesTurn game) - ==> forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game + ==> forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_devourVoteCommandErrorsWhenCallerNotWerewolf :: Game -> Property -prop_devourVoteCommandErrorsWhenCallerNotWerewolf game = +prop_devourVoteCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property +prop_devourVoteCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) = forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let command = devourVoteCommand (caller ^. name) (target ^. name) -prop_devourVoteCommandErrorsWhenCallerHasVoted :: Game -> Property -prop_devourVoteCommandErrorsWhenCallerHasVoted game = - forAll (arbitraryWerewolf game') $ \caller -> - forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target -> do + verbose_runCommandErrors game command + +prop_devourVoteCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property +prop_devourVoteCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) = + forAll (arbitraryWerewolf game) $ \caller -> + forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \target -> do let command = devourVoteCommand (caller ^. name) (target ^. name) - let game'' = run_ (apply command) game' - verbose_runCommandErrors game'' command - where - game' = game { _stage = WerewolvesTurn } + verbose_runCommandErrors game command -prop_devourVoteCommandErrorsWhenTargetWerewolf :: Game -> Property -prop_devourVoteCommandErrorsWhenTargetWerewolf game = +prop_devourVoteCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property +prop_devourVoteCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) = forAll (suchThat (arbitraryPlayer game) isWerewolf) $ \target -> forAll (arbitraryPlayer game) $ \caller -> verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name)) -prop_devourVoteCommandUpdatesVotes :: Game -> Property -prop_devourVoteCommandUpdatesVotes game = - forAll (arbitraryDevourVoteCommand game') $ \command -> do - let game'' = run_ (apply command) game' +prop_devourVoteCommandUpdatesVotes :: GameAtWerewolvesTurn -> Property +prop_devourVoteCommandUpdatesVotes (GameAtWerewolvesTurn game) = + forAll (arbitraryDevourVoteCommand game) $ \(Blind command) -> do + let game' = run_ (apply command) game - Map.size (game'' ^. votes) == 1 - where - game' = game { _stage = WerewolvesTurn } + Map.size (game' ^. votes) == 1 -prop_healCommandErrorsWhenGameIsOver :: Game -> Property -prop_healCommandErrorsWhenGameIsOver game = - forAll (arbitraryWitch game') $ \witch -> - verbose_runCommandErrors game' (healCommand $ witch ^. name) - where - game' = game { _stage = GameOver } +prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = do + let witch = head . filterWitches $ game ^. players + let command = healCommand $ witch ^. name -prop_healCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_healCommandErrorsWhenCallerDoesNotExist game caller = + verbose_runCommandErrors game command + +prop_healCommandErrorsWhenCallerDoesNotExist :: GameWithDevourEvent -> Player -> Property +prop_healCommandErrorsWhenCallerDoesNotExist (GameWithDevourEvent game) caller = not (doesPlayerExist (caller ^. name) (game ^. players)) ==> verbose_runCommandErrors game (healCommand (caller ^. name)) -prop_healCommandErrorsWhenCallerIsDead :: Game -> Property -prop_healCommandErrorsWhenCallerIsDead game = +prop_healCommandErrorsWhenCallerIsDead :: GameWithDevourEvent -> Property +prop_healCommandErrorsWhenCallerIsDead (GameWithDevourEvent game) = forAll (arbitraryPlayer game) $ \caller -> do let game' = killPlayer game caller let command = healCommand (caller ^. name) verbose_runCommandErrors game' command -prop_healCommandErrorsWhenNoTargetIsDevoured :: Game -> Property -prop_healCommandErrorsWhenNoTargetIsDevoured game = - forAll (arbitraryWitch game) $ \witch -> - verbose_runCommandErrors game (healCommand $ witch ^. name) +prop_healCommandErrorsWhenNoTargetIsDevoured :: GameAtWitchsTurn -> Property +prop_healCommandErrorsWhenNoTargetIsDevoured (GameAtWitchsTurn game) = do + let witch = head . filterWitches $ game ^. players + let command = healCommand $ witch ^. name + verbose_runCommandErrors game command + prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property -prop_healCommandErrorsWhenNotWitchsTurn game = - not (isWitchsTurn game) - ==> forAll (arbitraryWitch game) $ \witch -> - verbose_runCommandErrors game (healCommand $ witch ^. name) +prop_healCommandErrorsWhenNotWitchsTurn game = do + let witch = head . filterWitches $ game ^. players + let command = healCommand $ witch ^. name -prop_healCommandErrorsWhenCallerHasHealed :: Gen Property -prop_healCommandErrorsWhenCallerHasHealed = do - game <- arbitraryGameWithDevourEventForVillager + not (isWitchsTurn game) ==> verbose_runCommandErrors game command - return $ forAll (arbitraryHealCommand game) $ \command -> do - let game' = run_ (apply command) game +prop_healCommandErrorsWhenCallerHasHealed :: GameWithHeal -> Property +prop_healCommandErrorsWhenCallerHasHealed (GameWithHeal game) = do + let witch = head . filterWitches $ game ^. players + let command = healCommand $ witch ^. name - verbose_runCommandErrors game' command + verbose_runCommandErrors game command -prop_healCommandErrorsWhenCallerNotWitch :: Game -> Property -prop_healCommandErrorsWhenCallerNotWitch game = - forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller -> - verbose_runCommandErrors game (healCommand (caller ^. name)) +prop_healCommandErrorsWhenCallerNotWitch :: GameWithDevourEvent -> Property +prop_healCommandErrorsWhenCallerNotWitch (GameWithDevourEvent game) = + forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller -> do + let command = healCommand (caller ^. name) -prop_healCommandSetsHeal :: Gen Property -prop_healCommandSetsHeal = do - game <- arbitraryGameWithDevourEventForVillager + verbose_runCommandErrors game command - return $ forAll (arbitraryHealCommand game) $ \command -> +prop_healCommandSetsHeal :: GameWithDevourEvent -> Property +prop_healCommandSetsHeal (GameWithDevourEvent game) = + forAll (arbitraryHealCommand game) $ \(Blind command) -> (run_ (apply command) game) ^. heal -prop_healCommandSetsHealUsed :: Gen Property -prop_healCommandSetsHealUsed = do - game <- arbitraryGameWithDevourEventForVillager - - return $ forAll (arbitraryHealCommand game) $ \command -> +prop_healCommandSetsHealUsed :: GameWithDevourEvent -> Property +prop_healCommandSetsHealUsed (GameWithDevourEvent game) = + forAll (arbitraryHealCommand game) $ \(Blind command) -> (run_ (apply command) game) ^. healUsed -prop_lynchVoteCommandErrorsWhenGameIsOver :: Game -> Property -prop_lynchVoteCommandErrorsWhenGameIsOver game = - forAll (arbitraryLynchVoteCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } +prop_lynchVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_lynchVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_lynchVoteCommandErrorsWhenCallerDoesNotExist game caller = +prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property +prop_lynchVoteCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller = not (doesPlayerExist (caller ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (lynchVoteCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitraryPlayer game) $ \target -> do + let command = lynchVoteCommand (caller ^. name) (target ^. name) -prop_lynchVoteCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_lynchVoteCommandErrorsWhenTargetDoesNotExist game target = + verbose_runCommandErrors game command + +prop_lynchVoteCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property +prop_lynchVoteCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target = not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \caller -> - verbose_runCommandErrors game (lynchVoteCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitraryPlayer game) $ \caller -> do + let command = lynchVoteCommand (caller ^. name) (target ^. name) -prop_lynchVoteCommandErrorsWhenCallerIsDead :: Game -> Property -prop_lynchVoteCommandErrorsWhenCallerIsDead game = + verbose_runCommandErrors game command + +prop_lynchVoteCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property +prop_lynchVoteCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) = forAll (arbitraryPlayer game) $ \caller -> forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game caller @@ -242,8 +241,8 @@ verbose_runCommandErrors game' command -prop_lynchVoteCommandErrorsWhenTargetIsDead :: Game -> Property -prop_lynchVoteCommandErrorsWhenTargetIsDead game = +prop_lynchVoteCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property +prop_lynchVoteCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) = forAll (arbitraryPlayer game) $ \caller -> forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game target @@ -254,41 +253,34 @@ prop_lynchVoteCommandErrorsWhenNotVillagesTurn :: Game -> Property prop_lynchVoteCommandErrorsWhenNotVillagesTurn game = not (isVillagesTurn game) - ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game + ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_lynchVoteCommandErrorsWhenCallerHasVoted :: Game -> Property -prop_lynchVoteCommandErrorsWhenCallerHasVoted game = - forAll (arbitraryPlayer game') $ \caller -> - forAll (arbitraryPlayer game') $ \target -> do +prop_lynchVoteCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property +prop_lynchVoteCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) = + forAll (arbitraryPlayer game) $ \caller -> + forAll (arbitraryPlayer game) $ \target -> do let command = lynchVoteCommand (caller ^. name) (target ^. name) - let game'' = run_ (apply command) game' - verbose_runCommandErrors game'' command - where - game' = game { _stage = VillagesTurn } + verbose_runCommandErrors game command -prop_lynchVoteCommandUpdatesVotes :: Game -> Property -prop_lynchVoteCommandUpdatesVotes game = - forAll (arbitraryLynchVoteCommand game') $ \command -> do - let game'' = run_ (apply command) game' +prop_lynchVoteCommandUpdatesVotes :: GameAtVillagesTurn -> Property +prop_lynchVoteCommandUpdatesVotes (GameAtVillagesTurn game) = + forAll (arbitraryLynchVoteCommand game) $ \(Blind command) -> do + let game' = run_ (apply command) game - Map.size (game'' ^. votes) == 1 - where - game' = game { _stage = VillagesTurn } + Map.size (game' ^. votes) == 1 -prop_passCommandErrorsWhenGameIsOver :: Game -> Property -prop_passCommandErrorsWhenGameIsOver game = - forAll (arbitraryPassCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } +prop_passCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_passCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind -prop_passCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_passCommandErrorsWhenCallerDoesNotExist game caller = +prop_passCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property +prop_passCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller = not (doesPlayerExist (caller ^. name) (game ^. players)) ==> verbose_runCommandErrors game (passCommand (caller ^. name)) -prop_passCommandErrorsWhenCallerIsDead :: Game -> Property -prop_passCommandErrorsWhenCallerIsDead game = +prop_passCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property +prop_passCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = forAll (arbitraryPlayer game) $ \caller -> do let game' = killPlayer game caller let command = passCommand (caller ^. name) @@ -298,188 +290,178 @@ prop_passCommandErrorsWhenNotWitchsTurn :: Game -> Property prop_passCommandErrorsWhenNotWitchsTurn game = not (isWitchsTurn game) - ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game + ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind -prop_passCommandUpdatesPasses :: Game -> Property -prop_passCommandUpdatesPasses game = - forAll (arbitraryPassCommand game') $ \command -> do - let game'' = run_ (apply command) game' +prop_passCommandUpdatesPasses :: GameAtWitchsTurn -> Property +prop_passCommandUpdatesPasses (GameAtWitchsTurn game) = + forAll (arbitraryPassCommand game) $ \(Blind command) -> do + let game' = run_ (apply command) game - length (game'' ^. passes) == 1 - where - game' = game { _stage = WitchsTurn } + length (game' ^. passes) == 1 -prop_poisonCommandErrorsWhenGameIsOver :: Game -> Property -prop_poisonCommandErrorsWhenGameIsOver game = - forAll (arbitraryPoisonCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } +prop_poisonCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_poisonCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind -prop_poisonCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_poisonCommandErrorsWhenCallerDoesNotExist game caller = +prop_poisonCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property +prop_poisonCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller = not (doesPlayerExist (caller ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name)) + ==> forAll (arbitraryPlayer game) $ \target -> do + let command = poisonCommand (caller ^. name) (target ^. name) -prop_poisonCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_poisonCommandErrorsWhenTargetDoesNotExist game target = + verbose_runCommandErrors game command + +prop_poisonCommandErrorsWhenTargetDoesNotExist :: GameAtWitchsTurn -> Player -> Property +prop_poisonCommandErrorsWhenTargetDoesNotExist (GameAtWitchsTurn game) target = do + let witch = head . filterWitches $ game ^. players + let command = poisonCommand (witch ^. name) (target ^. name) + not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitraryPlayer game) $ \caller -> - verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name)) + ==> verbose_runCommandErrors game command -prop_poisonCommandErrorsWhenCallerIsDead :: Game -> Property -prop_poisonCommandErrorsWhenCallerIsDead game = - forAll (arbitraryPlayer game) $ \caller -> +prop_poisonCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property +prop_poisonCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do + let witch = head . filterWitches $ game ^. players + forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer game caller - let command = poisonCommand (caller ^. name) (target ^. name) + let game' = killPlayer game witch + let command = poisonCommand (witch ^. name) (target ^. name) verbose_runCommandErrors game' command -prop_poisonCommandErrorsWhenTargetIsDead :: Game -> Property -prop_poisonCommandErrorsWhenTargetIsDead game = - forAll (arbitraryPlayer game) $ \caller -> +prop_poisonCommandErrorsWhenTargetIsDead :: GameAtWitchsTurn -> Property +prop_poisonCommandErrorsWhenTargetIsDead (GameAtWitchsTurn game) = do + let witch = head . filterWitches $ game ^. players + forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game target - let command = poisonCommand (caller ^. name) (target ^. name) + let command = poisonCommand (witch ^. name) (target ^. name) verbose_runCommandErrors game' command -prop_poisonCommandErrorsWhenTargetIsDevoured :: Game -> Property -prop_poisonCommandErrorsWhenTargetIsDevoured game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> forAll (arbitraryWitch game'') $ \caller -> - let game''' = run_ checkStage game'' - votee = head (getVoteResult game'') - in verbose_runCommandErrors game''' (poisonCommand (caller ^. name) (votee ^. name)) - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_poisonCommandErrorsWhenTargetIsDevoured :: GameWithDevourEvent -> Property +prop_poisonCommandErrorsWhenTargetIsDevoured (GameWithDevourEvent game) = do + let (DevourEvent targetName) = fromJust $ getDevourEvent game + let witch = head . filterWitches $ game ^. players + let command = poisonCommand (witch ^. name) targetName + + verbose_runCommandErrors game command + prop_poisonCommandErrorsWhenNotWitchsTurn :: Game -> Property prop_poisonCommandErrorsWhenNotWitchsTurn game = not (isWitchsTurn game) - ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game + ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind -prop_poisonCommandErrorsWhenCallerHasPoisoned :: Game -> Property -prop_poisonCommandErrorsWhenCallerHasPoisoned game = - forAll (arbitraryWitch game') $ \caller -> - forAll (arbitraryPlayer game') $ \target -> - let command = poisonCommand (caller ^. name) (target ^. name) - in verbose_runCommandErrors (run_ (apply command) game') command - where - game' = game { _stage = WitchsTurn } +prop_poisonCommandErrorsWhenCallerHasPoisoned :: GameWithPoison -> Property +prop_poisonCommandErrorsWhenCallerHasPoisoned (GameWithPoison game) = do + let witch = head . filterWitches $ game ^. players -prop_poisonCommandErrorsWhenCallerNotWitch :: Game -> Property -prop_poisonCommandErrorsWhenCallerNotWitch game = + 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) (not . isWitch)) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> - verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name)) + forAll (arbitraryPlayer game) $ \target -> do + let command = poisonCommand (caller ^. name) (target ^. name) -prop_poisonCommandSetsPoison :: Game -> Property -prop_poisonCommandSetsPoison game = - forAll (arbitraryPoisonCommand game') $ \command -> - isJust (run_ (apply command) game' ^. poison) - where - game' = game { _stage = WitchsTurn } + verbose_runCommandErrors game command -prop_poisonCommandSetsPoisonUsed :: Game -> Property -prop_poisonCommandSetsPoisonUsed game = - forAll (arbitraryPoisonCommand game') $ \command -> - run_ (apply command) game' ^. poisonUsed - where - game' = game { _stage = WitchsTurn } +prop_poisonCommandSetsPoison :: GameAtWitchsTurn -> Property +prop_poisonCommandSetsPoison (GameAtWitchsTurn game) = + forAll (arbitraryPoisonCommand game) $ \(Blind command) -> + isJust (run_ (apply command) game ^. poison) -prop_protectCommandErrorsWhenGameIsOver :: Game -> Property -prop_protectCommandErrorsWhenGameIsOver game = - forAll (arbitraryProtectCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } +prop_poisonCommandSetsPoisonUsed :: GameAtWitchsTurn -> Property +prop_poisonCommandSetsPoisonUsed (GameAtWitchsTurn game) = + forAll (arbitraryPoisonCommand game) $ \(Blind command) -> + run_ (apply command) game ^. poisonUsed -prop_protectCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_protectCommandErrorsWhenCallerDoesNotExist game caller = +prop_protectCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_protectCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind + +prop_protectCommandErrorsWhenCallerDoesNotExist :: GameAtDefendersTurn -> Player -> Property +prop_protectCommandErrorsWhenCallerDoesNotExist (GameAtDefendersTurn game) caller = not (doesPlayerExist (caller ^. name) (game ^. players)) ==> forAll (arbitraryPlayer game) $ \target -> do let command = protectCommand (caller ^. name) (target ^. name) verbose_runCommandErrors game command -prop_protectCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_protectCommandErrorsWhenTargetDoesNotExist game target = +prop_protectCommandErrorsWhenTargetDoesNotExist :: GameAtDefendersTurn -> Player -> Property +prop_protectCommandErrorsWhenTargetDoesNotExist (GameAtDefendersTurn game) target = do + let defender = head . filterDefenders $ game ^. players + let command = protectCommand (defender ^. name) (target ^. name) + not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitraryDefender game) $ \caller -> do - let command = protectCommand (caller ^. name) (target ^. name) + ==> verbose_runCommandErrors game command - verbose_runCommandErrors game command +prop_protectCommandErrorsWhenCallerIsDead :: GameAtDefendersTurn -> Property +prop_protectCommandErrorsWhenCallerIsDead (GameAtDefendersTurn game) = do + let defender = head . filterDefenders $ game ^. players + let game' = killPlayer game defender -prop_protectCommandErrorsWhenCallerIsDead :: Game -> Property -prop_protectCommandErrorsWhenCallerIsDead game = - forAll (arbitraryDefender game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer game caller - let command = protectCommand (caller ^. name) (target ^. name) + forAll (arbitraryPlayer game') $ \target -> do + let command = protectCommand (defender ^. name) (target ^. name) verbose_runCommandErrors game' command -prop_protectCommandErrorsWhenTargetIsDead :: Game -> Property -prop_protectCommandErrorsWhenTargetIsDead game = - forAll (arbitraryDefender game) $ \caller -> +prop_protectCommandErrorsWhenTargetIsDead :: GameAtDefendersTurn -> Property +prop_protectCommandErrorsWhenTargetIsDead (GameAtDefendersTurn game) = do + let defender = head . filterDefenders $ game ^. players + forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game target - let command = protectCommand (caller ^. name) (target ^. name) + let command = protectCommand (defender ^. name) (target ^. name) verbose_runCommandErrors game' command prop_protectCommandErrorsWhenNotDefendersTurn :: Game -> Property prop_protectCommandErrorsWhenNotDefendersTurn game = not (isDefendersTurn game) - ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game + ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind -prop_protectCommandErrorsWhenCallerNotDefender :: Game -> Property -prop_protectCommandErrorsWhenCallerNotDefender game = +prop_protectCommandErrorsWhenCallerNotDefender :: GameAtDefendersTurn -> Property +prop_protectCommandErrorsWhenCallerNotDefender (GameAtDefendersTurn game) = forAll (suchThat (arbitraryPlayer game) (not . isDefender)) $ \caller -> forAll (arbitraryPlayer game) $ \target -> do let command = protectCommand (caller ^. name) (target ^. name) verbose_runCommandErrors game command -prop_protectCommandErrorsWhenTargetIsCaller :: Game -> Property -prop_protectCommandErrorsWhenTargetIsCaller game = - forAll (arbitraryDefender game) $ \caller -> do - let command = protectCommand (caller ^. name) (caller ^. name) +prop_protectCommandErrorsWhenTargetIsCaller :: GameAtDefendersTurn -> Property +prop_protectCommandErrorsWhenTargetIsCaller (GameAtDefendersTurn game) = do + let defender = head . filterDefenders $ game ^. players + let command = protectCommand (defender ^. name) (defender ^. name) - verbose_runCommandErrors game command + verbose_runCommandErrors game command -prop_protectCommandErrorsWhenTargetIsPriorProtect :: Gen Property -prop_protectCommandErrorsWhenTargetIsPriorProtect = do - game <- arbitraryGameWithProtect - let game' = game { _protect = Nothing } +prop_protectCommandErrorsWhenTargetIsPriorProtect :: GameWithProtect -> Property +prop_protectCommandErrorsWhenTargetIsPriorProtect (GameWithProtect game) = do + let game' = game & protect .~ Nothing - return $ forAll (arbitraryDefender game') $ \caller -> do - let command = protectCommand (caller ^. name) (fromJust $ game' ^. priorProtect) + let defender = head . filterDefenders $ game' ^. players + let command = protectCommand (defender ^. name) (fromJust $ game' ^. priorProtect) - verbose_runCommandErrors game' command + verbose_runCommandErrors game' command -prop_protectCommandSetsPriorProtect :: Game -> Property -prop_protectCommandSetsPriorProtect game = - forAll (arbitraryProtectCommand game') $ \command -> - isJust $ run_ (apply command) game' ^. priorProtect - where - game' = game { _stage = DefendersTurn } +prop_protectCommandSetsPriorProtect :: GameAtDefendersTurn -> Property +prop_protectCommandSetsPriorProtect (GameAtDefendersTurn game) = + forAll (arbitraryProtectCommand game) $ \(Blind command) -> + isJust $ run_ (apply command) game ^. priorProtect -prop_protectCommandSetsProtect :: Game -> Property -prop_protectCommandSetsProtect game = - forAll (arbitraryProtectCommand game') $ \command -> - isJust $ run_ (apply command) game' ^. protect - where - game' = game { _stage = DefendersTurn } +prop_protectCommandSetsProtect :: GameAtDefendersTurn -> Property +prop_protectCommandSetsProtect (GameAtDefendersTurn game) = + forAll (arbitraryProtectCommand game) $ \(Blind command) -> + isJust $ run_ (apply command) game ^. protect -prop_quitCommandErrorsWhenGameIsOver :: Game -> Property -prop_quitCommandErrorsWhenGameIsOver game = - forAll (arbitraryQuitCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } +prop_quitCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property +prop_quitCommandErrorsWhenGameIsOver (GameAtGameOver game) = + forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game . getBlind prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_quitCommandErrorsWhenCallerDoesNotExist game caller = @@ -488,160 +470,136 @@ prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property prop_quitCommandErrorsWhenCallerIsDead game = - forAll (arbitraryPlayer game) $ \caller -> - verbose_runCommandErrors (killPlayer game caller) (quitCommand $ caller ^. name) + forAll (arbitraryPlayer game) $ \caller -> do + let game' = killPlayer game caller + let command = quitCommand $ caller ^. name + verbose_runCommandErrors game' command + prop_quitCommandKillsPlayer :: Game -> Property prop_quitCommandKillsPlayer game = not (isGameOver game) - ==> forAll (arbitraryQuitCommand game) $ \command -> - length (filterDead $ run_ (apply command) game ^. players) == 1 + ==> forAll (arbitraryQuitCommand game) $ \(Blind command) -> do + let game' = run_ (apply command) game -prop_quitCommandClearsHealWhenCallerIsWitch :: Game -> Property -prop_quitCommandClearsHealWhenCallerIsWitch game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> forAll (arbitraryWitch game'') $ \caller -> - let command = healCommand (caller ^. name) - game''' = run_ (apply command) $ run_ checkStage game'' - in not $ run_ (apply $ quitCommand (caller ^. name)) game''' ^. heal - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players + length (filterDead $ game' ^. players) == 1 -prop_quitCommandClearsHealUsedWhenCallerIsWitch :: Game -> Property -prop_quitCommandClearsHealUsedWhenCallerIsWitch game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> forAll (arbitraryWitch game'') $ \caller -> - let command = healCommand (caller ^. name) - game''' = run_ (apply command) $ run_ checkStage game'' - in not $ run_ (apply $ quitCommand (caller ^. name)) game''' ^. healUsed - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_quitCommandClearsHealWhenCallerIsWitch :: GameWithHeal -> Bool +prop_quitCommandClearsHealWhenCallerIsWitch (GameWithHeal game) = do + let witch = head . filterWitches $ game ^. players + let command = quitCommand (witch ^. name) -prop_quitCommandClearsPoisonWhenCallerIsWitch :: Game -> Property -prop_quitCommandClearsPoisonWhenCallerIsWitch game = - forAll (arbitraryWitch game') $ \caller -> - forAll (arbitraryPlayer game') $ \target -> - let game'' = run_ (apply $ poisonCommand (caller ^. name) (target ^. name)) game' - in isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. poison - where - game' = game { _stage = WitchsTurn } + not $ run_ (apply command) game ^. heal -prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: Game -> Property -prop_quitCommandClearsPriorProtectWhenCallerIsDefender game = - forAll (arbitraryDefender game') $ \caller -> - forAll (suchThat (arbitraryPlayer game') (not . isDefender)) $ \target -> do - let command = protectCommand (caller ^. name) (target ^. name) - let game'' = run_ (apply command) game' +prop_quitCommandClearsHealUsedWhenCallerIsWitch :: GameWithHeal -> Bool +prop_quitCommandClearsHealUsedWhenCallerIsWitch (GameWithHeal game) = do + let witch = head . filterWitches $ game ^. players + let command = quitCommand (witch ^. name) - isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. priorProtect - where - game' = game { _stage = DefendersTurn } + not $ run_ (apply command) game ^. healUsed -prop_quitCommandClearsProtectWhenCallerIsDefender :: Game -> Property -prop_quitCommandClearsProtectWhenCallerIsDefender game = - forAll (arbitraryDefender game') $ \caller -> - forAll (suchThat (arbitraryPlayer game') (not . isDefender)) $ \target -> do - let command = protectCommand (caller ^. name) (target ^. name) - let game'' = run_ (apply command) game' +prop_quitCommandClearsPoisonWhenCallerIsWitch :: GameWithPoison -> Bool +prop_quitCommandClearsPoisonWhenCallerIsWitch (GameWithPoison game) = do + let witch = head . filterWitches $ game ^. players + let command = quitCommand (witch ^. name) - isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. protect - where - game' = game { _stage = DefendersTurn } + isNothing $ run_ (apply command) game ^. poison -prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: Game -> Property -prop_quitCommandClearsPoisonUsedWhenCallerIsWitch game = - forAll (arbitraryWitch game') $ \caller -> - forAll (arbitraryPlayer game') $ \target -> - let game'' = run_ (apply $ poisonCommand (caller ^. name) (target ^. name)) game' - in not $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. poisonUsed - where - game' = game { _stage = WitchsTurn } +prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: GameWithPoison -> Bool +prop_quitCommandClearsPoisonUsedWhenCallerIsWitch (GameWithPoison game) = do + let witch = head . filterWitches $ game ^. players + let command = quitCommand (witch ^. name) -prop_quitCommandClearsPlayersDevourVote :: Game -> Property -prop_quitCommandClearsPlayersDevourVote game = - forAll (arbitraryWerewolf game') $ \caller -> - forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target -> - let game'' = run_ (apply $ devourVoteCommand (caller ^. name) (target ^. name)) game' - in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes - where - game' = game { _stage = WerewolvesTurn } + not $ run_ (apply command) game ^. poisonUsed -prop_quitCommandClearsPlayersLynchVote :: Game -> Property -prop_quitCommandClearsPlayersLynchVote game = - forAll (arbitraryPlayer game') $ \caller -> - forAll (arbitraryPlayer game') $ \target -> - let game'' = run_ (apply $ lynchVoteCommand (caller ^. name) (target ^. name)) game' - in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes - where - game' = game { _stage = VillagesTurn } +prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: GameWithProtect -> Bool +prop_quitCommandClearsPriorProtectWhenCallerIsDefender (GameWithProtect game) = do + let defender = head . filterDefenders $ game ^. players + let command = quitCommand (defender ^. name) -prop_seeCommandErrorsWhenGameIsOver :: Game -> Property -prop_seeCommandErrorsWhenGameIsOver game = - forAll (arbitrarySeeCommand game') $ verbose_runCommandErrors game' - where - game' = game { _stage = GameOver } + isNothing $ run_ (apply command) game ^. priorProtect -prop_seeCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property -prop_seeCommandErrorsWhenCallerDoesNotExist game caller = +prop_quitCommandClearsProtectWhenCallerIsDefender :: GameWithProtect -> Bool +prop_quitCommandClearsProtectWhenCallerIsDefender (GameWithProtect game) = do + let defender = head . filterDefenders $ game ^. players + let command = quitCommand (defender ^. name) + + isNothing $ run_ (apply command) game ^. protect + +prop_quitCommandClearsPlayersDevourVote :: GameWithDevourVotes -> Property +prop_quitCommandClearsPlayersDevourVote (GameWithDevourVotes game) = + forAll (arbitraryWerewolf game) $ \caller -> do + let command = quitCommand (caller ^. name) + + isNothing $ run_ (apply command) game ^. votes . at (caller ^. name) + +prop_quitCommandClearsPlayersLynchVote :: GameWithLynchVotes -> Property +prop_quitCommandClearsPlayersLynchVote (GameWithLynchVotes game) = + forAll (arbitraryPlayer game) $ \caller -> do + let command = quitCommand (caller ^. name) + + isNothing $ run_ (apply command) game ^. votes . at (caller ^. name) + +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 ^. players)) ==> forAll (arbitraryPlayer game) $ \target -> do let command = seeCommand (caller ^. name) (target ^. name) verbose_runCommandErrors game command -prop_seeCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property -prop_seeCommandErrorsWhenTargetDoesNotExist game target = +prop_seeCommandErrorsWhenTargetDoesNotExist :: GameAtSeersTurn -> Player -> Property +prop_seeCommandErrorsWhenTargetDoesNotExist (GameAtSeersTurn game) target = do + let seer = head . filterSeers $ game ^. players + let command = seeCommand (seer ^. name) (target ^. name) + not (doesPlayerExist (target ^. name) (game ^. players)) - ==> forAll (arbitrarySeer game) $ \caller -> do - let command = seeCommand (caller ^. name) (target ^. name) + ==> verbose_runCommandErrors game command - verbose_runCommandErrors game command +prop_seeCommandErrorsWhenCallerIsDead :: GameAtSeersTurn -> Property +prop_seeCommandErrorsWhenCallerIsDead (GameAtSeersTurn game) = do + let seer = head . filterSeers $ game ^. players + let game' = killPlayer game seer -prop_seeCommandErrorsWhenCallerIsDead :: Game -> Property -prop_seeCommandErrorsWhenCallerIsDead game = - forAll (arbitrarySeer game) $ \caller -> - forAll (arbitraryPlayer game) $ \target -> do - let game' = killPlayer game caller - let command = seeCommand (caller ^. name) (target ^. name) + forAll (arbitraryPlayer game') $ \target -> do + let command = seeCommand (seer ^. name) (target ^. name) verbose_runCommandErrors game' command -prop_seeCommandErrorsWhenTargetIsDead :: Game -> Property -prop_seeCommandErrorsWhenTargetIsDead game = - forAll (arbitrarySeer game) $ \caller -> +prop_seeCommandErrorsWhenTargetIsDead :: GameAtSeersTurn -> Property +prop_seeCommandErrorsWhenTargetIsDead (GameAtSeersTurn game) = do + let seer = head . filterSeers $ game ^. players + forAll (arbitraryPlayer game) $ \target -> do let game' = killPlayer game target - let command = seeCommand (caller ^. name) (target ^. name) + let command = seeCommand (seer ^. name) (target ^. name) verbose_runCommandErrors game' command prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property prop_seeCommandErrorsWhenNotSeersTurn game = not (isSeersTurn game) - ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game + ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind -prop_seeCommandErrorsWhenCallerNotSeer :: Game -> Property -prop_seeCommandErrorsWhenCallerNotSeer game = +prop_seeCommandErrorsWhenCallerNotSeer :: GameAtSeersTurn -> Property +prop_seeCommandErrorsWhenCallerNotSeer (GameAtSeersTurn game) = forAll (suchThat (arbitraryPlayer game) (not . isSeer)) $ \caller -> forAll (arbitraryPlayer game) $ \target -> do let command = seeCommand (caller ^. name) (target ^. name) verbose_runCommandErrors game command -prop_seeCommandSetsSee :: Game -> Property -prop_seeCommandSetsSee game = - forAll (arbitrarySeeCommand game') $ \command -> - isJust $ run_ (apply command) game' ^. see - where - game' = game { _stage = SeersTurn } +prop_seeCommandSetsSee :: GameAtSeersTurn -> Property +prop_seeCommandSetsSee (GameAtSeersTurn game) = + forAll (arbitrarySeeCommand game) $ \(Blind command) -> + isJust $ run_ (apply command) game ^. see verbose_runCommandErrors :: Game -> Command -> Property -verbose_runCommandErrors game command = whenFail (mapM_ putStrLn [show game, show . fromRight $ run (apply command) game]) (isLeft $ run (apply command) game) +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/test/src/Game/Werewolf/Test/Engine.hs b/test/src/Game/Werewolf/Test/Engine.hs --- a/test/src/Game/Werewolf/Test/Engine.hs +++ b/test/src/Game/Werewolf/Test/Engine.hs @@ -24,7 +24,6 @@ prop_checkVillagesTurnDoesNothingUnlessAllVoted, prop_checkWerewolvesTurnAdvancesToWitchsTurn, - prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured, prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned, prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus, prop_checkWerewolvesTurnKillsNoOneWhenConflicted, @@ -71,7 +70,7 @@ isWitchsTurn, killPlayer) import Game.Werewolf.Game import Game.Werewolf.Player -import Game.Werewolf.Role hiding (name, _name) +import Game.Werewolf.Role hiding (name) import qualified Game.Werewolf.Role as Role import Game.Werewolf.Test.Arbitrary import Game.Werewolf.Test.Util @@ -79,190 +78,130 @@ import Test.QuickCheck import Test.QuickCheck.Monadic -prop_checkStageSkipsDefendersTurnWhenNoDefender :: Game -> Property -prop_checkStageSkipsDefendersTurnWhenNoDefender game = - forAll (arbitrarySeeCommand game') $ \command -> - not . isDefendersTurn $ run_ (apply command >> checkStage) game' +prop_checkStageSkipsDefendersTurnWhenNoDefender :: GameWithSee -> Bool +prop_checkStageSkipsDefendersTurnWhenNoDefender (GameWithSee game) = + not . isDefendersTurn $ run_ checkStage game' where - game' = (foldl killPlayer game (filterDefenders $ game ^. players)) { _stage = SeersTurn } + game' = foldl killPlayer game (filterDefenders $ game ^. players) -prop_checkStageSkipsSeersTurnWhenNoSeer :: Game -> Property -prop_checkStageSkipsSeersTurnWhenNoSeer game = - forAll (runArbitraryCommands n game') $ \game'' -> - not . isSeersTurn $ run_ checkStage game'' +prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithLynchVotes -> Bool +prop_checkStageSkipsSeersTurnWhenNoSeer (GameWithLynchVotes game) = + not . isSeersTurn $ run_ checkStage game' where - game' = (foldl killPlayer game (filterSeers $ game ^. players)) { _stage = VillagesTurn } - n = length $ game' ^. players + game' = foldl killPlayer game (filterSeers $ game ^. players) -prop_checkStageSkipsWitchsTurnWhenNoWitch :: Game -> Property -prop_checkStageSkipsWitchsTurnWhenNoWitch game = - forAll (runArbitraryCommands n game') $ \game'' -> - not . isWitchsTurn $ run_ checkStage game'' +prop_checkStageSkipsWitchsTurnWhenNoWitch :: GameWithDevourVotes -> Bool +prop_checkStageSkipsWitchsTurnWhenNoWitch (GameWithDevourVotes game) = + not . isWitchsTurn $ run_ checkStage game' where - game' = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players + game' = foldl killPlayer game (filterWitches $ game ^. players) -prop_checkStageDoesNothingWhenGameOver :: Game -> Property -prop_checkStageDoesNothingWhenGameOver game = run_ checkStage game' === game' - where - game' = game { _stage = GameOver } +prop_checkStageDoesNothingWhenGameOver :: GameAtGameOver -> Property +prop_checkStageDoesNothingWhenGameOver (GameAtGameOver game) = + run_ checkStage game === game -prop_checkDefendersTurnAdvancesToWerewolvesTurn :: Game -> Property -prop_checkDefendersTurnAdvancesToWerewolvesTurn game = - forAll (arbitraryProtectCommand game') $ \command -> - isWerewolvesTurn $ run_ (apply command >> checkStage) game' - where - game' = game { _stage = DefendersTurn } +prop_checkDefendersTurnAdvancesToWerewolvesTurn :: GameWithProtect -> Bool +prop_checkDefendersTurnAdvancesToWerewolvesTurn (GameWithProtect game) = + isWerewolvesTurn $ run_ checkStage game -prop_checkSeersTurnAdvancesToDefendersTurn :: Game -> Property -prop_checkSeersTurnAdvancesToDefendersTurn game = - forAll (arbitraryCommand game') $ \command -> - isDefendersTurn $ run_ (apply command >> checkStage) game' - where - game' = game { _stage = SeersTurn } +prop_checkSeersTurnAdvancesToDefendersTurn :: GameWithSee -> Bool +prop_checkSeersTurnAdvancesToDefendersTurn (GameWithSee game) = + isDefendersTurn $ run_ checkStage game -prop_checkSeersTurnResetsSee :: Game -> Property -prop_checkSeersTurnResetsSee game = - forAll (arbitraryCommand game') $ \command -> - isNothing $ run_ (apply command >> checkStage) game' ^. see - where - game' = game { _stage = SeersTurn } +prop_checkSeersTurnResetsSee :: GameWithSee -> Bool +prop_checkSeersTurnResetsSee (GameWithSee game) = + isNothing $ run_ checkStage game ^. see -prop_checkSeersTurnDoesNothingUnlessSeen :: Game -> Bool -prop_checkSeersTurnDoesNothingUnlessSeen game = isSeersTurn $ run_ checkStage game' - where - game' = game { _stage = SeersTurn } +prop_checkSeersTurnDoesNothingUnlessSeen :: GameAtSeersTurn -> Bool +prop_checkSeersTurnDoesNothingUnlessSeen (GameAtSeersTurn game) = + isSeersTurn $ run_ checkStage game -prop_checkVillagesTurnAdvancesToSeersTurn :: Game -> Property -prop_checkVillagesTurnAdvancesToSeersTurn game = - forAll (runArbitraryCommands n game') $ \game'' -> - not (null . filterAlive . filterSeers $ run_ checkStage game'' ^. players) - ==> isSeersTurn $ run_ checkStage game'' - where - game' = game { _stage = VillagesTurn } - n = length $ game' ^. players +prop_checkVillagesTurnAdvancesToSeersTurn :: GameWithLynchVotes -> Property +prop_checkVillagesTurnAdvancesToSeersTurn (GameWithLynchVotes game) = + any isSeer (filterAlive $ run_ checkStage game ^. players) + ==> isSeersTurn $ run_ checkStage game -prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: Game -> Property -prop_checkVillagesTurnLynchesOnePlayerWhenConsensus game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> length (filterDead $ run_ checkStage game'' ^. players) == 1 - where - game' = game { _stage = VillagesTurn } - n = length $ game' ^. players +prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: GameWithLynchVotes -> Property +prop_checkVillagesTurnLynchesOnePlayerWhenConsensus (GameWithLynchVotes game) = + length (getVoteResult game) == 1 + ==> length (filterDead $ run_ checkStage game ^. players) == 1 +-- TODO (hjw) prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats :: Game -> Property prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats game = forAll (runArbitraryCommands n game') $ \game'' -> length (getVoteResult game'') > 1 ==> length (filterDead $ run_ checkStage game'' ^. players) == length (filterDead $ game' ^. players) where - game' = (foldl killPlayer game (filterScapegoats $ game ^. players)) { _stage = VillagesTurn } - n = length $ game' ^. players - -prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: Game -> Property -prop_checkVillagesTurnLynchesScapegoatWhenConflicted game = - forAll (runArbitraryCommands n game') $ \game'' -> and [ - length (getVoteResult game'') > 1, - any isScapegoat $ game' ^. players - ] ==> isScapegoat $ head (filterDead $ run_ checkStage game'' ^. players) - where - game' = game { _stage = VillagesTurn } + game' = foldl killPlayer game (filterScapegoats $ game ^. players) & stage .~ VillagesTurn n = length $ game' ^. players -prop_checkVillagesTurnResetsVotes :: Game -> Property -prop_checkVillagesTurnResetsVotes game = - forAll (runArbitraryCommands n game') $ \game'' -> - Map.null $ run_ checkStage game'' ^. votes - where - game' = game { _stage = VillagesTurn } - n = length $ game' ^. players +prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: GameWithLynchVotes -> Property +prop_checkVillagesTurnLynchesScapegoatWhenConflicted (GameWithLynchVotes game) = + length (getVoteResult game) > 1 + ==> isScapegoat $ head (filterDead $ run_ checkStage game ^. players) -prop_checkVillagesTurnDoesNothingUnlessAllVoted :: Game -> Property -prop_checkVillagesTurnDoesNothingUnlessAllVoted game = - forAll (runArbitraryCommands n game') $ \game'' -> - isVillagesTurn $ run_ checkStage game'' - where - game' = game { _stage = VillagesTurn } - n = length (game' ^. players) - 1 +prop_checkVillagesTurnResetsVotes :: GameWithLynchVotes -> Bool +prop_checkVillagesTurnResetsVotes (GameWithLynchVotes game) = + Map.null $ run_ checkStage game ^. votes -prop_checkWerewolvesTurnAdvancesToWitchsTurn :: Game -> Property -prop_checkWerewolvesTurnAdvancesToWitchsTurn game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> isWitchsTurn $ run_ checkStage game'' +prop_checkVillagesTurnDoesNothingUnlessAllVoted :: GameAtVillagesTurn -> Property +prop_checkVillagesTurnDoesNothingUnlessAllVoted (GameAtVillagesTurn game) = + forAll (runArbitraryCommands n game) $ \game' -> + isVillagesTurn $ run_ checkStage game' where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players + n = length (game ^. players) - 1 -prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured :: Game -> Property -prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured game = - forAll (arbitraryWitch game) $ \witch -> - let devourVoteCommands = map (\werewolf -> devourVoteCommand (werewolf ^. name) (witch ^. name)) (filterWerewolves $ game ^. players) - game'' = foldl (flip $ run_ . apply) game' devourVoteCommands - in isWitchsTurn $ run_ checkStage game'' - where - game' = game { _stage = WerewolvesTurn } +prop_checkWerewolvesTurnAdvancesToWitchsTurn :: GameWithDevourVotes -> Property +prop_checkWerewolvesTurnAdvancesToWitchsTurn (GameWithDevourVotes game) = + length (getVoteResult game) == 1 + ==> isWitchsTurn $ run_ checkStage game -prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned :: Game -> Bool -prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned game = +prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned :: GameWithDevourVotes -> Bool +prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned (GameWithDevourVotes game) = not . isWitchsTurn $ run_ checkStage game' where - game' = game { _stage = WerewolvesTurn, _healUsed = True, _poisonUsed = True } - -prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus :: Game -> Property -prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> length (filterDead . filter (not . isWitch) $ run_ checkStage game'' ^. players) == 1 - where - game' = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players - -prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: Gen Bool -prop_checkWerewolvesTurnKillsNoOneWhenConflicted = do - game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) > 1 - - return . isNothing . getDevourEvent $ run_ checkStage game + game' = game & healUsed .~ True & poisonUsed .~ True -prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended :: Gen Bool -prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended = do - game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) == 1 - let game' = game { _protect = Just $ head (getVoteResult game) ^. name } +prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus :: GameWithDevourVotes -> Property +prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus (GameWithDevourVotes game) = + length (getVoteResult game) == 1 + ==> isJust . getDevourEvent $ run_ checkStage game - return . isNothing . getDevourEvent $ run_ checkStage game' +prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: GameWithDevourVotes -> Property +prop_checkWerewolvesTurnKillsNoOneWhenConflicted (GameWithDevourVotes game) = + length (getVoteResult game) > 1 + ==> isNothing . getDevourEvent $ run_ checkStage game -prop_checkWerewolvesTurnResetsProtect :: Gen Bool -prop_checkWerewolvesTurnResetsProtect = do - game <- arbitraryGameWithProtectAndDevourVotes +prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended :: GameWithProtectAndDevourVotes -> Property +prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended (GameWithProtectAndDevourVotes game) = + length (getVoteResult game) == 1 + ==> isNothing . getDevourEvent $ run_ checkStage game' + where + target = head $ getVoteResult game + game' = game & protect .~ Just (target ^. name) - return . isNothing $ run_ checkStage game ^. protect +prop_checkWerewolvesTurnResetsProtect :: GameWithProtectAndDevourVotes -> Bool +prop_checkWerewolvesTurnResetsProtect (GameWithProtectAndDevourVotes game) = + isNothing $ run_ checkStage game ^. protect -prop_checkWerewolvesTurnResetsVotes :: Game -> Property -prop_checkWerewolvesTurnResetsVotes game = - forAll (runArbitraryCommands n game') $ \game'' -> - Map.null $ run_ checkStage game'' ^. votes - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_checkWerewolvesTurnResetsVotes :: GameWithDevourVotes -> Bool +prop_checkWerewolvesTurnResetsVotes (GameWithDevourVotes game) = + Map.null $ run_ checkStage game ^. votes -prop_checkWerewolvesTurnDoesNothingUnlessAllVoted :: Game -> Property -prop_checkWerewolvesTurnDoesNothingUnlessAllVoted game = - forAll (runArbitraryCommands n game') $ \game'' -> - isWerewolvesTurn $ run_ checkStage game'' +prop_checkWerewolvesTurnDoesNothingUnlessAllVoted :: GameAtWerewolvesTurn -> Property +prop_checkWerewolvesTurnDoesNothingUnlessAllVoted (GameAtWerewolvesTurn game) = + forAll (runArbitraryCommands n game) $ \game' -> + isWerewolvesTurn $ run_ checkStage game' where - game' = game { _stage = WerewolvesTurn } - n = length (filterWerewolves $ game' ^. players) - 1 + n = length (filterWerewolves $ game ^. players) - 1 -prop_checkWitchsTurnAdvancesToVillagesTurn :: Game -> Property -prop_checkWitchsTurnAdvancesToVillagesTurn game = - forAll (arbitraryPassCommand game') $ \command -> - isVillagesTurn $ run_ (apply command >> checkStage) game' - where - game' = game { _stage = WitchsTurn } +prop_checkWitchsTurnAdvancesToVillagesTurn :: GameAtWitchsTurn -> Property +prop_checkWitchsTurnAdvancesToVillagesTurn (GameAtWitchsTurn game) = + forAll (arbitraryPassCommand game) $ \(Blind command) -> + isVillagesTurn $ run_ (apply command >> checkStage) game +-- TODO (hjw) prop_checkWitchsTurnHealsDevoureeWhenHealed :: Game -> Property prop_checkWitchsTurnHealsDevoureeWhenHealed game = forAll (runArbitraryCommands n game') $ \game'' -> @@ -270,69 +209,51 @@ ==> let target = head $ getVoteResult game'' in not (isWitch target) ==> let game''' = run_ checkStage game'' - in forAll (arbitraryHealCommand game''') $ \command -> - forAll (arbitraryPassCommand game''') $ \passCommand -> + in forAll (arbitraryHealCommand game''') $ \(Blind command) -> + forAll (arbitraryPassCommand game''') $ \(Blind passCommand) -> null . filterDead $ run_ checkStage (run_ (apply passCommand) $ run_ (apply command) game''' ) ^. players where - game' = game { _stage = WerewolvesTurn } + game' = game & stage .~ WerewolvesTurn n = length . filterWerewolves $ game' ^. players -prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: Game -> Property -prop_checkWitchsTurnKillsOnePlayerWhenPoisoned game = - forAll (arbitraryPoisonCommand game') $ \command -> - forAll (arbitraryPassCommand game') $ \passCommand -> - length (filterDead $ run_ (apply command >> apply passCommand >> checkStage) game' ^. players) == 1 - where - game' = game { _stage = WitchsTurn } - -prop_checkWitchsTurnDoesNothingWhenPassed :: Game -> Property -prop_checkWitchsTurnDoesNothingWhenPassed game = - forAll (arbitraryPassCommand game') $ \command -> - null . filterDead $ run_ (apply command >> checkStage) game' ^. players - where - game' = game { _stage = WitchsTurn } +prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: GameWithPoison -> Property +prop_checkWitchsTurnKillsOnePlayerWhenPoisoned (GameWithPoison game) = + forAll (arbitraryPassCommand game) $ \(Blind command) -> + length (filterDead $ run_ (apply command >> checkStage) game ^. players) == 1 -prop_checkWitchsTurnResetsHeal :: Game -> Property -prop_checkWitchsTurnResetsHeal game = - forAll (runArbitraryCommands n game') $ \game'' -> - length (getVoteResult game'') == 1 - ==> let target = head $ getVoteResult game'' - in not (isWitch target) - ==> let game''' = run_ checkStage game'' - in forAll (arbitraryHealCommand game''') $ \command -> - forAll (arbitraryPassCommand game''') $ \passCommand -> - not $ run_ checkStage - (run_ (apply passCommand) $ - run_ (apply command) game''' - ) ^. heal - where - game' = game { _stage = WerewolvesTurn } - n = length . filterWerewolves $ game' ^. players +prop_checkWitchsTurnDoesNothingWhenPassed :: GameAtWitchsTurn -> Property +prop_checkWitchsTurnDoesNothingWhenPassed (GameAtWitchsTurn game) = + forAll (arbitraryPassCommand game) $ \(Blind command) -> + null . filterDead $ run_ (apply command >> checkStage) game ^. players +prop_checkWitchsTurnResetsHeal :: GameWithHeal -> Property +prop_checkWitchsTurnResetsHeal (GameWithHeal game) = + forAll (arbitraryPassCommand game) $ \(Blind command) -> + not $ run_ (apply command >> checkStage) game ^. heal -prop_checkWitchsTurnResetsPoison :: Game -> Property -prop_checkWitchsTurnResetsPoison game = - forAll (arbitraryPoisonCommand game') $ \command -> - isNothing $ run_ (apply command >> checkStage) game' ^. poison - where - game' = game { _stage = WitchsTurn } +prop_checkWitchsTurnResetsPoison :: GameWithPoison -> Property +prop_checkWitchsTurnResetsPoison (GameWithPoison game) = + forAll (arbitraryPassCommand game) $ \(Blind command) -> + isNothing $ run_ (apply command >> checkStage) game ^. poison +-- TODO (hjw) prop_checkGameOverAdvancesStage :: Game -> Property prop_checkGameOverAdvancesStage game = forAll (sublistOf $ game ^. players) $ \players' -> let game' = foldl killPlayer game players' in - length (nub . map (_allegiance . _role) . filterAlive $ game' ^. players) <= 1 + length (nub . map (view $ role . allegiance) . filterAlive $ game' ^. players) <= 1 ==> isGameOver $ run_ checkGameOver game' +-- TODO (hjw) prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive :: Game -> Property prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive game = not (isGameOver game) ==> forAll (sublistOf $ game ^. players) $ \players' -> let game' = foldl killPlayer game players' in - length (nub . map (_allegiance . _role) . filterAlive $ game' ^. players) > 1 + length (nub . map (view $ role . allegiance) . filterAlive $ game' ^. players) > 1 ==> not . isGameOver $ run_ checkGameOver game' prop_startGameStartsWithSunsetStage :: Property @@ -347,65 +268,81 @@ prop_startGameErrorsUnlessUniquePlayerNames :: Game -> Property prop_startGameErrorsUnlessUniquePlayerNames game = - forAll (elements players') $ \player -> isLeft (runExcept . runWriterT $ startGame "" (player:players')) + forAll (elements players') $ \player -> + isLeft (runExcept . runWriterT $ startGame "" (player:players')) where players' = game ^. players prop_startGameErrorsWhenLessThan7Players :: [Player] -> Property prop_startGameErrorsWhenLessThan7Players players = length players < 7 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan24Players :: Property prop_startGameErrorsWhenMoreThan24Players = forAll (resize 30 $ listOf arbitrary) $ \players -> length players > 24 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1Defender :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Defender players = length (filterDefenders players) > 1 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1Scapegoat :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Scapegoat players = length (filterScapegoats players) > 1 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1Seer :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Seer players = length (filterSeers players) > 1 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1VillagerVillager :: [Player] -> Property prop_startGameErrorsWhenMoreThan1VillagerVillager players = length (filterVillagerVillagers players) > 1 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_startGameErrorsWhenMoreThan1Witch :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Witch players = length (filterWitches players) > 1 - ==> isLeft (runExcept . runWriterT $ startGame "" players) + ==> isLeft . runExcept . runWriterT $ startGame "" players prop_createPlayersUsesGivenPlayerNames :: [Text] -> [Role] -> Property -prop_createPlayersUsesGivenPlayerNames playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . (playerNames ==) . map _name +prop_createPlayersUsesGivenPlayerNames playerNames extraRoles = monadicIO $ do + players <- createPlayers playerNames extraRoles + return $ playerNames == map (view name) players + prop_createPlayersUsesGivenRoles :: [Text] -> [Role] -> Property -prop_createPlayersUsesGivenRoles playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . isSubsequenceOf extraRoles . map _role +prop_createPlayersUsesGivenRoles playerNames extraRoles = monadicIO $ do + players <- createPlayers playerNames extraRoles + return $ extraRoles `isSubsequenceOf` map (view role) players + prop_createPlayersCreatesAlivePlayers :: [Text] -> [Role] -> Property -prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . all ((Alive ==) . _state) +prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ do + players <- createPlayers playerNames extraRoles + return $ all isAlive players + prop_randomiseRolesReturnsNRoles :: [Role] -> Int -> Property -prop_randomiseRolesReturnsNRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . (==) n . length +prop_randomiseRolesReturnsNRoles extraRoles n = monadicIO $ do + roles <- randomiseRoles extraRoles n + return $ length roles == n + prop_randomiseRolesUsesGivenRoles :: [Role] -> Int -> Property -prop_randomiseRolesUsesGivenRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . isSubsequenceOf extraRoles +prop_randomiseRolesUsesGivenRoles extraRoles n = monadicIO $ do + roles <- randomiseRoles extraRoles n + return $ extraRoles `isSubsequenceOf` roles + prop_randomiseRolesProportionsAllegiances :: [Role] -> Int -> Property prop_randomiseRolesProportionsAllegiances extraRoles n = monadicIO $ do roles <- randomiseRoles extraRoles n - let werewolvesCount = length . elemIndices Role.Werewolves $ map _allegiance roles + let werewolvesCount = length . elemIndices Role.Werewolves $ map (view allegiance) roles - return $ n `quot` 6 + 1 == werewolvesCount + return $ werewolvesCount == n `quot` 6 + 1 diff --git a/werewolf.cabal b/werewolf.cabal --- a/werewolf.cabal +++ b/werewolf.cabal @@ -1,5 +1,5 @@ name: werewolf -version: 0.4.3.2 +version: 0.4.4.0 author: Henry J. Wylde maintainer: public@hjwylde.com @@ -49,16 +49,16 @@ other-extensions: OverloadedStrings build-depends: - aeson >= 0.8, + aeson >= 0.8 && < 0.11, base >= 4.8 && < 5, - directory >= 1.2, - extra >= 1.4, - filepath >= 1.4, - lens >= 4.12, - mtl >= 2.2, - optparse-applicative >= 0.11, - text >= 1.2, - transformers >= 0.4, + directory == 1.2.*, + extra == 1.4.*, + filepath == 1.4.*, + lens >= 4.12 && < 4.14, + mtl == 2.2.*, + optparse-applicative >= 0.11 && < 0.13, + text == 1.2.*, + transformers == 0.4.*, werewolf library @@ -81,18 +81,18 @@ RankNTypes, TemplateHaskell build-depends: - aeson >= 0.8, + aeson >= 0.8 && < 0.11, base >= 4.8 && < 5, - containers >= 0.5, - directory >= 1.2, - extra >= 1.4, - filepath >= 1.4, - lens >= 4.12, - MonadRandom >= 0.4, - mtl >= 2.2, + containers == 0.5.*, + directory == 1.2.*, + extra == 1.4.*, + filepath == 1.4.*, + lens >= 4.12 && < 4.14, + MonadRandom == 0.4.*, + mtl == 2.2.*, random-shuffle, - text >= 1.2, - transformers >= 0.4 + text == 1.2.*, + transformers == 0.4.* test-suite werewolf-test type: exitcode-stdio-1.0 @@ -112,12 +112,12 @@ OverloadedStrings build-depends: base >= 4.8 && < 5, - containers >= 0.5, - extra >= 1.4, - lens >= 4.12, - mtl >= 2.2, - QuickCheck >= 2.8, + containers == 0.5.*, + extra == 1.4.*, + lens >= 4.12 && < 4.14, + mtl == 2.2.*, + QuickCheck == 2.8.*, tasty >= 0.10 && < 0.12, - tasty-quickcheck >= 0.8, - text >= 1.2, + tasty-quickcheck == 0.8.*, + text == 1.2.*, werewolf