Bumping to 0.3.0.0 for making the Game type signature parametric in the players' type

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

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

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

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

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 {

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}

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)