diff --git a/ChangeLog.md b/ChangeLog.md index 7d319df..ea861a4 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for hanafuda +## 0.3.0.0 -- 2018-05-28 + +* Make Game type parametric in the type to represent players + ## 0.2.1.0 -- 2018-03-16 * Export some more types needed to export the game's state diff --git a/hanafuda.cabal b/hanafuda.cabal index 2e5b7cc..6340e22 100644 --- a/hanafuda.cabal +++ b/hanafuda.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hanafuda -version: 0.2.1.0 +version: 0.3.0.0 synopsis: A game of Hanafuda (a family of japanese card games) description: This is a library to represent the cards and the players of games in this family. It also implements one such game @@ -37,7 +37,7 @@ library , Hanafuda.KoiKoi.Yaku -- other-modules: -- other-extensions: - build-depends: base >=4.10 && <4.11 + build-depends: base , containers , mtl , random diff --git a/src/Hanafuda/KoiKoi.hs b/src/Hanafuda/KoiKoi.hs index 358e22b..f281e8a 100644 --- a/src/Hanafuda/KoiKoi.hs +++ b/src/Hanafuda/KoiKoi.hs @@ -14,14 +14,13 @@ module Hanafuda.KoiKoi ( ) where import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove) -import qualified Hanafuda.Player as Player (deal) +import qualified Hanafuda.Player as Player (players, random, scores) import Hanafuda.KoiKoi.Yaku (Yaku(..), Score) import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Move(..), On(..), Over(..), Step(..), raise) import qualified Hanafuda.KoiKoi.Round as Round (deal, next) import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next) -import System.Random (randomIO) -play :: Move -> On -> IO Game +play :: Ord player => Move -> On player -> IO (Game player) play move on@(On_ {river, step}) = case (step, move) of (ToPlay, Play card) -> @@ -39,19 +38,21 @@ play move on@(On_ {river, step}) = where canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 -new :: Mode -> IO On -new mode = do - playing <- randomIO +new :: Ord player => [player] -> Mode -> IO (On player) +new playersList mode = do + playing <- Player.random players Round.deal $ On_ { mode - , scores = Player.deal [0, 0] + , scores = Player.scores players [0, 0] , month = Pine - , players = undefined + , players , playing , winning = playing , oyake = playing - , stock = undefined + , deck = undefined , river = undefined , step = ToPlay , trick = [] } + where + players = Player.players playersList diff --git a/src/Hanafuda/KoiKoi/Game.hs b/src/Hanafuda/KoiKoi/Game.hs index 46b1b6b..3f79ed2 100644 --- a/src/Hanafuda/KoiKoi/Game.hs +++ b/src/Hanafuda/KoiKoi/Game.hs @@ -13,41 +13,40 @@ module Hanafuda.KoiKoi.Game ( ) where import Hanafuda (Card, Flower, Pack) -import Hanafuda.Player (Players, Player, Scores, Seat) +import Hanafuda.Player (Players, Player, Scores, set) import Hanafuda.KoiKoi.Yaku (Score) -import Data.Map (insert) data Mode = FirstAt Int | WholeYear deriving (Show) data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool data Step = ToPlay | Turned Card | Scored deriving (Show) -data On = On_ { +data On player = On_ { mode :: Mode - , scores :: Scores + , scores :: Scores player , month :: Flower - , players :: Players Score - , playing :: Seat - , winning :: Seat - , oyake :: Seat - , stock :: [Card] + , players :: Players player Score + , playing :: player + , winning :: player + , oyake :: player + , deck :: [Card] , river :: Pack , step :: Step , trick :: [Card] } deriving (Show) -data Over = Over_ { - finalScores :: Scores +data Over player = Over_ { + finalScores :: Scores player } deriving (Show) -data Game = Error String | Over Over | On On deriving (Show) +data Game player = Error String | Over (Over player) | On (On player) deriving (Show) -setPlayer :: On -> Player Score -> On -setPlayer on@(On_ {players, playing}) player = on {players = insert playing player players} +setPlayer :: Ord player => On player -> Player player Score -> On player +setPlayer on@(On_ {players, playing}) player = on {players = set playing player players} -end :: On -> IO Game +end :: Ord player => On player -> IO (Game player) end (On_ {scores}) = return . Over $ Over_ {finalScores = scores} -stop :: On -> IO Game +stop :: Ord player => On player -> IO (Game player) stop = return . On -raise :: String -> IO Game +raise :: String -> IO (Game player) raise = return . Error diff --git a/src/Hanafuda/KoiKoi/Round.hs b/src/Hanafuda/KoiKoi/Round.hs index 54e7ad6..9f1c422 100644 --- a/src/Hanafuda/KoiKoi/Round.hs +++ b/src/Hanafuda/KoiKoi/Round.hs @@ -7,22 +7,22 @@ module Hanafuda.KoiKoi.Round ( import Hanafuda (Flower(Paulownia), cards, shuffle, packOfCards) import Hanafuda.KoiKoi.Yaku (sumYakus) import Hanafuda.KoiKoi.Game (Game, Mode(..), On(..), Step(..), end, stop) -import qualified Hanafuda.Player as Player (deal, next, new, score) +import qualified Hanafuda.Player as Player (deal, get, next, score) import Data.Map ((!), insert) import Control.Monad.State (replicateM, runState, state) -deal :: On -> IO On -deal on = do - ([hand1, hand2, river], stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards +deal :: Ord player => On player -> IO (On player) +deal on@(On_ {players}) = do + ([hand1, hand2, river], deck) <- fmap (runState (replicateM 3 take8)) $ shuffle cards return on { - players = fmap Player.new $ Player.deal [hand1, hand2] - , stock + players = Player.deal players [hand1, hand2] + , deck , river = packOfCards river } where take8 = state $ splitAt 8 -next :: On -> IO Game +next :: Ord player => On player -> IO (Game player) next on@(On_ {mode, scores, month, players, oyake, winning}) = case mode of FirstAt n | n <= newScore -> end scored @@ -30,8 +30,8 @@ next on@(On_ {mode, scores, month, players, oyake, winning}) = WholeYear | month == Paulownia -> end scored WholeYear -> continue where - playing = Player.next oyake - newScore = (scores ! winning) + Player.score sumYakus (players ! winning) + playing = Player.next players oyake + newScore = (scores ! winning) + Player.score sumYakus (Player.get winning players) scored = on {scores = insert winning newScore scores} continue = deal (scored { diff --git a/src/Hanafuda/KoiKoi/Turn.hs b/src/Hanafuda/KoiKoi/Turn.hs index 8872819..6e32eef 100644 --- a/src/Hanafuda/KoiKoi/Turn.hs +++ b/src/Hanafuda/KoiKoi/Turn.hs @@ -8,28 +8,27 @@ module Hanafuda.KoiKoi.Turn ( import Hanafuda (Card, Pack, empty, match) import Hanafuda.Player (Player(..), plays) -import qualified Hanafuda.Player as Player (next) +import qualified Hanafuda.Player as Player (get, next) import Hanafuda.KoiKoi.Yaku (meldInto) import Hanafuda.KoiKoi.Game (Game, On(..), Step(..), raise, setPlayer, stop) import qualified Hanafuda.KoiKoi.Round as Round (next) -import Data.Map ((!)) import Control.Monad.Reader (runReader) -catch :: On -> Card -> (Pack, [Card]) -> IO Game +catch :: Ord player => On player -> Card -> (Pack, [Card]) -> IO (Game player) catch on@(On_ {players, playing}) card (river, trick) = either raise (popNextCard . setPlayer (on {river, trick})) played where - played = (players ! playing) `plays` card + played = (Player.get playing players) `plays` card -popNextCard :: On -> IO Game -popNextCard (On_ {stock = []}) = raise "No more cards in the stack" -popNextCard on@(On_ {river, stock = turned : others}) = - let pop = on {stock = others} in +popNextCard :: Ord player => On player -> IO (Game player) +popNextCard (On_ {deck = []}) = raise "No more cards in the stack" +popNextCard on@(On_ {river, deck = turned : others}) = + let pop = on {deck = others} in case match turned river of Right (newRiver, newCaptured) -> end pop (newRiver, newCaptured) Left _ -> stop $ pop {step = Turned turned} -end :: On -> (Pack, [Card]) -> IO Game +end :: Ord player => On player -> (Pack, [Card]) -> IO (Game player) end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do let updatedGame = setPlayer (on {river, trick = []}) updatedPlayer if null scored @@ -37,13 +36,13 @@ end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do else stop $ updatedGame {step = Scored, winning = playing} where newTrick = newCaptured ++ trick - player = players ! playing + player = Player.get playing players (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)} -next :: On -> IO Game +next :: Ord player => On player -> IO (Game player) next on@(On_ {players, playing}) = - let newPlaying = Player.next playing in - if hand (players ! newPlaying) == empty + let newPlaying = Player.next players playing in + if hand (Player.get newPlaying players) == empty then Round.next $ on else stop $ on {playing = newPlaying, step = ToPlay} diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs index 01b42fe..728ea60 100644 --- a/src/Hanafuda/Player.hs +++ b/src/Hanafuda/Player.hs @@ -2,51 +2,67 @@ module Hanafuda.Player where import Hanafuda (Card, Pack, contains, packOfCards, remove) -import Data.Map (Map, fromList) +import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size) +import qualified Data.Map as Map (filter) import System.Random (Random(..)) -data Seat = - Player1 - | Player2 - deriving (Eq, Ord, Show, Enum) - -instance Random Seat where - randomR (lo, hi) g = - let (n, g') = randomR (fromEnum lo, fromEnum hi) g in - (toEnum n, g') - - random = randomR (Player1, Player2) - -next :: Seat -> Seat -next Player1 = Player2 -next _ = Player1 - -data Player a = Player { +data Player key yakus = Player { hand :: Pack , meld :: Pack - , yakus :: a + , nextPlayer :: key + , yakus :: yakus } deriving (Show) -type Players a = Map Seat (Player a) +newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show) -deal :: [a] -> Map Seat a -deal = fromList . zip [Player1, Player2] - -new :: Monoid a => [Card] -> Player a -new cards = Player { - hand = packOfCards cards +new :: Monoid yakus => key -> Player key yakus +new nextPlayer = Player { + hand = packOfCards [] , meld = packOfCards [] + , nextPlayer , yakus = mempty } -plays :: Player a -> Card -> Either String (Player a) +players :: (Ord key, Monoid yakus) => [key] -> Players key yakus +players [] = Players empty +players [player] = Players $ singleton player $ new player +players (alice:others@(bob:_)) = + let Players playersByKey = players others in + let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByKey in + Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByKey + where + setNextPlayer nextPlayer player = player {nextPlayer} + +next :: Ord key => Players key yakus -> key -> key +next (Players playersByKey) = nextPlayer . (playersByKey !) + +random :: Players key yakus -> IO key +random (Players playersByKey) = + fst . ($ playersByKey) . elemAt <$> randomRIO (0, size playersByKey - 1) + +get :: Ord key => key -> Players key yakus -> Player key yakus +get key (Players playersByKey) = playersByKey ! key + +set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus +set key player (Players playersByKey) = Players $ insert key player playersByKey + +deal :: Ord key => Players key yakus -> [[Card]] -> Players key yakus +deal (Players playersByKey) hands = + Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands + where + setHand cards player = player {hand = packOfCards cards} + dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m) + +plays :: Player key yakus -> Card -> Either String (Player key yakus) plays player@(Player {hand}) card = if hand `contains` card then Right $ player {hand = remove hand card} else Left "You don't have this card" type Points = Int +type Scores key = Map key Points -score :: (a -> Points) -> Player a -> Int +score :: (yakus -> Points) -> Player key yakus -> Points score rater = rater . yakus -type Scores = Map Seat Points +scores :: Ord key => Players key yakus -> [Points] -> Scores key +scores (Players playersByKey) = fromList . zip (keys playersByKey)