Add gameID directly into Game data structure

src/Hanafuda/ID.hs

@@ -1,10 +1,38 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Hanafuda.ID (
       ID(..)
-    , getID
+    , IDType(..)
+    , Prefix(..)
   ) where
 
-newtype ID a = ID Int deriving (Eq, Ord, Enum, Read, Show)
+import Data.Char (isDigit)
+import System.Random (Random(..))
+import Text.ParserCombinators.ReadP (char, munch, string)
+import Text.ParserCombinators.ReadPrec (lift)
+import Text.Read (readPrec)
 
-getID :: ID a -> String
+newtype ID a = ID {
-getID (ID n) = show n
+    getID :: Int
+  } deriving (Eq, Ord)
+
+newtype Prefix a = Prefix String
+
+class IDType a where
+  prefix :: Prefix a
+
+instance IDType a => Show (ID a) where
+  show (ID someID) = p ++ ('#' : show someID)
+    where Prefix p = (prefix :: Prefix a)
+
+instance IDType a => Read (ID a) where
+  readPrec = fmap (ID . read) . lift $
+    string p >> char '#' >> munch (isDigit)
+    where Prefix p = (prefix :: Prefix a)
+
+rIntToRID :: (Int, g) -> (ID a, g)
+rIntToRID (someID, g) = (ID someID, g)
+
+instance Random (ID a) where
+  random = rIntToRID . randomR (0, maxBound)
+  randomR (ID idA, ID idB) = rIntToRID . randomR (idA, idB)

src/Hanafuda/KoiKoi.hs

@@ -4,13 +4,16 @@ module Hanafuda.KoiKoi (
       Action(..)
     , Card(..)
     , Environment
-    , Game
+    , Game(..)
-    , GameBlueprint(..)
     , GameID
     , Mode(..)
     , Move(..)
+    , Player
     , PlayerID
+    , PlayerTurn
+    , Players
     , Score
+    , Scores
     , Source(..)
     , Step(..)
     , Yaku(..)
@@ -18,17 +21,19 @@ 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, GameBlueprint(..), GameID, Mode(..), Move(..), PlayerID
+      Action(..), Environment, Game(..), GameID, Mode(..), Move(..), Player
-    , 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)
 import Control.Monad.Except (MonadError(..))
-import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.IO.Class (MonadIO(..))
+import System.Random (randomIO)
 
 play :: Environment m => Move -> Game -> m Game
 play move game@(Game {river, step}) =
@@ -52,11 +57,14 @@ play move game@(Game {river, step}) =
 new :: MonadIO m => (PlayerID, PlayerID) -> Mode -> m Game
 new (playerA, playerB) mode = do
   playing <- Player.random players
+  gameID <- liftIO $ randomIO
   Round.deal $ Game {
-        mode
+        gameID
+      , mode
       , scores = Player.scores players [0, 0]
       , month = Pine
       , players
+      , nextPlayer
       , playing
       , winning = playing
       , oyake = playing
@@ -68,3 +76,4 @@ new (playerA, playerB) mode = do
     }
   where
     players = Player.players [playerA, playerB]
+    nextPlayer = Map.fromList $ [(playerA, playerB), (playerB, playerA)]

src/Hanafuda/KoiKoi/Game.hs

@@ -4,13 +4,16 @@
 module Hanafuda.KoiKoi.Game (
       Action(..)
     , Environment
-    , Game
+    , Game(..)
-    , GameBlueprint(..)
     , GameID
     , ID
     , Mode(..)
     , Move(..)
+    , Player
     , PlayerID
+    , PlayerTurn
+    , Players
+    , Scores
     , Source(..)
     , Step(..)
     , end
@@ -20,14 +23,14 @@ 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 Hanafuda.ID (ID, IDType(..), Prefix(..))
 import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score)
-import Hanafuda.Player (Players, Player, Scores, set)
+import qualified Hanafuda.Player as Player (ID, Players, Player, Scores, set)
-import qualified Hanafuda.Player as Player (ID)
 
 data Mode = FirstAt Int | WholeYear deriving (Show)
