Fix number of players for KoiKoi game to 2 on the type level

hanafuda.cabal

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

src/Hanafuda.hs

@@ -5,16 +5,20 @@ module Hanafuda (
     , Pack
     , add
     , cards
+    , cardsOf
     , cardsOfPack
     , contains
+    , difference
     , empty
     , flower
     , intersection
     , match
     , packOfCards
     , remove
+    , sameMonth
     , shuffle
     , size
+    , union
   ) where
 
 import Data.Word (Word64)
@@ -26,6 +30,7 @@ import Data.Bits (
     , testBit
     , xor
     , (.&.)
+    , (.|.)
     , countTrailingZeros
   )
 import System.Random (randomRIO)
@@ -111,8 +116,14 @@ intersection = portBinary (.&.)
 difference :: Pack -> Pack -> Pack
 difference = portBinary (\a b -> a `xor` (a .&. b))
 
-sameMonth :: Card -> Pack
+union :: Pack -> Pack -> Pack
-sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
+union = portBinary (.|.)
+
+cardsOf :: Flower -> Pack
+cardsOf = Pack . shift 0xf . (* 4) . fromEnum
+
+sameMonth :: Card -> Pack -> Pack
+sameMonth card (Pack p) = Pack $ (0xf `shift` (fromEnum card .&. 0xfc)) .&. p
 
 cards :: [Card]
 cards = [Pine0 .. Phoenix]
@@ -130,7 +141,7 @@ shuffle l =
 
 match :: Card -> Pack -> Either String (Pack, [Card])
 match card pack =
-  let sameMonthCards = sameMonth card `intersection` pack in
+  let sameMonthCards = sameMonth card pack in
   case size sameMonthCards of
     0 -> Right (add pack card, [])
     1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)

src/Hanafuda/ID.hs

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

src/Hanafuda/KoiKoi.hs

