haverer (empty) → 0.1.0.0
raw patch · 19 files changed
+2259/−0 lines, 19 filesdep +MonadRandomdep +basedep +basic-preludesetup-changed
Dependencies added: MonadRandom, base, basic-prelude, containers, errors, haverer, lens, mtl, random-shuffle, tasty, tasty-hunit, tasty-quickcheck, text
Files
- LICENSE +202/−0
- Setup.hs +2/−0
- haverer.cabal +92/−0
- lib/Haverer.hs +83/−0
- lib/Haverer/Action.hs +125/−0
- lib/Haverer/CLI/CommandLine.hs +204/−0
- lib/Haverer/CLI/Prompt.hs +76/−0
- lib/Haverer/Deck.hs +97/−0
- lib/Haverer/Engine.hs +115/−0
- lib/Haverer/Game.hs +112/−0
- lib/Haverer/Internal/Counter.hs +56/−0
- lib/Haverer/Internal/Error.hs +36/−0
- lib/Haverer/Internal/Ring.hs +100/−0
- lib/Haverer/Player.hs +123/−0
- lib/Haverer/Round.hs +486/−0
- lib/Haverer/Testing.hs +163/−0
- lib/Haverer/ValidMoves.hs +57/−0
- src/cli/Main.hs +93/−0
- tests/test.hs +37/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haverer.cabal view
@@ -0,0 +1,92 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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 <jml@mumak.net>+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
+ lib/Haverer.hs view
@@ -0,0 +1,83 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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')
+ lib/Haverer/Action.hs view
@@ -0,0 +1,125 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/CLI/CommandLine.hs view
@@ -0,0 +1,204 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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 ..]
+ lib/Haverer/CLI/Prompt.hs view
@@ -0,0 +1,76 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Deck.hs view
@@ -0,0 +1,97 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Engine.hs view
@@ -0,0 +1,115 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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')
+ lib/Haverer/Game.hs view
@@ -0,0 +1,112 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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' }
+ lib/Haverer/Internal/Counter.hs view
@@ -0,0 +1,56 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Internal/Error.hs view
@@ -0,0 +1,36 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Internal/Ring.hs view
@@ -0,0 +1,100 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Player.hs view
@@ -0,0 +1,123 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Round.hs view
@@ -0,0 +1,486 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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
+ lib/Haverer/Testing.hs view
@@ -0,0 +1,163 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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 []
+ lib/Haverer/ValidMoves.hs view
@@ -0,0 +1,57 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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]
+ src/cli/Main.hs view
@@ -0,0 +1,93 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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 ""
+ tests/test.hs view
@@ -0,0 +1,37 @@+-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>+--+-- 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