diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haverer.cabal b/haverer.cabal new file mode 100644 --- /dev/null +++ b/haverer.cabal @@ -0,0 +1,92 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +-- Initial haverer.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: haverer +version: 0.1.0.0 +synopsis: Implementation of the rules of Love Letter +description: Implementation of the rules of Love Letter +license: Apache-2.0 +license-file: LICENSE +author: Jonathan M. Lange +maintainer: jml@mumak.net +copyright: Jonathan M. Lange +category: Game +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com:jml/haverer.git + +library + hs-source-dirs: lib + build-depends: base >=4.8 && <4.9 + , containers + , lens >= 4.7 + , random-shuffle + , MonadRandom + , tasty >= 0.7 + , tasty-quickcheck + , basic-prelude >= 0.4.1 && < 0.5 + , text >= 1.2 && < 1.3 + , errors >= 1.4.7 && < 1.5 + , mtl >= 2.2 && <2.3 + exposed-modules: Haverer + , Haverer.Action + , Haverer.CLI.CommandLine + , Haverer.CLI.Prompt + , Haverer.Deck + , Haverer.Engine + , Haverer.Game + , Haverer.Internal.Counter + , Haverer.Internal.Error + , Haverer.Internal.Ring + , Haverer.Player + , Haverer.Round + , Haverer.Testing + , Haverer.ValidMoves + default-language: Haskell2010 + ghc-options: -Wall + +executable haverer + main-is: Main.hs + build-depends: base >=4.8 && <4.9 + , haverer + , basic-prelude >= 0.4.1 && < 0.5 + , text >= 1.2 && < 1.3 + hs-source-dirs: src/cli + default-language: Haskell2010 + + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test.hs + ghc-options: -Wall + build-depends: + base >=4.8 && <4.9 + , tasty >= 0.7 + , tasty-hunit + , tasty-quickcheck + , haverer + , random-shuffle + , containers + , basic-prelude >= 0.4.1 && < 0.5 + , text >= 1.2 && < 1.3 + , errors >= 1.4.7 && < 1.5 + , mtl >= 2.2 && <2.3 diff --git a/lib/Haverer.hs b/lib/Haverer.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer.hs @@ -0,0 +1,83 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-| Implementation of the rules of Love Letter. -} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Haverer ( + Game, + makeGame, + newRound, + newRound', + players, + roundsPlayed, + finalScores, + scores, + winners, + Round, + BadAction, + Result(..), + Event(..), + playTurn, + playTurn', + getPlayers, + getPlayerMap, + currentPlayer, + currentTurn, + Card(..), + Deck, + Complete, + newDeck, + Play(..), + viewAction, + Player, + getDiscards, + getHand, + isProtected, + toPlayers, + toPlayerSet, + ) where + + +import Haverer.Action (Play(..), viewAction) +import Haverer.Deck (Card(..), Complete, Deck, newDeck) +import Haverer.Game ( + Game, + finalScores, + makeGame, + newRound, + newRound', + players, + roundsPlayed, + scores, + winners) +import Haverer.Player ( + Player, + getDiscards, + getHand, + isProtected, + toPlayers, + toPlayerSet) +import Haverer.Round ( + BadAction, + Result(..), + Round, + Event(..), + currentPlayer, + currentTurn, + getPlayers, + getPlayerMap, + playTurn, + playTurn') diff --git a/lib/Haverer/Action.hs b/lib/Haverer/Action.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Action.hs @@ -0,0 +1,125 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Haverer.Action ( + BadPlay, + Play(..), + Action, + bustingHand, + getTarget, + getValidPlays, + playToAction, + viewAction + ) where + +import BasicPrelude +import Control.Monad.Except + +import Haverer.Deck (Card(..)) + + +-- | A thing that can be done with a card. +data Play target = NoEffect | Attack target | Guess target Card deriving (Eq, Show) + +-- | A validated card + play combination. +-- Only guarantees that such a thing makes sense according to the rules, +-- rather than the current state of the round. +data Action target = Action target Card (Play target) deriving (Eq, Show) + +data BadPlay target = BadActionForCard (Play target) Card -- ^ If that play and card are forbidden by the rules + | BadGuess -- ^ If they try to guess a soldier + | SelfTarget -- ^ If they try to target themselves when forbidden + deriving Show + + +viewAction :: Action target -> (target, Card, Play target) +viewAction (Action pid card play) = (pid, card, play) + + +getTarget :: Play target -> Maybe target +getTarget NoEffect = Nothing +getTarget (Attack target) = Just target +getTarget (Guess target _) = Just target + + +-- | Given a player, a card, and a choice of play, decide whether it's a valid +-- action. +playToAction :: (Eq target, MonadError (BadPlay target) m) => target -> Card -> Play target -> m (Action target) +playToAction pid card play = Action pid card <$> _validatePlay pid card play + + +_validatePlay :: (Eq target, MonadError (BadPlay target) m) => target -> Card -> Play target -> m (Play target) +_validatePlay _ Soldier (Guess _ Soldier) = throwError BadGuess +_validatePlay player Soldier play@(Guess target _) + | player == target = throwError SelfTarget + | otherwise = return play +_validatePlay player Clown play@(Attack target) + | player == target = throwError SelfTarget + | otherwise = return play +_validatePlay player Knight play@(Attack target) + | player == target = throwError SelfTarget + | otherwise = return play +_validatePlay _ Priestess NoEffect = return NoEffect +_validatePlay _ Wizard play@(Attack _) = return play +_validatePlay player General play@(Attack target) + | player == target = throwError SelfTarget + | otherwise = return play +_validatePlay _ Minister NoEffect = return NoEffect +_validatePlay _ Prince NoEffect = return NoEffect +_validatePlay _ card play = throwError (BadActionForCard play card) + + +-- | Return all valid plays for a particular card. +getValidPlaysForCard :: target -- ^ The current player + -> [target] -- ^ All other active players in the round + -> Card -- ^ The card they wish to play + -> [Play target] -- ^ All valid plays for that card +getValidPlaysForCard self others card = + case card of + Soldier -> [Guess tgt c | tgt <- others, c <- [Clown ..]] + Clown -> fmap Attack others + Knight -> fmap Attack others + Priestess -> [NoEffect] + Wizard -> fmap Attack (self:others) + General -> fmap Attack others + Minister -> [NoEffect] + Prince -> [NoEffect] + + +-- | Return all valid plays for a hand. +-- +-- If the hand is one that would bust out (see 'bustingHand') then returns an +-- empty list. +getValidPlays :: player -- ^ The current player + -> [player] -- ^ All other active players in the round + -> Card -- ^ The card they were dealt + -> Card -- ^ The card that was in their hand + -> [(Card, Play player)] -- ^ All valid plays +getValidPlays self others dealt hand = do + guard $ not $ bustingHand dealt hand + [(dealt, play) | play <- playsForCard dealt] ++ + [(hand, play) | play <-playsForCard hand] + where playsForCard = getValidPlaysForCard self others + + +-- | If you're holding the Minister, there's a potential to "bust out" -- to +-- have to immediately leave the round because you're holding another high +-- card. +bustingHand :: Card -> Card -> Bool +bustingHand Minister card = card >= Wizard +bustingHand card Minister = bustingHand Minister card +bustingHand _ _ = False diff --git a/lib/Haverer/CLI/CommandLine.hs b/lib/Haverer/CLI/CommandLine.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/CLI/CommandLine.hs @@ -0,0 +1,204 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haverer.CLI.CommandLine ( + ConsoleText(..), + formatScores, + pickNumPlayers, + pickCardToPlay, + pickPlay + ) where + +import BasicPrelude hiding (round) +import Control.Error hiding (readMay) + +import qualified Data.Map as Map + +import Haverer.Action (Play(..), viewAction) +import Haverer.Deck (Card(..)) +import Haverer.Player (PlayerSet, getDiscards, isProtected, toPlayers) +import Haverer.Round ( + Event(..), + Result(..), + Round, + Victory(..), + getPlayerMap, + remainingCards + ) + +import Haverer.CLI.Prompt ( + ConsoleText, + repeatedlyPrompt, + chooseItem, + chooseItem', + underline, + toText + ) + + + +instance ConsoleText Card where + toText = show + + +instance ConsoleText a => ConsoleText (Round a) where + + toText round = + "Cards remaining: " ++ show (remainingCards round) ++ ".\n\n" ++ + underline '-' "All discards" ++ "\n" ++ + Map.foldrWithKey (\k a b -> formatPlayer k a ++ "\n" ++ b) "" (getPlayerMap round) + where + formatPlayer pid player = + toText pid ++ ": " ++ intercalate ", " (map toText (getDiscards player)) ++ playerStatus player + playerStatus player = + case isProtected player of + Just True -> " (protected)" + Just False -> "" + Nothing -> " (eliminated)" + + +instance (Eq a, ConsoleText a, Show a) => ConsoleText (Result a) where + + -- FIXME: Don't have quite enough information here to disambiguate between + -- Soldier attack failing due to wrong guess and Soldier attack failing due to + -- Priestess. + toText (Played (viewAction -> (pid1, Soldier, Guess pid2 card)) NoChange) = + toText pid1 ++ " wrongly guessed " ++ toText pid2 ++ " had a " ++ toText card + ++ ". Nothing happened, maybe it was the right guess and they were protected." + + -- FIXME: Don't have quite enough information here to disambiguate between + -- Knight attack failing due to tie and Knight attack failing due to + -- Priestess. + toText (Played (viewAction -> (pid1, Knight, Attack pid2)) NoChange) = + toText pid1 ++ " attacked " ++ toText pid2 ++ " with a Knight, but nothing happened. " + ++ "Because of a bug in the software, you don't know if it's because of a tie or " + ++ "because " ++ toText pid2 ++ " is protected by the Priestess." + + toText (Played (viewAction -> (pid1, card, Attack pid2)) NoChange) = + toText pid1 ++ " played " ++ toText card ++ " against " ++ toText pid2 ++ + ", but they were protected by the Priestess, so nothing happened" + + toText (Played (viewAction -> (pid1, card, NoEffect)) NoChange) = + toText pid1 ++ " played " ++ toText card + + toText (BustedOut pid c1 c2) = + toText pid ++ " busted out, holding " ++ toText c1 ++ " and " ++ toText c2 + + toText (Played (viewAction -> (pid, Priestess, _)) (Protected p)) + | p == pid = + toText pid ++ " played Priestess, protecting themselves from harm" + | otherwise = error "BUG: " ++ show pid ++ " played Priestess but ended up protecting " ++ show p + + toText (Played _ (SwappedHands pid1 pid2)) = + toText pid2 ++ " swapped hands with " ++ toText pid1 + + toText (Played (viewAction -> (pid1, Soldier, Guess pid2 card)) (Eliminated loser)) + | loser == pid2 = + toText pid1 ++ " correctly guessed " ++ toText pid2 ++ " had a " ++ toText card + ++ ". " ++ toText pid2 ++ " has been eliminated" + | otherwise = error "BUG: Soldier attacked " ++ show pid2 ++ " but eliminated " ++ show loser + + toText (Played (viewAction -> (pid1, Knight, Attack pid2)) (Eliminated loser)) = + toText pid1 ++ " attacked " ++ toText pid2 ++ " with a Knight " ++ + (if loser == pid1 + then "and lost. " + else (if loser == pid2 then "and won. " else error "BUG: Knight!")) ++ + toText loser ++ " has been eliminated" + + toText (Played (viewAction -> (pid1, Prince, NoEffect)) (Eliminated loser)) + | loser == pid1 = toText pid1 ++ " played the Prince, eliminating themselves" + | otherwise = error "BUG: " ++ show pid1 ++ " played Prince, but " ++ show loser ++ " eliminated." + + -- FIXME: There are two reasons they could lose here: 1. Discard Prince, 2. + -- Discard last card. Disambiguate between them. + toText (Played (viewAction -> (pid1, Wizard, Attack pid2)) (Eliminated loser)) + | loser == pid2 = + toText pid1 ++ " played Wizard on " ++ toText pid2 ++ " forcing them to discard " + ++ "and thus be eliminated from the round" + | otherwise = error "BUG: Wizard attacked " ++ show pid2 ++ " but eliminated " ++ show loser + + toText (Played _ (ForcedDiscard pid)) = + toText pid ++ " was forced to discard their hand and draw another card" + + -- XXX: This is revealed to all who are watching the console. + toText (Played _ (ForcedReveal pid1 pid2 card)) = + toText pid1 ++ ": " ++ toText pid2 ++ " is holding a " ++ toText card + + toText event = "UNKNOWN: " ++ show event + + +instance ConsoleText a => ConsoleText (Victory a) where + toText (SoleSurvivor pid card) = + toText pid ++ " wins as the only remaining player, holding " ++ toText card + toText (HighestCard card [winner] _) = + toText winner ++ " wins holding " ++ toText card + toText (HighestCard card winners _) = + "Many winners holding " ++ toText card ++ ": " ++ intercalate ", " (map toText winners) + + +formatScores :: ConsoleText playerId => [(playerId, Int)] -> Text +formatScores scores = + underline '-' "Scores" ++ "\n" ++ + unlines (map formatScore scores) + where formatScore (pid, score) = toText pid ++ ": " ++ toText score + + +pickNumPlayers :: IO Int +pickNumPlayers = + repeatedlyPrompt "Pick number of players: " parseNumPlayers + where + parseNumPlayers s = do + i <- note errMsg (readMay s) + assertErr errMsg (2 <= i && i <= 4) + return i + errMsg = "Please enter a number between 2 and 4" :: Text + + +pickCardToPlay :: (Card, Card) -> IO Card +pickCardToPlay (dealt, hand) = + chooseItem "\nPlease choose a card: " [dealt, hand] + + +pickPlay :: ConsoleText playerId => Card -> PlayerSet playerId -> IO (Play playerId) +pickPlay card players = + case card of + Soldier -> pickGuess players + Clown -> pickAttack players + Knight -> pickAttack players + Priestess -> return NoEffect + Wizard -> pickAttack players + General -> pickAttack players + Minister -> return NoEffect + Prince -> return NoEffect + + +-- XXX: Exclude self-targeting when it's not legal +pickTarget :: ConsoleText playerId => PlayerSet playerId -> IO playerId +pickTarget ps = chooseItem "\nPlease choose a target: " (toPlayers ps) + +pickAttack :: ConsoleText playerId => PlayerSet playerId -> IO (Play playerId) +pickAttack players = fmap Attack (pickTarget players) + +pickGuess :: ConsoleText playerId => PlayerSet playerId -> IO (Play playerId) +pickGuess players = do + target <- pickTarget players + guess <- pickGuessCard + return $ Guess target guess + where pickGuessCard = chooseItem' "\nWhat card do they have?" 2 [Clown ..] diff --git a/lib/Haverer/CLI/Prompt.hs b/lib/Haverer/CLI/Prompt.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/CLI/Prompt.hs @@ -0,0 +1,76 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Haverer.CLI.Prompt where + +import BasicPrelude + +import Control.Error hiding (readMay) +import qualified Data.Text as Text +import System.IO (hFlush, stdout) + + +class ConsoleText a where + toText :: a -> Text + +instance ConsoleText Text where + toText = id + +instance ConsoleText Int where + toText = show + + +underline :: Char -> Text -> Text +underline char string = string ++ Text.pack ('\n':replicate (Text.length string) char) + + +prompt :: ConsoleText e => Text -> (Text -> Either e a) -> IO (Either e a) +prompt promptStr parser = do + putStr promptStr + hFlush stdout + input <- getLine + return $ parser input + + +repeatedlyPrompt :: ConsoleText e => Text -> (Text -> Either e a) -> IO a +repeatedlyPrompt promptStr parser = do + result <- prompt promptStr parser + case result of + Left e -> do + putStrLn $ toText e + repeatedlyPrompt promptStr parser + Right r -> return r + + +chooseItem :: ConsoleText a => Text -> [a] -> IO a +chooseItem promptStr = chooseItem' promptStr 1 + +-- XXX: Crazier: Allow specifying generic Idx +chooseItem' :: ConsoleText a => Text -> Int -> [a] -> IO a +chooseItem' promptStr startIndex items = + repeatedlyPrompt fullPrompt (pickItem items) + where + fullPrompt = + promptStr ++ "\n" ++ + intercalate "\n" [toText (i :: Int) ++ ". " ++ toText x | (i, x) <- zip [startIndex ..] items] + ++ "\n>>> " + pickItem xs chosen = note errMsg $ do + i <- readMay chosen + xs `atMay` (i - startIndex) + errMsg = "Please select an item from the list" :: Text diff --git a/lib/Haverer/Deck.hs b/lib/Haverer/Deck.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Deck.hs @@ -0,0 +1,97 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} + + +module Haverer.Deck ( + allCards, + baseCards, + Card(..), + Complete, + deal, + Deck, + Incomplete, + makeDeck, + newDeck, + pop, + shuffleDeck, + toList + ) where + + +import BasicPrelude + +import Control.Monad.Random (MonadRandom) +import System.Random.Shuffle (shuffleM) + + +data Card = Soldier | Clown | Knight | Priestess | Wizard | General | Minister | Prince + deriving (Eq, Show, Ord, Enum) + + +allCards :: [Card] +allCards = [Soldier ..] + + +data Complete +data Incomplete + +newtype Deck a = Deck [Card] deriving (Eq, Show, Ord) + +baseCards :: [Card] +baseCards = [ + Soldier + , Soldier + , Soldier + , Soldier + , Soldier + , Clown + , Clown + , Knight + , Knight + , Priestess + , Priestess + , Wizard + , Wizard + , General + , Minister + , Prince + ] + +baseDeck :: Deck Complete +baseDeck = Deck baseCards + +shuffleDeck :: MonadRandom m => Deck a -> m (Deck a) +shuffleDeck (Deck d) = liftM Deck $ shuffleM d + +newDeck :: MonadRandom m => m (Deck Complete) +newDeck = shuffleDeck baseDeck + +makeDeck :: [Card] -> Maybe (Deck Complete) +makeDeck cards = + if sort cards == baseCards then Just (Deck cards) else Nothing + +pop :: Deck a -> (Maybe Card, Deck Incomplete) +pop (Deck []) = (Nothing, Deck []) +pop (Deck (c:cards)) = (Just c, Deck cards) + +deal :: Deck a -> Int -> (Maybe [Card], Deck Incomplete) +deal (Deck cards) n = + case splitAt n cards of + (_, []) -> (Nothing, Deck cards) + (top, rest) -> (Just top, Deck rest) + +toList :: Deck a -> [Card] +toList (Deck xs) = xs diff --git a/lib/Haverer/Engine.hs b/lib/Haverer/Engine.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Engine.hs @@ -0,0 +1,115 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} + + +module Haverer.Engine ( + MonadEngine(..) + , playGame + ) where + +import BasicPrelude hiding (round) + +import Control.Monad.Random (MonadRandom) +import Data.Maybe (fromJust) + +import Haverer.Action (Play) +import Haverer.Deck (Card) +import qualified Haverer.Game as Game +import qualified Haverer.Round as Round +import Haverer.Player (PlayerSet) + + +class Monad m => MonadEngine m playerId where + + badPlay :: Round.BadAction playerId -> m () + badPlay _ = return () + + -- XXX: We're passing PlayerSet around everywhere just so we can have it + -- here. + choosePlay :: PlayerSet playerId -> playerId -> Card -> Card -> m (Card, Play playerId) + + gameStarted :: Game.Game playerId -> m () + gameStarted _ = return () + + gameOver :: Game.Outcome playerId -> m () + gameOver _ = return () + + roundStarted :: Game.Game playerId -> Round.Round playerId -> m () + roundStarted _ _ = return () + + roundOver :: Round.Victory playerId -> m () + roundOver _ = return () + + handStarted :: Round.Round playerId -> m () + handStarted _ = return () + + handOver :: Round.Result playerId -> m () + handOver _ = return () + + +playGame :: (Ord playerId, Show playerId, MonadRandom m, MonadEngine m playerId) => PlayerSet playerId -> m (Game.Outcome playerId) +playGame players = do + let game = Game.makeGame players + gameStarted game + outcome <- playGame' game + gameOver outcome + return outcome + + +playGame' :: (Show playerId, Ord playerId, MonadRandom m, MonadEngine m playerId) => Game.Game playerId -> m (Game.Outcome playerId) +playGame' game = do + round <- Game.newRound game + roundStarted game round + outcome <- playRound (Game.players game) round + roundOver outcome + case Game.playersWon game (Round.getWinners outcome) of + Left o -> return o + Right game' -> playGame' game' + + +playRound :: (Show playerId, Ord playerId, MonadEngine m playerId) => PlayerSet playerId -> Round.Round playerId -> m (Round.Victory playerId) +playRound players round = do + result <- playHand players round + case result of + Just round' -> playRound players round' + Nothing -> return $ fromJust $ Round.victory round + + +playHand :: (Show playerId, Ord playerId, MonadEngine m playerId) => PlayerSet playerId -> Round.Round playerId -> m (Maybe (Round.Round playerId)) +playHand players r = + case Round.currentTurn r of + Nothing -> return Nothing + Just (player, (dealt, hand)) -> do + handStarted r + (event, round') <- getPlay players r player dealt hand + handOver event + return $ Just round' + + +getPlay :: (Ord playerId, Show playerId, MonadEngine m playerId) => PlayerSet playerId -> Round.Round playerId -> playerId -> Card -> Card -> m (Round.Result playerId, Round.Round playerId) +getPlay players round player dealt hand = do + result <- case Round.playTurn round of + Left r -> return r + Right handlePlay -> do + (card, play) <- choosePlay players player dealt hand + return $ handlePlay card play + case result of + Left err -> do + badPlay err + getPlay players round player dealt hand + Right (event, round') -> return (event, round') diff --git a/lib/Haverer/Game.hs b/lib/Haverer/Game.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Game.hs @@ -0,0 +1,112 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} + + +module Haverer.Game ( + Game, + Outcome, + finalScores, + makeGame, + newRound, + newRound', + players, + playersWon, + roundsPlayed, + scores, + winners + ) where + +import BasicPrelude +import Control.Monad.Random (MonadRandom) + +import Haverer.Deck (Deck, Complete, newDeck) +import Haverer.Player ( + PlayerSet, + toPlayers, + ) +import Haverer.Round (Round) +import qualified Haverer.Round as Round + +import qualified Haverer.Internal.Counter as Counter + + +type PlayerScores a = Counter.Counter a Int + + +data Game playerId = Game { + _winningScore :: Int, + _players :: PlayerScores playerId, + _playerSet :: PlayerSet playerId, + _roundsPlayed :: Int + } deriving Show + + +data Outcome playerId = Outcome { _unoutcome :: PlayerScores playerId } deriving Show + + +-- | Create a new game for the given set of players. +makeGame :: Ord playerId => PlayerSet playerId -> Game playerId +makeGame ps = Game { + _winningScore = 4, -- XXX: in some rule sets, this varies based on the number of players + _players = Counter.initialize $ toPlayers ps, + _playerSet = ps, + _roundsPlayed = 0 + } + +-- | Start a new round of the game with an already-shuffled deck of cards. +newRound' :: (Ord playerId, Show playerId) => Game playerId -> Deck Complete -> Round playerId +newRound' game deck = Round.makeRound deck (_playerSet game) + +-- | Start a new round of the game, shuffling the deck cards ourselves. +newRound :: (Functor m, MonadRandom m, Ord playerId, Show playerId) => Game playerId -> m (Round playerId) +newRound game = newRound' game <$> newDeck + +-- | Indicate that the specified players won. +playersWon :: Ord playerId => Game playerId -> [playerId] -> Either (Outcome playerId) (Game playerId) +playersWon game ps = + bumpRoundsPlayed <$> onCounter game (`Counter.incrementMany` ps) + where + bumpRoundsPlayed g = g { _roundsPlayed = _roundsPlayed g + 1 } + +-- | Return the number of rounds played. +roundsPlayed :: Game playerId -> Int +roundsPlayed = _roundsPlayed + +-- | Return the current scores of all the players. +scores :: Ord playerId => Game playerId -> [(playerId, Int)] +scores = Counter.toList . _players + +-- | Return the set of all players +players :: Game playerId -> PlayerSet playerId +players = _playerSet + +-- | Get the winners of the game. +winners :: Ord playerId => Outcome playerId -> [playerId] +winners = snd . Counter.top . _unoutcome + +-- | Get the final scores at the end of the game. +finalScores :: Ord playerId => Outcome playerId -> [(playerId, Int)] +finalScores = Counter.toList . _unoutcome + + +-- | Perform an operation on the score counter. If this ends the game, return +-- a Left Outcome. +onCounter :: Ord playerId => Game playerId -> (PlayerScores playerId -> PlayerScores playerId) -> Either (Outcome playerId) (Game playerId) +onCounter game f = + let players' = f $ _players game in + if Counter.topValue players' >= _winningScore game + then Left $ Outcome players' + else Right $ game { _players = players' } diff --git a/lib/Haverer/Internal/Counter.hs b/lib/Haverer/Internal/Counter.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Internal/Counter.hs @@ -0,0 +1,56 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} + +module Haverer.Internal.Counter ( + Counter, + increment, + incrementMany, + initialize, + toList, + top, + topValue, + ) where + +import BasicPrelude +import Prelude (Foldable) + +import qualified Data.Map as Map + + +data Counter k a = Counter { _uncounter :: Map k a } deriving Show + +incrementMany :: (Ord k, Num a, Foldable m) => Counter k a -> m k -> Counter k a +incrementMany = foldl increment + +increment :: (Ord k, Num a) => Counter k a -> k -> Counter k a +increment (Counter m) key = + Counter $ Map.insertWith (+) key 1 m + + +initialize :: (Ord k, Num a) => [k] -> Counter k a +initialize keys = Counter $ Map.fromList (zip keys (repeat 0)) + +topValue :: (Ord k, Ord a) => Counter k a -> a +topValue (Counter m) = maximum $ Map.elems m + +withValue :: (Ord k, Eq a) => Counter k a -> a -> [k] +withValue (Counter m) v = Map.keys $ Map.filter (== v) m + +top :: (Ord k, Ord a, Eq a) => Counter k a -> (a, [k]) +top counter = let v = topValue counter in (v, withValue counter v) + +toList :: (Ord k) => Counter k a -> [(k, a)] +toList = Map.toList . _uncounter diff --git a/lib/Haverer/Internal/Error.hs b/lib/Haverer/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Internal/Error.hs @@ -0,0 +1,36 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haverer.Internal.Error ( + assertRight, + assertRight', + terror + ) where + +import BasicPrelude + + +-- | Assert that the value is Right. Throws error if it's Left. +assertRight :: (Show a) => Text -> Either a b -> b +assertRight _ (Right value) = value +assertRight message (Left e) = terror $ message ++ show e + + +-- | Assert that the value is Right. Throws error if it's Left. +assertRight' :: Show a => Either a b -> b +assertRight' (Right value) = value +assertRight' (Left e) = (terror . show) e diff --git a/lib/Haverer/Internal/Ring.hs b/lib/Haverer/Internal/Ring.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Internal/Ring.hs @@ -0,0 +1,100 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} + +module Haverer.Internal.Ring ( + Ring + , makeRing + , advance + , advance1 + , dropItem + , dropItem1 + , toList + , nextItem + , ringSize + , currentItem + ) where + +import BasicPrelude + +data Ring a = Ring { + _items :: [a], + _current :: Int, + _length :: Int + } deriving (Show, Eq) + + +makeRing :: [a] -> Maybe (Ring a) +makeRing [] = Nothing +makeRing xs = Just Ring { + _items = xs, + _current = 0, + _length = length xs + } + + +toList :: Ring a -> [a] +toList = _items + +advanceBy :: Int -> Ring a -> Ring a +advanceBy n ring = ring { + _current = (_current ring + n) `mod` _length ring + } + +advance :: Ring a -> Ring a +advance = advanceBy 1 + +advance1 :: Ring a -> Either a (Ring a) +advance1 ring = + case _items ring of + [x] -> Left x + _ -> Right $ advance ring + +dropItem :: (Eq a) => Ring a -> a -> Maybe (Ring a) +dropItem ring item = + case span (/=item) (_items ring) of + (_, []) -> Just ring + ([], [_]) -> Nothing + (pre, _:xs) -> + let newLength = _length ring - 1 + current = _current ring + in + Just $ ring { + _items = pre ++ xs, + _length = newLength, + _current = + if current == newLength + then (if null xs then 0 else current - 1) + else current + } + + +dropItem1 :: (Eq a) => Ring a -> a -> Either a (Ring a) +dropItem1 ring item = + case dropItem ring item of + Nothing -> Left item + Just ring' -> Right ring' + + +ringSize :: Ring a -> Int +ringSize = _length + +currentItem :: Ring a -> a +currentItem ring = _items ring !! _current ring + +nextItem :: Ring a -> a +nextItem = currentItem . advance + +-- XXX: (optional) enforce non-emptyness at the type level diff --git a/lib/Haverer/Player.hs b/lib/Haverer/Player.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Player.hs @@ -0,0 +1,123 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Haverer.Player ( + bust, + Error(..), + discardAndDraw, + eliminate, + getDiscards, + getHand, + isProtected, + makePlayer, + Player, + PlayerSet, + playCard, + protect, + swapHands, + toPlayers, + toPlayerSet, + unprotect + ) where + +import BasicPrelude +import Control.Lens hiding (chosen) +import Control.Monad.Except + +import Haverer.Deck (Card) + + +data Error a = InvalidNumPlayers Int | DuplicatePlayers [a] deriving (Show, Eq) + + +newtype PlayerSet a = PlayerSet { toPlayers :: [a] } deriving (Show, Eq) + + +toPlayerSet :: Ord a => [a] -> Either (Error a) (PlayerSet a) +toPlayerSet playerIds + | numPlayers /= numDistinctPlayers = throwError (DuplicatePlayers playerIds) + | numPlayers < 2 || numPlayers > 4 = throwError (InvalidNumPlayers numPlayers) + | otherwise = (return . PlayerSet) playerIds + where numPlayers = length playerIds + numDistinctPlayers = (length . nub . sort) playerIds + + +data Player = Active { + _hand :: Card, + _protected :: Bool, + _discard :: [Card] + } | Inactive { _discard :: [Card] } deriving (Show, Eq) + +makeLenses ''Player + +makePlayer :: Card -> Player +makePlayer card = Active { + _hand = card, + _protected = False, + _discard = [] + } + + +protect :: Player -> Player +protect = set protected True + +unprotect :: Player -> Player +unprotect = set protected False + +eliminate :: Player -> Player +eliminate player@(Inactive _) = player +eliminate (Active card _ discards) = Inactive (card:discards) + +swapHands :: Player -> Player -> (Player, Player) +swapHands player1 player2 = + case (preview hand player1, preview hand player2) of + (Just h1, Just h2) -> + (set hand h2 player1, set hand h1 player2) + _ -> (player1, player2) + + +-- Will not de-activate player if they discard a Prince. +discardAndDraw :: Player -> Maybe Card -> Player +discardAndDraw player@(Inactive _) _ = player +discardAndDraw (Active card _ discards) Nothing = Inactive (card:discards) +discardAndDraw (Active card p discards) (Just newCard) = + Active newCard p (card:discards) + + +-- | Given a dealt and chosen card, update the hand to chosen, and chuck +-- whatever wasn't played onto the discard pile. +playCard :: Player -> Card -> Card -> Maybe Player +playCard (Inactive _) _ _ = Nothing +playCard (Active hand' p discards) dealt chosen + | hand' == chosen = Just $ Active dealt p (hand':discards) + | dealt == chosen = Just $ Active hand' p (dealt:discards) + | otherwise = Nothing + + +bust :: Player -> Card -> Player +bust player@(Inactive _) _ = player +bust (Active h _ discards) dealt = Inactive (h:dealt:discards) + + +getDiscards :: Player -> [Card] +getDiscards = view discard + +getHand :: Player -> Maybe Card +getHand = preview hand + +isProtected :: Player -> Maybe Bool +isProtected = preview protected diff --git a/lib/Haverer/Round.hs b/lib/Haverer/Round.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Round.hs @@ -0,0 +1,486 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Haverer.Round ( + -- A Round of a game of Love Letter. + Round + , makeRound + , playTurn + , playTurn' + + -- The results of playTurn + , BadAction + , Result(..) + , Event(..) + + -- Information about a Round + , currentPlayer + , currentTurn + , getActivePlayers + , getPlayer + , getPlayerMap + , getPlayers + , getWinners + , nextPlayer + , remainingCards + + -- The outcome of a Round + , Victory(..) + , victory + + -- Properties used for testing that rely on unexposed fields. + , prop_allCardsPresent + , prop_burnCardsSame + , prop_multipleActivePlayers + , prop_ringIsActivePlayers + ) where + +import BasicPrelude hiding (round) + +import Control.Error +import Control.Monad.Except +import Control.Monad.State +import Control.Lens hiding (chosen) + +import Data.Maybe (fromJust) +import qualified Data.Map as Map + +import Haverer.Action ( + BadPlay, + bustingHand, + Play(..), + Action, + getTarget, + playToAction, + viewAction) +import Haverer.Deck (Card(..), Complete, Deck, deal, Incomplete, pop) +import qualified Haverer.Deck as Deck +import Haverer.Player ( + bust, + discardAndDraw, + eliminate, + getDiscards, + getHand, + isProtected, + makePlayer, + playCard, + Player, + PlayerSet, + protect, + swapHands, + toPlayers, + unprotect + ) + +import Haverer.Internal.Error (assertRight) +import Haverer.Internal.Ring (Ring, advance1, currentItem, dropItem1, makeRing, nextItem) +import qualified Haverer.Internal.Ring as Ring + + +-- XXX: Consider popping this out so that it's the constructor of the Round. +data RoundState = NotStarted | Turn Card | Playing | Over deriving Show + + +data Round playerId = Round { + _stack :: Deck Incomplete, + _playOrder :: Ring playerId, + _players :: Map playerId Player, + _roundState :: RoundState, + _burn :: Card +} deriving Show + + +makeLenses ''Round + + +-- | Make a new round, given a complete Deck and a set of players. +makeRound :: (Ord playerId, Show playerId) => Deck Complete -> PlayerSet playerId -> Round playerId +makeRound deck playerSet = + nextTurn $ case deal deck (length playerList) of + (Just cards, remainder) -> + case pop remainder of + (Nothing, _) -> terror ("Not enough cards for burn: " ++ show deck) + (Just burn', stack') -> Round { + _stack = stack', + _playOrder = fromJust (makeRing playerList), + _players = Map.fromList $ zip playerList (map makePlayer cards), + _roundState = NotStarted, + _burn = burn' + } + _ -> terror ("Given a complete deck - " ++ show deck ++ "- that didn't have enough cards for players - " ++ show playerSet) + where playerList = toPlayers playerSet + + +-- | The number of cards remaining in the deck. +remainingCards :: Round playerId -> Int +remainingCards = length . Deck.toList . view stack + + +-- | The IDs of all of the players. +getPlayers :: Round playerId -> [playerId] +getPlayers = Map.keys . view players + + +-- | The IDs of all of the active players. +getActivePlayers :: Round playerId -> [playerId] +getActivePlayers = Ring.toList . view playOrder + + +-- TODO: Rather than exporting Player, export functions that will return +-- active state, protected state and discard pile. Then move Player data type +-- and functions to somewhere hidden (Internal maybe?), because it really is +-- just as implementation detail of Round. + + +-- | A map of player IDs to players. +getPlayerMap :: Round playerId -> Map playerId Player +getPlayerMap = view players + + +-- | Get the player with the given ID. Nothing if there is no such player. +getPlayer :: Ord playerId => Round playerId -> playerId -> Maybe Player +getPlayer round pid = view (players . at pid) round + + +-- | Draw a card from the top of the Deck. Returns the card and a new Round. +drawCard :: Monad m => StateT (Round playerId) m (Maybe Card) +drawCard = do + (card, stack') <- pop <$> use stack + assign stack stack' + return card + + +-- | Progress the Round to the next turn. +nextTurn :: (Show playerId, Ord playerId) => Round playerId -> Round playerId +nextTurn round = flip execState round $ do + current <- use roundState + case current of + Over -> return () + Turn _ -> terror "Cannot advance to next turn while waiting for play." + NotStarted -> do + card <- drawCard + assign roundState $ case card of + Just card' -> Turn card' + Nothing -> Over -- XXX: Not actually possible. + Playing -> do + -- To advance to the next turn we need to make sure that there are cards + -- in the deck and that there is more than one player. + card <- drawCard + newPlayOrder <- advance1 <$> use playOrder + case (card, newPlayOrder) of + (Nothing, _) -> end round + (_, Left _) -> end round + (Just card', Right newPlayOrder') -> do + modify $ unprotectPlayer (currentItem newPlayOrder') + assign roundState (Turn card') + assign playOrder newPlayOrder' + where + end :: Round playerId -> State (Round playerId) () + end rnd = do + put rnd + assign roundState Over + unprotectPlayer pid rnd = assertRight "Couldn't unprotect current player: " + (modifyActivePlayer rnd pid unprotect) + + +-- | The ID of the current player. If the Round is over or not started, this +-- will be Nothing. +currentPlayer :: Round playerId -> Maybe playerId +currentPlayer rnd = + case view roundState rnd of + Over -> Nothing + NotStarted -> Nothing + Turn _ -> Just $ (currentItem . view playOrder) rnd + Playing -> Just $ (currentItem . view playOrder) rnd + + +currentTurn :: Ord playerId => Round playerId -> Maybe (playerId, (Card, Card)) +currentTurn rnd = do + pid <- currentPlayer rnd + hand <- getHand =<< getPlayer rnd pid + d <- dealt + return (pid, (d, hand)) + where + dealt = case view roundState rnd of + Turn d -> Just d + _ -> Nothing + + +nextPlayer :: Round playerId -> Maybe playerId +nextPlayer rnd = + case view roundState rnd of + Over -> Nothing + NotStarted -> Just $ currentItem playOrder' + Turn _ -> Just $ nextItem playOrder' + Playing -> Just $ nextItem playOrder' + where playOrder' = view playOrder rnd + + +data BadAction playerId = NoSuchPlayer playerId + | InactivePlayer playerId + | InvalidPlay (BadPlay playerId) + | WrongCard Card (Card, Card) + | PlayWhenBusted + | NoPlaySpecified + | RoundOver + deriving Show + + +-- | A change to the Round that comes as result of a player's actions. +data Event playerId = + -- | Nothing happened. What the player did had no effect. + NoChange | + -- | The player is now protected. + Protected playerId | + -- | The first player has been forced to swap hands with the second. + SwappedHands playerId playerId | + -- | The player has been eliminated from the round. + Eliminated playerId | + -- | The player has been forced to discard their hand. + ForcedDiscard playerId | + -- | The second player has been forced to show their hand to the first. + ForcedReveal playerId playerId Card + deriving (Eq, Show) + + +-- | The result of a turn. +data Result playerId = + -- | The player whose turn it was "busted out", they held the Minister and + -- another high card, and thus didn't get to play. + BustedOut playerId Card Card | + -- | The player performed an Action resulting in Event. + Played (Action playerId) (Event playerId) + deriving (Eq, Show) + + +type ActionM id a = Either (BadAction id) a + +-- | Translate a player action into a change to make to the round. +-- Will return errors if the action is for or against an inactive or +-- nonexistent player. +-- +-- If the target player is protected, will return the identity result, +-- NoChange. +actionToEvent :: (Ord playerId, Show playerId) => Round playerId -> Action playerId -> ActionM playerId (Event playerId) +actionToEvent round action@(viewAction -> (pid, _, play)) = do + (_, sourceHand) <- getActivePlayerHand round pid + case getTarget play of + Nothing -> return $ noTarget action + Just target -> do + (targetPlayer, targetHand) <- getActivePlayerHand round target + if fromJust (isProtected targetPlayer) + then return NoChange + else return $ withTarget sourceHand targetHand action + + where + + noTarget (viewAction -> (_, Priestess, NoEffect)) = Protected pid + noTarget (viewAction -> (_, Minister, NoEffect)) = NoChange + noTarget (viewAction -> (_, Prince, NoEffect)) = Eliminated pid + noTarget _ = terror $ "We thought " ++ show action ++ " had no target." + + withTarget _ targetCard (viewAction -> (_, Soldier, Guess target guess)) + | targetCard == guess = Eliminated target + | otherwise = NoChange + withTarget _ targetCard (viewAction -> (_, Clown, Attack target)) = + ForcedReveal pid target targetCard + withTarget sourceHand targetHand (viewAction -> (_, Knight, Attack target)) = + case compare sourceHand targetHand of + LT -> Eliminated pid + EQ -> NoChange + GT -> Eliminated target + withTarget _ Prince (viewAction -> (_, Wizard, Attack target)) = Eliminated target + withTarget _ _ (viewAction -> (_, Wizard, Attack target)) = ForcedDiscard target + withTarget _ _ (viewAction -> (_, General, Attack target)) = SwappedHands target pid + withTarget _ _ _ = terror $ "Invalid action: " ++ show action + + +-- XXX: Lots of these re-get players from the Round that have already been +-- retrieved by actionToEvent. Perhaps we could include that data in the Event +-- structure so this simply returns a Round. + +-- | Apply a change to the Round. +applyEvent :: Ord playerId => Round playerId -> Event playerId -> ActionM playerId (Round playerId) +applyEvent round NoChange = return round +applyEvent round (Protected pid) = modifyActivePlayer round pid protect +applyEvent round (SwappedHands pid1 pid2) = do + p1 <- getActivePlayer round pid1 + p2 <- getActivePlayer round pid2 + let (p1', p2') = swapHands p1 p2 in + return $ (replace pid2 p2' . replace pid1 p1') round + where replace pid p rnd = setActivePlayer rnd pid p +applyEvent round (Eliminated pid) = modifyActivePlayer round pid eliminate +applyEvent round (ForcedDiscard pid) = + let (card, round') = runState drawCard round in + modifyActivePlayer round' pid (`discardAndDraw` card) +applyEvent round (ForcedReveal {}) = return round + + +-- | Play a turn in a Round. +-- +-- This is the main function in this module. +-- +-- A turn has two steps. First, the player draws a card. If their hand "busts +-- out" (due to holding the Minister and another high card), then they are +-- eliminated and play proceeds to the next player. This is the `Left` return +-- value, which returns the new Round and a Result indicating the player bust +-- out. +-- +-- Second, the player plays one of these two cards. This is the `Right` return +-- value, a function that takes the players chosen card and play, and returns +-- either a BadAction or a new Round together with the Result of the play. +playTurn :: (Ord playerId, Show playerId) + => Round playerId + -> Either (ActionM playerId (Result playerId, Round playerId)) + (Card -> Play playerId -> ActionM playerId (Result playerId, Round playerId)) +playTurn round = do + (playerId, (dealt, hand)) <- note (Left RoundOver) (currentTurn round) + let player = assertRight "Current player is not active: " (getActivePlayer round playerId) + if bustingHand dealt hand + then Left $ return $ bustOut playerId dealt hand + else Right $ handlePlay playerId player dealt hand + + where + handlePlay playerId player dealt hand chosen play = do + player' <- note (WrongCard chosen (dealt, hand)) (playCard player dealt chosen) + let round' = setActivePlayer (set roundState Playing round) playerId player' + action <- fmapL InvalidPlay (playToAction playerId chosen play) + result <- actionToEvent round' action + round'' <- applyEvent round' result + return (Played action result, nextTurn round'') + + bustOut pid dealt hand = + let bustedRound = assertRight "Could not bust out player: " + (modifyActivePlayer round pid (`bust` dealt)) + in (BustedOut pid dealt hand, nextTurn (set roundState Playing bustedRound)) + + +-- | Play a turn in a Round +-- +-- Similar to playTurn, except that instead of splitting the turn into two +-- phases, there is a single, optional play. If the hand is a busting hand, +-- then the play must be Nothing; if not, the play must be specified. +playTurn' :: (Ord playerId, Show playerId) + => Round playerId + -> Maybe (Card, Play playerId) + -> ActionM playerId (Result playerId, Round playerId) +playTurn' round optionalPlay = do + result <- case playTurn round of + Left action -> action + Right handler -> do + (card, play) <- note NoPlaySpecified optionalPlay + handler card play + case (optionalPlay, result) of + (Just _, (BustedOut {}, _)) -> throwError PlayWhenBusted + _ -> return result + + +data Victory playerId + -- | The given player is the only survivor. + = SoleSurvivor playerId Card + -- | These players have the highest card. + | HighestCard Card [playerId] [(playerId, Card)] + deriving (Eq, Show) + + +-- | The currently surviving players in the round, with their cards. +survivors :: Round playerId -> [(playerId, Card)] +survivors = Map.toList . Map.mapMaybe getHand . view players + + +-- | If the Round is Over, return the Victory data. Otherwise, Nothing. +victory :: Round playerId -> Maybe (Victory playerId) +victory (round@Round { _roundState = Over }) = + case survivors round of + [(pid, card)] -> Just $ SoleSurvivor pid card + xs -> let (best:rest) = reverse (groupBy ((==) `on` snd) (sortBy (compare `on` snd) xs)) + in Just $ HighestCard (snd $ head best) (map fst best) (concat rest) +victory _ = Nothing + + +getWinners :: Victory playerId -> [playerId] +getWinners (SoleSurvivor pid _) = [pid] +getWinners (HighestCard _ pids _) = pids + + +-- | Update the given player in Round. If the update function returns Nothing, +-- then that is taken to mean the player was inactive. +modifyActivePlayer :: Ord playerId => Round playerId -> playerId -> (Player -> Player) -> ActionM playerId (Round playerId) +modifyActivePlayer rnd pid f = setActivePlayer rnd pid <$> f <$> getActivePlayer rnd pid + + +-- | Replace the given player in the Round. If the new player is inactive, +-- then the player is dropped from the cycle of play. +setActivePlayer :: Ord playerId => Round playerId -> playerId -> Player -> Round playerId +setActivePlayer round pid newP = + case getHand newP of + Nothing -> dropPlayer pid + Just _ -> round' + where + round' = over players (set (at pid) (Just newP)) round + dropPlayer p = + case dropItem1 (view playOrder round') p of + Left _ -> set roundState Over round' + Right newOrder -> set playOrder newOrder round' + + +-- | Get the given player, asserting they must be active. Will return a Left +-- if no player is found or if the requested player is inactive. +getActivePlayer :: Ord playerId => Round playerId -> playerId -> ActionM playerId Player +getActivePlayer round pid = fst <$> getActivePlayerHand round pid + + +getActivePlayerHand :: Ord playerId => Round playerId -> playerId -> ActionM playerId (Player, Card) +getActivePlayerHand round pid = do + player <- note (NoSuchPlayer pid) (getPlayer round pid) + hand <- note (InactivePlayer pid) (getHand player) + return (player, hand) + + +-- | Are all the cards in the Round? +prop_allCardsPresent :: Round playerId -> Bool +prop_allCardsPresent = + isJust . Deck.makeDeck . allCards + where allCards rnd = + _burn rnd : ( + (Deck.toList . view stack) rnd + ++ (concatMap getDiscards . Map.elems . view players) rnd + ++ (mapMaybe getHand . Map.elems . view players) rnd) + ++ ( + case _roundState rnd of + Turn x -> [x] + _ -> []) + + +prop_burnCardsSame :: [Round playerId] -> Bool +prop_burnCardsSame (x:xs) = all ((== view burn x) . view burn) xs +prop_burnCardsSame [] = True + + +prop_ringIsActivePlayers :: Eq playerId => Round playerId -> Bool +prop_ringIsActivePlayers r = + (Map.keys . Map.mapMaybe getHand . _players) r == + (Ring.toList . view playOrder) r + + +prop_multipleActivePlayers :: Round playerId -> Bool +prop_multipleActivePlayers r = + case view roundState r of + Over -> True + _ -> Ring.ringSize (view playOrder r) > 1 diff --git a/lib/Haverer/Testing.hs b/lib/Haverer/Testing.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/Testing.hs @@ -0,0 +1,163 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Haverer.Testing ( PlayerId + , inRoundEvent + , playTurn' + , randomRound + , randomRounds + , shuffled + ) where + +import BasicPrelude hiding (round) + +import Data.Maybe (fromJust) +import qualified System.Random.Shuffle as Shuffle +import Test.Tasty.QuickCheck + +import Haverer.Action (Play(..)) +import Haverer.Deck (baseCards, Card(..), Complete, Deck, makeDeck) +import Haverer.Player (PlayerSet, toPlayerSet) +import Haverer.Round ( + Round + , Result(..) + , makeRound + , playTurn + ) +import Haverer.ValidMoves (getValidMoves) +import Haverer.Internal.Error (assertRight) + + +type PlayerId = Int + + +instance Arbitrary (Deck Complete) where + -- | An arbitrary complete deck is a shuffled set of cards. + arbitrary = fmap (fromJust . makeDeck) (shuffled baseCards) + + +instance Arbitrary (PlayerSet PlayerId) where + -- | Start the game with a random number of players. + arbitrary = + makePlayerSet <$> elements [2, 3, 4] + where + makePlayerSet n = + assertRight "Couldn't make set: " (toPlayerSet $ take n [1..]) + + +instance Arbitrary (Round PlayerId) where + -- | A fresh, unplayed round with an arbitrary number of players and a + -- shuffled deck. + arbitrary = makeRound <$> arbitrary <*> arbitrary + + +-- | For a Round and a known-good Card and Play, play the cards and return the +-- round and event. If the hand busts out, Card and Play are ignored. +playTurn' :: (Ord a, Show a) => Round a -> Card -> Play a -> (Result a, Round a) +playTurn' round card play = assertRight "Should have generated valid play: " $ + case playTurn round of + Left action -> action + Right handler -> handler card play + + +playRandomTurn :: (Ord a, Show a) => Round a -> Gen (Maybe (Result a, Round a)) +playRandomTurn round = do + move <- randomCardPlay round + case move of + Nothing -> return Nothing + Just (card, play) -> return $ Just $ playTurn' round card play + where + randomCardPlay round' = + case getValidMoves round' of + [] -> return Nothing + xs -> elements (fmap Just xs) + + +-- | Given a Round, generate a Round that's randomly had a move applied, i.e. +-- a possible next Round. If there are no valid moves, then return the same +-- Round. +randomNextMove :: (Ord a, Show a) => Round a -> Gen (Round a) +randomNextMove round = do + result <- playRandomTurn round + case result of + Nothing -> return round + Just (_, round') -> return round' + + +-- | Generate a sequence of N rounds, starting from an initial round. +manyMoves :: Int -> Gen [Round PlayerId] +manyMoves 0 = return [] +manyMoves n = do + initial <- arbitrary + rest <- iterateM' (n - 2) randomNextMove initial + return (initial:rest) + + +-- | Generate a random number of consecutive rounds, starting from an initial round. +randomRounds :: Gen [Round PlayerId] +randomRounds = do + num <- choose (2, 14) + manyMoves num + + +-- | Generate a random round that might come up in the course of play. +randomRound :: Gen (Round PlayerId) +randomRound = last <$> randomRounds + + +-- | Generate a random, non-terminating round and a valid play for that round. +roundAndPlay :: Gen (Round PlayerId, Card, Play PlayerId) +roundAndPlay = do + round <- randomRound `suchThat` (not . null . getValidMoves) + (card, play) <- elements $ getValidMoves round + return (round, card, play) + + +-- | Generate an event that might come up in the course of play. +inRoundEvent :: Gen (Result PlayerId) +inRoundEvent = do + (round, card, play) <- roundAndPlay + return $ fst $ playTurn' round card play + + +-- | Take a list and generate a shuffled version of it. +shuffled ::[a] -> Gen [a] +shuffled xs = do + rs <- randomOrdering (length xs - 1) + return $ Shuffle.shuffle xs rs + where + -- a sequence (r1,...r[n-1]) of numbers such that r[i] is an independent + -- sample from a uniform random distribution [0..n-i] + randomOrdering 0 = return [] + randomOrdering n = + do y <- choose (0, n) + ys <- randomOrdering (n - 1) + return (y:ys) + + +-- | Kind of like iterate, but for a monadic function, such that the result of +-- calling once is used as the argument for calling next. +iterateM' :: (Monad m) => Int -> (a -> m a) -> a -> m [a] +iterateM' n f x + | n == 0 = return [x] + | n > 0 = do y <- f x + ys <- iterateM' (n - 1) f y + return (y:ys) + | otherwise = return [] diff --git a/lib/Haverer/ValidMoves.hs b/lib/Haverer/ValidMoves.hs new file mode 100644 --- /dev/null +++ b/lib/Haverer/ValidMoves.hs @@ -0,0 +1,57 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} + +module Haverer.ValidMoves ( + getValidMoves + , protectedPlayers + , movesThatTargetPlayer + , attacksOnProtectedPlayers + ) where + +import BasicPrelude hiding (round) + +import Haverer.Action (getTarget, getValidPlays, Play) +import Haverer.Deck (Card) +import Haverer.Player (isProtected) +import Haverer.Round ( + Round, + currentTurn, + getActivePlayers, + getPlayer + ) + + +getValidMoves :: Ord playerId => Round playerId -> [(Card, Play playerId)] +getValidMoves round = + case currentTurn round of + Nothing -> [] + Just (pid, (dealt, hand)) -> getValidPlays pid otherPlayers dealt hand + where otherPlayers = delete pid $ getActivePlayers round + + +protectedPlayers :: Ord playerId => Round playerId -> [playerId] +protectedPlayers round = + filter (\p -> Just True == (isProtected =<< getPlayer round p)) $ getActivePlayers round + + +movesThatTargetPlayer :: Ord playerId => Round playerId -> playerId -> [(Card, Play playerId)] +movesThatTargetPlayer round target = + filter ((== Just target) . getTarget . snd) (getValidMoves round) + + +attacksOnProtectedPlayers :: Ord playerId => Round playerId -> [(Card, Play playerId)] +attacksOnProtectedPlayers round = + [(card, play) | p <- protectedPlayers round, (card, play) <- movesThatTargetPlayer round p] diff --git a/src/cli/Main.hs b/src/cli/Main.hs new file mode 100644 --- /dev/null +++ b/src/cli/Main.hs @@ -0,0 +1,93 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import BasicPrelude hiding (round) + +import qualified Haverer.Engine as E +import Haverer ( + toPlayerSet, + finalScores, + scores, + winners, + roundsPlayed + ) + +import Haverer.CLI.CommandLine ( + ConsoleText(..), + formatScores, + pickNumPlayers, + pickCardToPlay, + pickPlay, + ) +import Haverer.CLI.Prompt (underline) + +import Haverer.Internal.Error (assertRight) + + +main :: IO () +main = do + result <- pickNumPlayers + let players = assertRight ("Couldn't make set for "++ show result ++ " players: ") + (makePlayerSet result) + + void $ E.playGame players + where makePlayerSet n = toPlayerSet $ take n $ map PlayerId [1..] + + +newtype PlayerId = PlayerId Int deriving (Show, Eq, Ord) + +instance ConsoleText PlayerId where + toText (PlayerId i) = "Player #" ++ show i + + +instance E.MonadEngine IO PlayerId where + + badPlay e = putStrLn $ "ERROR: " ++ show e + + choosePlay players _ dealt hand = do + card <- pickCardToPlay (dealt, hand) + putStrLn $ "You chose: " ++ show card + play <- pickPlay card players + return (card, play) + + handStarted = putStrLn . toText + + handOver event = putStrLn $ "\n" ++ toText event ++ "\n" + + gameStarted _ = do + putStrLn $ underline '=' "GAME BEGIN" + putStrLn "" + + gameOver outcome = do + putStrLn "GAME OVER" + case winners outcome of + [x] -> putStrLn $ "The winner is: " ++ toText x ++ "!" + xs -> putStrLn $ "The winners are: " ++ intercalate ", " (map toText xs) ++ "!" + putStrLn $ formatScores $ finalScores outcome + + roundStarted game _ = do + putStrLn $ formatScores $ scores game + putStrLn $ underline '=' ("ROUND #" ++ show (roundsPlayed game + 1) ++ " BEGIN") + putStrLn "" + + roundOver v = do + putStrLn "ROUND OVER" + putStrLn $ toText v + putStrLn "" diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,37 @@ +-- Copyright (c) 2014-2015 Jonathan M. Lange +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +import BasicPrelude +import Test.Tasty + +import qualified CLI +import qualified Player +import qualified Ring +import qualified Round + + +suite :: TestTree +suite = + testGroup "Test Suite" [ + CLI.suite + , Player.suite + , Ring.suite + , Round.suite + ] + +main :: IO () +main = defaultMain suite