Take player turns out of the Player data structure

src/Hanafuda/KoiKoi.hs

@@ -10,6 +10,7 @@ module Hanafuda.KoiKoi (
     , Move(..)
     , Player
     , PlayerID
+    , PlayerTurn
     , Players
     , Score
     , Scores
@@ -20,12 +21,13 @@ module Hanafuda.KoiKoi (
     , play
   ) where
 
+import qualified Data.Map as Map (fromList)
 import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
 import qualified Hanafuda.Player as Player (players, random, scores)
 import Hanafuda.KoiKoi.Yaku (Yaku(..), Score)
 import Hanafuda.KoiKoi.Game (
       Action(..), Environment, Game(..), GameID, Mode(..), Move(..), Player
-    , PlayerID, Players, Scores, Source(..), Step(..)
+    , PlayerID, PlayerTurn, Players, Scores, Source(..), Step(..)
   )
 import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
 import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
@@ -59,6 +61,7 @@ new (playerA, playerB) mode = do
       , scores = Player.scores players [0, 0]
       , month = Pine
       , players
+      , nextPlayer
       , playing
       , winning = playing
       , oyake = playing
@@ -70,3 +73,4 @@ new (playerA, playerB) mode = do
     }
   where
     players = Player.players [playerA, playerB]
+    nextPlayer = Map.fromList $ [(playerA, playerB), (playerB, playerA)]

src/Hanafuda/KoiKoi/Game.hs

@@ -11,6 +11,7 @@ module Hanafuda.KoiKoi.Game (
     , Move(..)
     , Player
     , PlayerID
+    , PlayerTurn
     , Players
     , Scores
     , Source(..)
@@ -22,6 +23,7 @@ module Hanafuda.KoiKoi.Game (
 import Control.Monad.Except (MonadError)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Writer (MonadWriter)
+import Data.Map (Map)
 import Hanafuda (Card, Flower, Pack)
 import Hanafuda.ID (ID)
 import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score)
@@ -43,11 +45,13 @@ type PlayerID = Player.ID KoiKoi.Score
 type Players = Player.Players KoiKoi.Score
 type Scores = Player.Scores KoiKoi.Score
 type GameID = ID Game
+type PlayerTurn = Map PlayerID PlayerID
 
 data Game = Game {
       mode :: Mode
     , scores :: Scores
     , month :: Flower
+    , nextPlayer :: PlayerTurn
     , players :: Players
     , playing :: PlayerID
     , winning :: PlayerID

src/Hanafuda/KoiKoi/Round.hs

@@ -7,7 +7,7 @@ module Hanafuda.KoiKoi.Round (
 import Hanafuda (Flower(Paulownia), cards, shuffle, packOfCards)
 import Hanafuda.KoiKoi.Yaku (sumYakus)
 import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Step(..), end)
-import qualified Hanafuda.Player as Player (deal, get, next, score, yakus)
+import qualified Hanafuda.Player as Player (deal, get, score, yakus)
 import Data.Map ((!), insert)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.State (runState, state)
@@ -25,14 +25,14 @@ deal game@(Game {players}) = do
     getTriple = (,,) <$> take8 <*> take8 <*> take8
 
 next :: MonadIO m => Game -> m Game
-next game@(Game {mode, scores, month, players, oyake, winning, rounds}) =
+next game@(Game {mode, scores, month, players, nextPlayer, oyake, winning, rounds}) =
   case mode of
     FirstAt n | n <= newScore -> end scored
     FirstAt _ -> continue
     WholeYear | month == Paulownia -> end scored
     WholeYear -> continue
   where
-    playing = Player.next players oyake
+    playing = nextPlayer ! oyake
     winner = Player.get winning players
     newScore = (scores ! winning) + Player.score sumYakus winner
     scored = game {scores = insert winning newScore scores, rounds = (winning, Player.yakus winner): rounds}

src/Hanafuda/KoiKoi/Turn.hs

@@ -7,9 +7,10 @@ module Hanafuda.KoiKoi.Turn (
     , popNextCard
   ) where
 
+import Data.Map ((!))
 import Hanafuda (Card, Pack, empty, match)
 import Hanafuda.Player (Player(..), plays)
-import qualified Hanafuda.Player as Player (get, next)
+import qualified Hanafuda.Player as Player (get)
 import Hanafuda.KoiKoi.Yaku (meldInto)
 import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Source(..), Step(..), setPlayer)
 import qualified Hanafuda.KoiKoi.Round as Round (next)
@@ -56,8 +57,8 @@ end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
     updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}
 
 next :: MonadIO m => Game -> m Game