-data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
+data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool deriving (Show)
 data Step = ToPlay | Turned Card | Scored | Over deriving (Show)
 data Source = Hand | Deck deriving (Show)
 data Action = Action {
@@ -37,27 +40,36 @@ data Action = Action {
   } deriving (Show)
 
 type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
+type Player = Player.Player KoiKoi.Score
 type PlayerID = Player.ID KoiKoi.Score
+type Players = Player.Players KoiKoi.Score
+type Scores = Player.Scores KoiKoi.Score
 type GameID = ID Game
+instance IDType Game where
+  prefix = Prefix "Game"
+type PlayerTurn = Map PlayerID PlayerID
 
-data GameBlueprint deckType = Game {
+data Game = Game {
-      mode :: Mode
+      gameID :: GameID
-    , scores :: Scores KoiKoi.Score
+    , mode :: Mode
+    , scores :: Scores
     , month :: Flower
-    , players :: Players KoiKoi.Score
+    , nextPlayer :: PlayerTurn
+    , players :: Players
     , playing :: PlayerID
     , winning :: PlayerID
     , oyake :: PlayerID
-    , deck :: deckType
+    , deck :: [Card]
     , river :: Pack
     , step :: Step
     , trick :: [Card]
     , rounds :: [(PlayerID, KoiKoi.Score)]
   } deriving (Show)
-type Game = GameBlueprint [Card]
 
-setPlayer :: Game -> Player KoiKoi.Score -> Game
+setPlayer :: Game -> Player -> Game
-setPlayer game@(Game {players, playing}) player = game {players = set playing player players}
+setPlayer game@(Game {players, playing}) player = game {
+    players = Player.set playing player players
+  }
 
 end :: Monad m => Game -> m Game
 end game = return $ game {step = Over}

src/Hanafuda/KoiKoi/Round.hs

@@ -6,8 +6,8 @@ module Hanafuda.KoiKoi.Round (
 
 import Hanafuda (Flower(Paulownia), cards, shuffle, packOfCards)
 import Hanafuda.KoiKoi.Yaku (sumYakus)
-import Hanafuda.KoiKoi.Game (Game, GameBlueprint(..), Mode(..), Step(..), end)
+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,11 +7,12 @@ 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, GameBlueprint(..), Source(..), Step(..), setPlayer)
+import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Source(..), Step(..), setPlayer)
 import qualified Hanafuda.KoiKoi.Round as Round (next)
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.IO.Class (MonadIO)
@@ -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}) =
+next game@(Game {players, nextPlayer, playing}) =
-  let newPlaying = Player.next players playing in
+  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

@@ -3,42 +3,33 @@
 module Hanafuda.Player where
 
 import Hanafuda (Card, Pack, contains, packOfCards, remove)
-import qualified Hanafuda.ID as Hanafuda (ID)
+import qualified Hanafuda.ID as Hanafuda (ID, IDType(..), Prefix(..))
-import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
+import Data.Map ((!), Map, elemAt, insert, keys, size)
-import qualified Data.Map as Map (filter)
+import qualified Data.Map as Map (fromList, keys)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Except (MonadError(..))
 import System.Random (Random(..))
 
 type ID yakus = Hanafuda.ID (Player yakus)
+instance Hanafuda.IDType (Player yakus) where
+  prefix = Hanafuda.Prefix "Player"
+
 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 :: Monoid yakus => [Card] -> Player yakus
-new nextPlayer = Player {
+new cards = Player {
-      hand = packOfCards []
+      hand = packOfCards cards
     , meld = packOfCards []
-    , nextPlayer
     , yakus = mempty
   }
 
 players :: Monoid yakus => [ID yakus] -> Players yakus
-players [] = Players empty
+players = Players . Map.fromList . fmap (\playerID -> (playerID, new []))
-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 !)
 
 random :: MonadIO m => Players yakus -> m (ID yakus)
 random (Players playersByID) =
@@ -54,12 +45,9 @@ 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.keys playersByID
   where
-    setHand cards (Player {nextPlayer}) =
+    setHand cards playerID = (playerID, new cards)
-      (new nextPlayer) {hand = packOfCards cards}
-    dealTo (playerID, m) hand =
-      (nextPlayer $ m ! playerID, adjust (setHand hand) playerID m)
 
 plays :: MonadError String m => Player yakus -> Card -> m (Player yakus)
 plays player@(Player {hand}) card =
@@ -74,4 +62,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)