@@ -3,10 +3,13 @@
 module Hanafuda.KoiKoi (
       Action(..)
     , Card(..)
-    , Game(..)
     , Environment
+    , Game
+    , GameBlueprint(..)
+    , GameID
     , Mode(..)
     , Move(..)
+    , PlayerID
     , Score
     , Source(..)
     , Step(..)
@@ -18,13 +21,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, GameBlueprint(..), GameID, Mode(..), Move(..), PlayerID
+    , 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,8 +49,8 @@ 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 => (PlayerID, PlayerID) -> Mode -> m Game
-new playersList mode = do
+new (playerA, playerB) mode = do
   playing <- Player.random players
   Round.deal $ Game {
         mode
@@ -61,4 +67,4 @@ new playersList mode = do
       , rounds = []
     }
   where
-    players = Player.players playersList
+    players = Player.players [playerA, playerB]

src/Hanafuda/KoiKoi/Game.hs

@@ -3,10 +3,14 @@
 {-# LANGUAGE ConstraintKinds #-}
 module Hanafuda.KoiKoi.Game (
       Action(..)
-    , Game(..)
     , Environment
+    , Game
+    , GameBlueprint(..)
+    , GameID
+    , ID
     , Mode(..)
     , Move(..)
+    , PlayerID
     , Source(..)
     , Step(..)
     , end
@@ -17,8 +21,10 @@ import Control.Monad.Except (MonadError)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Writer (MonadWriter)
 import Hanafuda (Card, Flower, Pack)
+import Hanafuda.ID (ID)
+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 (ID)
 
 data Mode = FirstAt Int | WholeYear deriving (Show)
 data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
@@ -31,24 +37,27 @@ data Action = Action {
   } deriving (Show)
 
 type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
+type PlayerID = Player.ID KoiKoi.Score
+type GameID = ID Game
 
-data Game player = Game {
+data GameBlueprint deckType = Game {
       mode :: Mode
-    , scores :: Scores player
+    , scores :: Scores KoiKoi.Score
     , month :: Flower
-    , players :: Players player Score
+    , players :: Players KoiKoi.Score
-    , playing :: player
+    , playing :: PlayerID
-    , winning :: player
+    , winning :: PlayerID
-    , oyake :: player
+    , oyake :: PlayerID
-    , deck :: [Card]
+    , deck :: deckType
     , river :: Pack
     , step :: Step
     , trick :: [Card]
-    , rounds :: [(player, Score)]
+    , rounds :: [(PlayerID, KoiKoi.Score)]
   } deriving (Show)
+type Game = GameBlueprint [Card]
 
-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

@@ -6,13 +6,13 @@ 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 Hanafuda.KoiKoi.Game (Game, GameBlueprint(..), Mode(..), Step(..), end)
 import qualified Hanafuda.Player as Player (deal, get, next, score, yakus)
 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

@@ -11,7 +11,7 @@ import Hanafuda (Card, Pack, empty, match)
 import Hanafuda.Player (Player(..), plays)
 import qualified Hanafuda.Player as Player (get, next)
 import Hanafuda.KoiKoi.Yaku (meldInto)
-import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Source(..), Step(..), setPlayer)
+import Hanafuda.KoiKoi.Game (Action(..), Environment, Game, GameBlueprint(..), Source(..), Step(..), setPlayer)
 import qualified Hanafuda.KoiKoi.Round as Round (next)
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.IO.Class (MonadIO)
@@ -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/KoiKoi/Yaku.hs

@@ -1,11 +1,20 @@
 {-# LANGUAGE NamedFieldPuns #-}
-module Hanafuda.KoiKoi.Yaku where
+module Hanafuda.KoiKoi.Yaku (
+      Score
+    , Yaku(..)
+    , meldInto
+    , sumYakus
+  ) where
 
-import Hanafuda (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size)
+import Hanafuda (
+      Card(..), Monthly, Pack
+    , add, cardsOf, cardsOfPack, contains, difference, intersection, packOfCards
+    , size
+  )
 import Hanafuda.Player (Points)
 import qualified Data.Map as M (Map, empty, insert, unionWith, (!))
 import qualified Data.Set as S (Set, empty, singleton, union)
-import Control.Monad.Reader (reader)
+import Control.Monad.Reader (asks)
 
 data Yaku =
     Lights
@@ -18,13 +27,15 @@ data Yaku =
   | TsukimiZake
   | HanamiZake
   | TsukiFuda
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Read, Show)
 type YakuRater = Pack -> Maybe Points
+type YakuDistance = Pack -> Int
 type Score = M.Map Yaku Points
 
 data YakuFinder = YakuFinder {
       yaku :: Yaku
     , rater :: YakuRater
+    , distance :: YakuDistance
   }
 
 instance Eq YakuFinder where
@@ -57,12 +68,16 @@ moreThan count _ pack =
 index :: (Yaku, [Card], (Pack -> YakuRater)) -> YakusByCard
 index (yaku, cards, scorer) =
   let pack = packOfCards cards in
-  let yakuFinder = YakuFinder {yaku, rater = scorer pack . intersection pack} in
+  let yakuFinder = YakuFinder {
+      yaku
+    , rater = scorer pack . intersection pack
+    , distance = size . difference pack
+  } in
   foldl (\yakusByCard card -> M.insert card (S.singleton yakuFinder) yakusByCard) M.empty cards
 
 finders :: Monthly YakusByCard
 finders = do
-  monthCardPlus <- reader $ (+) . (4*) . fromEnum
+  monthCards <- cardsOfPack <$> asks cardsOf
   return $ foldl (\yakusByCard -> M.unionWith S.union yakusByCard . index) M.empty [
         (Lights, [Crane, CampCurtain, FullMoon, RainMan, Phoenix], lights)
       , (InoShikaCho, inoshikacho, fixed 5)
@@ -73,7 +88,7 @@ finders = do
       , (Kasu, plains, moreThan 9)
       , (TsukimiZake, [SakeCup, FullMoon], fixed 3)
       , (HanamiZake, [SakeCup, CampCurtain], fixed 3)
-      , (TsukiFuda, map (toEnum . monthCardPlus) [0..3], fixed 5)
+      , (TsukiFuda, monthCards, fixed 5)
     ]
   where
     inoshikacho = [Butterflies, Boar, Deer]

src/Hanafuda/Player.hs

@@ -3,21 +3,23 @@
 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 Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Except (MonadError(..))
 import System.Random (Random(..))
 
-data Player key yakus = Player {
+type ID yakus = Hanafuda.ID (Player yakus)
+data Player yakus = Player {
       hand :: Pack
     , meld :: Pack
-    , nextPlayer :: key
+    , nextPlayer :: ID yakus
     , yakus :: yakus
   } deriving (Show)
-newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show)
+newtype Players yakus = Players (Map (ID yakus) (Player yakus)) deriving (Show)
 
-new :: Monoid yakus => key -> Player key yakus
+new :: Monoid yakus => (ID yakus) -> Player yakus
 new nextPlayer = Player {
       hand = packOfCards []
     , meld = packOfCards []
@@ -25,49 +27,51 @@ new nextPlayer = Player {
     , yakus = mempty
   }
 
-players :: (Ord key, Monoid yakus) => [key] -> Players key yakus
+players :: Monoid yakus => [ID yakus] -> Players yakus
 players [] = Players empty
 players [player] = Players $ singleton player $ new player
 players (alice:others@(bob:_)) =
-  let Players playersByKey = players others in
+  let Players playersByID = players others in
-  let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByKey in
+  let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByID in
-  Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByKey
+  Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByID
   where
     setNextPlayer nextPlayer player = player {nextPlayer}
 
-next :: Ord key => Players key yakus -> key -> key
+next :: Players yakus -> (ID yakus) -> (ID yakus)
-next (Players playersByKey) = nextPlayer . (playersByKey !)
+next (Players playersByID) = nextPlayer . (playersByID !)
 
-random :: MonadIO m => Players key yakus -> m key
+random :: MonadIO m => Players yakus -> m (ID yakus)
-random (Players playersByKey) =
+random (Players playersByID) =
-  fst . ($ playersByKey) . elemAt <$> randomIndex
+  fst . ($ playersByID) . elemAt <$> randomIndex
   where
-    randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
+    randomIndex = liftIO $ randomRIO (0, size playersByID - 1)
 
-get :: Ord key => key -> Players key yakus -> Player key yakus
+get :: (ID yakus) -> Players yakus -> Player yakus
-get key (Players playersByKey) = playersByKey ! key
+get playerID (Players playersByID) = playersByID ! playerID
 
-set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus
+set :: (ID yakus) -> Player yakus -> Players yakus -> Players yakus
-set key player (Players playersByKey) = Players $ insert key player playersByKey
+set playerID player (Players playersByID) = Players $ insert playerID player playersByID
 
-deal :: (Ord key, Monoid yakus) => Players key yakus -> [[Card]] -> Players key yakus
+deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus
-deal (Players playersByKey) hands =
+deal (Players playersByID) hands =
-  Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands
+  Players $ snd $ foldl dealTo (fst $ findMin playersByID, playersByID) hands
   where
-    setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards}
+    setHand cards (Player {nextPlayer}) =
-    dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m)
+      (new nextPlayer) {hand = packOfCards cards}
+    dealTo (playerID, m) hand =
+      (nextPlayer $ m ! playerID, adjust (setHand hand) playerID 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 (ID 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)