Defining a generic Key newtype to provide IDs for Players and Games

hanafuda.cabal

@@ -31,6 +31,7 @@ library
   exposed-modules:     Hanafuda
                      , Hanafuda.KoiKoi
                      , Hanafuda.Player
+                     , Hanafuda.Key
   other-modules:       Hanafuda.KoiKoi.Game
                      , Hanafuda.KoiKoi.Round
                      , Hanafuda.KoiKoi.Turn

src/Hanafuda/Key.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hanafuda.Key (
+      Key(..)
+    , getKey
+  ) where
+
+newtype Key a = Key Int deriving (Eq, Ord, Enum, Read, Show)
+
+getKey :: Key a -> String
+getKey (Key n) = show n

src/Hanafuda/KoiKoi.hs

@@ -5,8 +5,10 @@ module Hanafuda.KoiKoi (
     , Card(..)
     , Game(..)
     , Environment
+    , GameKey
     , Mode(..)
     , Move(..)
+    , PlayerKey
     , Score
     , Source(..)
     , Step(..)
@@ -18,13 +20,16 @@ module Hanafuda.KoiKoi (
 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(..), Mode(..), Move(..), Source(..), Step(..))
+import Hanafuda.KoiKoi.Game (
+      Action(..), Environment, Game(..), GameKey, Mode(..), Move(..), PlayerKey
+    , 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)
 
-play :: (Environment m, Ord player) => Move -> Game player -> m (Game player)
+play :: Environment m => Move -> Game -> m Game
 play move game@(Game {river, step}) =
   case (step, move) of
     (ToPlay, Play card) ->
@@ -43,7 +48,7 @@ play move game@(Game {river, step}) =
   where
     canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
 
-new :: (MonadIO m, Ord player) => [player] -> Mode -> m (Game player)
+new :: MonadIO m => [PlayerKey] -> Mode -> m Game
 new playersList mode = do
   playing <- Player.random players
   Round.deal $ Game {

src/Hanafuda/KoiKoi/Game.hs

@@ -5,8 +5,11 @@ module Hanafuda.KoiKoi.Game (
       Action(..)
     , Game(..)
     , Environment
+    , GameKey
+    , Key
     , Mode(..)
     , Move(..)
+    , PlayerKey
     , Source(..)
     , Step(..)
     , end
@@ -17,8 +20,10 @@ import Control.Monad.Except (MonadError)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Writer (MonadWriter)
 import Hanafuda (Card, Flower, Pack)
+import Hanafuda.Key (Key)
+import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score)
 import Hanafuda.Player (Players, Player, Scores, set)
-import Hanafuda.KoiKoi.Yaku (Score)
+import qualified Hanafuda.Player as Player (Key)
 
 data Mode = FirstAt Int | WholeYear deriving (Show)
 data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
@@ -31,24 +36,26 @@ data Action = Action {
   } deriving (Show)
 
 type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
+type PlayerKey = Player.Key KoiKoi.Score
+type GameKey = Key Game
 
-data Game player = Game {
+data Game = Game {
       mode :: Mode
-    , scores :: Scores player
+    , scores :: Scores KoiKoi.Score
     , month :: Flower
-    , players :: Players player Score
+    , players :: Players KoiKoi.Score
-    , playing :: player
+    , playing :: PlayerKey
-    , winning :: player
+    , winning :: PlayerKey
-    , oyake :: player
+    , oyake :: PlayerKey
     , deck :: [Card]
     , river :: Pack
     , step :: Step
     , trick :: [Card]
-    , rounds :: [(player, Score)]
+    , rounds :: [(PlayerKey, KoiKoi.Score)]
   } deriving (Show)
 
-setPlayer :: Ord player => Game player -> Player player Score -> Game player
+setPlayer :: Game -> Player KoiKoi.Score -> Game
 setPlayer game@(Game {players, playing}) player = game {players = set playing player players}
 
-end :: Monad m => Game player -> m (Game player)
+end :: Monad m => Game -> m Game
 end game = return $ game {step = Over}

src/Hanafuda/KoiKoi/Round.hs

@@ -12,7 +12,7 @@ import Data.Map ((!), insert)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.State (runState, state)
 
-deal :: (MonadIO m, Ord player) => Game player -> m (Game  player)
+deal :: MonadIO m => Game -> m Game
 deal game@(Game {players}) = do
   ((hand1, hand2, river), deck) <- runState getTriple <$> shuffle cards
   return game {
@@ -24,7 +24,7 @@ deal game@(Game {players}) = do
     take8 = state $ splitAt 8
     getTriple = (,,) <$> take8 <*> take8 <*> take8
 
-next :: (MonadIO m, Ord player) => Game player -> m (Game player)
+next :: MonadIO m => Game -> m Game
 next game@(Game {mode, scores, month, players, oyake, winning, rounds}) =
   case mode of
     FirstAt n | n <= newScore -> end scored

src/Hanafuda/KoiKoi/Turn.hs

@@ -27,14 +27,14 @@ log source played cards = tell [
     captures [_, captured] = Just captured
     captures _ = Nothing
 
-catch :: (Environment m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player)
+catch :: Environment m => Game -> Card -> (Pack, [Card]) -> m Game
 catch game@(Game {players, playing}) card (river, trick) = do
   log Hand card trick
   (setPlayer (game {river, trick})) <$> played >>= popNextCard
   where
     played = (Player.get playing players) `plays` card
 
-popNextCard :: (Environment m, Ord player) => Game player -> m (Game player)
+popNextCard :: Environment m => Game -> m Game
 popNextCard (Game {deck = []}) = throwError "No more cards in the stack"
 popNextCard game@(Game {river, deck = turned : others}) =
   let pop = game {deck = others} in
@@ -42,7 +42,7 @@ popNextCard game@(Game {river, deck = turned : others}) =
     Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured)
     Left _ -> return $ pop {step = Turned turned}
 
-end :: (MonadWriter [Action] m, MonadIO m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player)
+end :: (MonadWriter [Action] m, MonadIO m) => Game -> Card -> (Pack, [Card]) -> m Game
 end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
   log Deck card newCaptured
   let updatedGame = setPlayer (game {river, trick = []}) updatedPlayer
@@ -55,7 +55,7 @@ end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
     (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
     updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}
 
-next :: (MonadIO m, Ord player) => Game player -> m (Game player)
+next :: MonadIO m => Game -> m Game
 next game@(Game {players, playing}) =
   let newPlaying = Player.next players playing in
   if hand (Player.get newPlaying players) == empty

src/Hanafuda/Player.hs

@@ -3,21 +3,23 @@
 module Hanafuda.Player where
 
 import Hanafuda (Card, Pack, contains, packOfCards, remove)
+import qualified Hanafuda.Key as Hanafuda (Key)
 import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
 import qualified Data.Map as Map (filter)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Except (MonadError(..))
 import System.Random (Random(..))
 
-data Player key yakus = Player {
+type Key yakus = Hanafuda.Key (Player yakus)
+data Player yakus = Player {
       hand :: Pack
     , meld :: Pack
-    , nextPlayer :: key
+    , nextPlayer :: Key yakus
     , yakus :: yakus
   } deriving (Show)
-newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show)
+newtype Players yakus = Players (Map (Key yakus) (Player yakus)) deriving (Show)
 
-new :: Monoid yakus => key -> Player key yakus
+new :: Monoid yakus => (Key yakus) -> Player yakus
 new nextPlayer = Player {
       hand = packOfCards []
     , meld = packOfCards []
@@ -25,7 +27,7 @@ new nextPlayer = Player {
     , yakus = mempty
   }
 
-players :: (Ord key, Monoid yakus) => [key] -> Players key yakus
+players :: Monoid yakus => [Key yakus] -> Players yakus
 players [] = Players empty
 players [player] = Players $ singleton player $ new player
 players (alice:others@(bob:_)) =
@@ -35,39 +37,39 @@ players (alice:others@(bob:_)) =
   where
     setNextPlayer nextPlayer player = player {nextPlayer}
 
-next :: Ord key => Players key yakus -> key -> key
+next :: Players yakus -> (Key yakus) -> (Key yakus)
 next (Players playersByKey) = nextPlayer . (playersByKey !)
 
-random :: MonadIO m => Players key yakus -> m key
+random :: MonadIO m => Players yakus -> m (Key yakus)
 random (Players playersByKey) =
   fst . ($ playersByKey) . elemAt <$> randomIndex
   where
     randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
 
-get :: Ord key => key -> Players key yakus -> Player key yakus
+get :: (Key yakus) -> Players yakus -> Player yakus
 get key (Players playersByKey) = playersByKey ! key
 
-set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus
+set :: (Key yakus) -> Player yakus -> Players yakus -> Players yakus
 set key player (Players playersByKey) = Players $ insert key player playersByKey
 
-deal :: (Ord key, Monoid yakus) => Players key yakus -> [[Card]] -> Players key yakus
+deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus
 deal (Players playersByKey) hands =
   Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands
   where
     setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards}
     dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m)
 
-plays :: MonadError String m => Player key yakus -> Card -> m (Player key yakus)
+plays :: MonadError String m => Player yakus -> Card -> m (Player yakus)
 plays player@(Player {hand}) card =
   if hand `contains` card
     then return $ player {hand = remove hand card}
     else throwError "You don't have this card"
 
 type Points = Int
-type Scores key = Map key Points
+type Scores yakus = Map (Key yakus) Points
 
-score :: (yakus -> Points) -> Player key yakus -> Points
+score :: (yakus -> Points) -> Player yakus -> Points
 score rater = rater . yakus
 
-scores :: Ord key => Players key yakus -> [Points] -> Scores key
+scores :: Players yakus -> [Points] -> Scores yakus
 scores (Players playersByKey) = fromList . zip (keys playersByKey)