-next game@(Game {players, playing}) =
-  let newPlaying = Player.next players playing in
+next game@(Game {players, nextPlayer, playing}) =
+  let newPlaying = nextPlayer ! playing in
   if hand (Player.get newPlaying players) == empty
     then Round.next $ game
     else return $ game {playing = newPlaying, step = ToPlay}

src/Hanafuda/Player.hs

@@ -4,8 +4,8 @@ module Hanafuda.Player where
 
 import Hanafuda (Card, Pack, contains, packOfCards, remove)
 import qualified Hanafuda.ID as Hanafuda (ID)
-import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
-import qualified Data.Map as Map (filter)
+import Data.Map ((!), Map, elemAt, insert, keys, size)
+import qualified Data.Map as Map (fromList, toList)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Except (MonadError(..))
 import System.Random (Random(..))
@@ -14,31 +14,19 @@ type ID yakus = Hanafuda.ID (Player yakus)
 data Player yakus = Player {
       hand :: Pack
     , meld :: Pack
-    , nextPlayer :: ID yakus
     , yakus :: yakus
   } deriving (Show)
 newtype Players yakus = Players (Map (ID yakus) (Player yakus)) deriving (Show)
 
-new :: Monoid yakus => (ID yakus) -> Player yakus
-new nextPlayer = Player {
+new :: Monoid yakus => Player yakus
+new = Player {
       hand = packOfCards []
     , meld = packOfCards []
-    , nextPlayer
     , yakus = mempty
   }
 
 players :: Monoid yakus => [ID yakus] -> Players yakus
-players [] = Players empty
-players [player] = Players $ singleton player $ new player
-players (alice:others@(bob:_)) =
-  let Players playersByID = players others in
-  let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByID in
-  Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByID
-  where
-    setNextPlayer nextPlayer player = player {nextPlayer}
-
-next :: Players yakus -> (ID yakus) -> (ID yakus)
-next (Players playersByID) = nextPlayer . (playersByID !)
+players = Players . Map.fromList . fmap (\playerID -> (playerID, new))
 
 random :: MonadIO m => Players yakus -> m (ID yakus)
 random (Players playersByID) =
@@ -54,12 +42,10 @@ set playerID player (Players playersByID) = Players $ insert playerID player pla
 
 deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus
 deal (Players playersByID) hands =
-  Players $ snd $ foldl dealTo (fst $ findMin playersByID, playersByID) hands
+  Players . Map.fromList . zipWith setHand hands $ Map.toList playersByID
   where
-    setHand cards (Player {nextPlayer}) =
-      (new nextPlayer) {hand = packOfCards cards}
-    dealTo (playerID, m) hand =
-      (nextPlayer $ m ! playerID, adjust (setHand hand) playerID m)
+    setHand cards (playerID, player) =
+      (playerID, player {hand = packOfCards cards})
 
 plays :: MonadError String m => Player yakus -> Card -> m (Player yakus)
 plays player@(Player {hand}) card =
@@ -74,4 +60,4 @@ score :: (yakus -> Points) -> Player yakus -> Points
 score rater = rater . yakus
 
 scores :: Players yakus -> [Points] -> Scores yakus
-scores (Players playersByKey) = fromList . zip (keys playersByKey)
+scores (Players playersByKey) = Map.fromList . zip (keys playersByKey)