Refactor to put all KoiKoi specifics into a separate submodule

hanafuda.cabal

@@ -17,12 +17,12 @@ extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     Hanafuda.Year
+  exposed-modules:     Hanafuda
-                     , Hanafuda.Month
+                     , Hanafuda.KoiKoi
-                     , Hanafuda.Day
+                     , Hanafuda.Player
-                     , Hanafuda.Game
+  other-modules:       Hanafuda.KoiKoi.Round
-                     , Hanafuda.Yaku
+                     , Hanafuda.KoiKoi.Turn
-                     , Hanafuda.Card
+                     , Hanafuda.KoiKoi.Yaku
   -- other-modules:
   -- other-extensions:    
   build-depends:       base >=4.10 && <4.11

src/Hanafuda.hs

@@ -1,4 +1,19 @@
-module Hanafuda.Card where
+module Hanafuda (
+      Card(..)
+    , Flower(..)
+    , Monthly
+    , Pack
+    , add
+    , cards
+    , contains
+    , flower
+    , intersection
+    , match
+    , packOfCards
+    , remove
+    , shuffle
+    , size
+  ) where
 
 import Data.Word (Word64)
 import Data.Bits (
@@ -67,6 +82,9 @@ cardsOfPack p =
   let c = smallest p in
   c : cardsOfPack (remove p c)
 
+instance Show Pack where
+  show = ("packOfCards " ++) . show . cardsOfPack
+
 portEnum :: Enum e => (Word64 -> Int -> b) -> Pack -> e -> b
 portEnum f (Pack p) = f p . fromEnum
 
@@ -111,10 +129,10 @@ shuffle l =
       let (top, bottom) = splitAt cut shuffled
       return $ top ++ h : bottom
 
-pair :: Card -> Pack -> Either String (Pack, [Card])
+match :: Card -> Pack -> Either String (Pack, [Card])
-pair card pack =
+match card pack =
   let sameMonthCards = sameMonth card `intersection` pack in
   case size sameMonthCards of
     0 -> Right (add pack card, [])
     1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
-    _ -> Left "This card can pair with several others"
+    _ -> Left "This card can match several others"

src/Hanafuda/Day.hs

@@ -1,64 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hanafuda.Day where
-
-import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, pair, remove)
-import Hanafuda.Yaku (rate)
-import Hanafuda.Game (Game(..), Move(..), PlayerState(..), plays)
-import Data.Map (union)
-import Control.Monad.Reader (runReader)
-
-data Step = ToPlay | Turned Card | Scored | Over Bool
-
-data Day = Day {
-      river :: Pack
-    , month :: Flower
-    , player :: PlayerState
-    , next :: Card
-    , step :: Step
-    , trick :: [Card]
-  }
-
-new :: Pack -> PlayerState -> Card -> Day
-new river player next = Day {
-      river
-    , month = Pine
-    , player
-    , next
-    , step = ToPlay
-    , trick = []
-  }
-
-instance Game Day Day where
-  play day@(Day {river, step, next, trick, player}) move =
-    case (step, move) of
-      (ToPlay, Play card) -> pair card river >>= play card
-      (ToPlay, Capture (card, caught)) ->
-        if card `canCatch` caught
-          then play card (remove river caught, [card, caught])
-          else Left "You can't choose that card"
-      (Turned card, Choose caught) ->
-        if card `canCatch` caught
-          then end $ day {river = remove river caught, trick = [card, caught] ++ trick}
-          else Left "You can't choose that card"
-      (Scored, KoiKoi win) -> Right $ day {step = Over win}
-      (_, _) -> Left "You can't play this move in that state"
-    where
-      canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
-      play card (river, trick) = do
-        played <- player `plays` card
-        turnOver $ day {river, trick, player = played}
-
-turnOver :: Day -> Either String Day
-turnOver day@(Day {river, next, trick}) =
-  case pair next river of
-    Right (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
-    Left _ -> Right $ day {step = Turned next}
-
-end :: Day -> Either String Day
-end day@(Day {month, trick, player}) =
-  let (scored, newMeld) = runReader (rate (meld player) trick) month in
-  let updatedPlayer = day {player = player {meld = newMeld, yakus = scored `union` (yakus player)}} in
-  Right $ if null scored
-    then updatedPlayer {step = Over False}
-    else updatedPlayer {step = Scored}

src/Hanafuda/Game.hs

@@ -1,52 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hanafuda.Game where
-
-import Data.Map (Map, empty, fromList)
-import Hanafuda.Card (Card, Pack, contains, packOfCards, remove)
-import Hanafuda.Yaku (Score, Points)
-
-data Player =
-    Player1
-  | Player2
-  deriving (Eq, Ord)
-
-next :: Player -> Player
-next Player1 = Player2
-next _ = Player1
-
-data PlayerState = PlayerState {
-      hand :: Pack
-    , meld :: Pack
-    , yakus :: Score
-  }
-type Players = Map Player PlayerState
-
-players :: [Player]
-players = [Player1, Player2]
-
-deal :: [a] -> Map Player a
-deal = fromList . zip players
-
-initPlayers :: [[Card]] -> Players
-initPlayers =
-  deal . map player
-  where
-    player cards = PlayerState {
-        hand = packOfCards cards
-      , meld = packOfCards []
-      , yakus = empty
-    }
-
-plays :: PlayerState -> Card -> Either String PlayerState
-plays player@(PlayerState {hand}) card =
-  if hand `contains` card
-    then Right $ player {hand = remove hand card}
-    else Left "You don't have this card"
-
-data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
-
-type Scores = Map Player Points
-
-class Game a b where
-  play :: a -> Move -> Either String b

src/Hanafuda/KoiKoi.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Hanafuda.KoiKoi (
+      new
+    , play
+    , Card(..)
+    , Mode(..)
+    , Move(..)
+    , On
+    , Over(..)
+  ) where
+
+import Prelude hiding (round)
+import Hanafuda (Flower(Paulownia), Card(..))
+import Hanafuda.KoiKoi.Round (Round(..), flower, next, score, winner)
+import qualified Hanafuda.KoiKoi.Round as Round (On(..), Over(..), new, play)
+import Hanafuda.Player (Move(..), Player(Player1), Scores, deal)
+import Data.Map (insert, (!))
+import System.Random (StdGen)
+
+data Mode = FirstAt Int | WholeYear deriving (Show)
+
+data On = On {
+      mode :: Mode
+    , round :: Round.On
+    , scores :: Scores
+  } deriving (Show)
+data Over = Over {
+    finalScores :: Scores
+  } deriving (Show)
+
+newtype Game = Game (Either Over On) deriving (Show)
+
+go :: On -> IO Game
+go = return . Game . Right
+
+new :: Mode -> IO On
+new mode = do
+  round <- Round.new Player1
+  return $ On {mode , round , scores = deal [0, 0]}
+
+consolidate :: On -> Player -> Int -> IO Game
+consolidate on@(On {mode, round, scores}) winner score =
+  case mode of
+    FirstAt n | n <= newScore -> stop
+    FirstAt n -> continue
+    WholeYear | flower round == Paulownia -> stop
+    WholeYear -> continue
+  where
+    newScore = scores ! winner + score
+    newScores = insert winner newScore scores
+    stop = return . Game . Left $ Over {finalScores = newScores}
+    continue = do
+      nextMonth <- next round
+      go $ on {scores = newScores, round = nextMonth}
+
+play :: On -> Move -> IO (Either String Game)
+play on@(On {mode, round}) move =
+  either (return . Left) (fmap Right) . fmap after $ Round.play round move
+  where
+    after (Round (Left (Round.Over {winner, score}))) = consolidate on winner score
+    after (Round (Right newMonth)) = go $ on {round = newMonth}

src/Hanafuda/KoiKoi/Round.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hanafuda.KoiKoi.Round where
+
+import Hanafuda (Card, Flower(Pine), cards, shuffle, packOfCards)
+import Hanafuda.KoiKoi.Yaku (Score, sumYakus)
+import Hanafuda.KoiKoi.Turn (Turn(..))
+import qualified Hanafuda.KoiKoi.Turn as Turn (Step(Over), new, play)
+import Hanafuda.Player (Move, Player, Players, deal)
+import qualified Hanafuda.Player as Player (next, new, score)
+import Data.Map ((!), empty, insert)
+import Control.Monad.State (replicateM, runState, state)
+
+data On = On {
+      flower :: Flower
+    , players :: Players Score
+    , turn :: Turn
+    , playing :: Player
+    , lastScored :: Player
+    , oyake :: Player
+    , stock :: [Card]
+  }  deriving (Show)
+data Over = Over {
+      winner :: Player
+    , score :: Int
+  }
+
+newtype Round = Round (Either Over On)
+
+go :: On -> Round
+go = Round . Right
+
+new :: Player -> IO On
+new playing = do
+  ([hand1, hand2, river], next:stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
+  let players = fmap Player.new $ deal [hand1, hand2]
+  return On {
+        flower = Pine
+      , players
+      , turn = Turn.new (packOfCards river) (players ! playing) next
+      , playing
+      , lastScored = playing
+      , oyake = playing
+      , stock
+    }
+  where
+    take8 = state $ splitAt 8
+
+next :: On -> IO On
+next (On {flower, oyake}) = do
+  on <- new $ Player.next oyake
+  return $ on {flower = succ flower}
+
+play :: On -> Move -> Either String Round
+play on@(On {flower, turn, playing, players, stock = next : moreStock}) move =
+  fmap after $ Turn.play turn move
+  where
+    after (Turn {step = Turn.Over True, player}) =
+      Round . Left $ Over {winner = playing, score = Player.score sumYakus player}
+    after (Turn {step = Turn.Over False, player, river}) =
+      let otherPlayer = Player.next playing in
+      go $ on {
+          players = insert playing player players
+        , playing = otherPlayer
+        , turn = (Turn.new river (players ! otherPlayer) next) { month = flower }
+        , stock = moreStock
+      }
+    after newTurn = go $ on {turn = newTurn}

src/Hanafuda/KoiKoi/Turn.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hanafuda.KoiKoi.Turn where
+
+import Hanafuda (Card, Pack, Flower(Pine), contains, flower, match, remove)
+import Hanafuda.KoiKoi.Yaku (Score, meldInto)
+import Hanafuda.Player (Move(..), State(..), plays)
+import Control.Monad.Reader (runReader)
+
+data Step = ToPlay | Turned Card | Scored | Over Bool deriving (Show)
+type Player = State Score
+
+data Turn = Turn {
+      river :: Pack
+    , month :: Flower
+    , player :: Player
+    , next :: Card
+    , step :: Step
+    , trick :: [Card]
+  } deriving (Show)
+
+new :: Pack -> Player -> Card -> Turn
+new river player next = Turn {
+      river
+    , month = Pine
+    , player
+    , next
+    , step = ToPlay
+    , trick = []
+  }
+
+play :: Turn -> Move -> Either String Turn
+play turn@(Turn {river, step, next, trick, player}) move =
+  case (step, move) of
+    (ToPlay, Play card) -> match card river >>= play card
+    (ToPlay, Capture (card, caught)) ->
+      if card `canCatch` caught
+        then play card (remove river caught, [card, caught])
+        else Left "You can't choose that card"
+    (Turned card, Choose caught) ->
+      if card `canCatch` caught
+        then end $ turn {river = remove river caught, trick = [card, caught] ++ trick}
+        else Left "You can't choose that card"
+    (Scored, KoiKoi win) -> Right $ turn {step = Over win}
+    (_, _) -> Left "You can't play this move in that state"
+  where
+    canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
+    play card (river, trick) = do
+      played <- player `plays` card
+      turnOver $ turn {river, trick, player = played}
+
+turnOver :: Turn -> Either String Turn
+turnOver turn@(Turn {river, next, trick}) =
+  case match next river of
+    Right (newRiver, newCaptured) -> end $ turn {river = newRiver, trick = trick ++ newCaptured}
+    Left _ -> Right $ turn {step = Turned next}
+
+end :: Turn -> Either String Turn
+end turn@(Turn {month, trick, player}) =
+  let (scored, newMeld) = runReader (trick `meldInto` (meld player)) month in
+  let updatedPlayer = turn {player = player {meld = newMeld, yakus = scored `mappend` (yakus player)}} in
+  Right $ if null scored
+    then updatedPlayer {step = Over False}
+    else updatedPlayer {step = Scored}

src/Hanafuda/KoiKoi/Yaku.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
-module Hanafuda.Yaku where
+module Hanafuda.KoiKoi.Yaku where
 
-import Hanafuda.Card (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size)
+import Hanafuda (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size)
-import qualified Data.Map as M (Map, empty, insert, unionWith, (!))
+import qualified Data.Map as M (Map, empty, insert, union, unionWith, (!))
 import qualified Data.Set as S (Set, empty, singleton, union)
 import Control.Monad.Reader (reader)
 
@@ -81,11 +81,14 @@ finders = do
     akatan = [PinePoetry, PlumPoetry, CherryPoetry]
     plains = (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..10]]) ++ Lightning : [Paulownia0 .. Sand]
 
-rate :: Pack -> [Card] -> Monthly (Score, Pack)
+meldInto :: [Card] -> Pack -> Monthly (Score, Pack)
-rate pack cards = do
+meldInto cards pack = do
   yakusToCheck <- fmap toCheck finders
   return (foldl scored M.empty yakusToCheck, newPack)
   where
     newPack = foldl add pack cards
     toCheck map = foldl (\set key -> S.union set (map M.! key)) S.empty cards
     scored score (YakuFinder {yaku, rater}) = foldr (M.insert yaku) score $ rater newPack
+
+sumYakus :: Score -> Points
+sumYakus = foldl (+) 0

src/Hanafuda/Month.hs

@@ -1,67 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hanafuda.Month where
-
-import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards)
-import Hanafuda.Day (Day(..))
-import qualified Hanafuda.Day as Day (Step(Over), new)
-import Hanafuda.Game (Game(..), Player, Players, PlayerState(..), initPlayers)
-import qualified Hanafuda.Game as Game (next)
-import Data.Map ((!), insert)
-import Control.Monad.State (replicateM, runState, state)
-
-data On = On {
-      flower :: Flower
-    , players :: Players
-    , day :: Day
-    , playing :: Player
-    , lastScored :: Player
-    , oyake :: Player
-    , stock :: [Card]
-  } 
-data Over = Over {
-      winner :: Player
-    , score :: Int
-  }
-
-newtype Month = Month (Either Over On)
-
-go :: On -> Month
-go = Month . Right
-
-new :: Player -> IO On
-new playing = do
-  ([hand1, hand2, river], next:stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
-  let players = initPlayers [hand1, hand2]
-  return On {
-        flower = Pine
-      , players
-      , day = Day.new (packOfCards river) (players ! playing) next
-      , playing
-      , lastScored = playing
-      , oyake = playing
-      , stock
-    }
-  where
-    take8 = state $ splitAt 8
-
-next :: On -> IO On
-next (On {flower, oyake}) = do
-  on <- new $ Game.next oyake
-  return $ on {flower = succ flower}
-
-instance Game On Month where
-  play on@(On {flower, day, playing, players, stock = next : moreStock}) move =
-    fmap after $ play day move
-    where
-      after (Day {step = Day.Over True, player = PlayerState {yakus}}) =
-        Month . Left $ Over {winner = playing, score = foldl (+) 0 yakus}
-      after (Day {step = Day.Over False, player, river}) =
-        let otherPlayer = Game.next playing in
-        go $ on {
-            players = insert playing player players
-          , playing = otherPlayer
-          , day = (Day.new river (players ! otherPlayer) next) { month = flower }
-          , stock = moreStock
-        }
-      after newDay = go $ on {day = newDay}

src/Hanafuda/Player.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hanafuda.Player where
+
+import Data.Map (Map, empty, fromList)
+import Hanafuda (Card, Pack, contains, packOfCards, remove)
+
+data Player =
+    Player1
+  | Player2
+  deriving (Eq, Ord, Show)
+
+next :: Player -> Player
+next Player1 = Player2
+next _ = Player1
+
+data State a = State {
+      hand :: Pack
+    , meld :: Pack
+    , yakus :: a
+  } deriving (Show)
+type Players a = Map Player (State a)
+
+deal :: [a] -> Map Player a
+deal = fromList . zip [Player1, Player2]
+
+new :: Monoid a => [Card] -> State a
+new cards = State {
+      hand = packOfCards cards
+    , meld = packOfCards []
+    , yakus = mempty
+  }
+
+plays :: State a -> Card -> Either String (State a)
+plays player@(State {hand}) card =
+  if hand `contains` card
+    then Right $ player {hand = remove hand card}
+    else Left "You don't have this card"
+
+data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
+
+type Points = Int
+
+score :: (a -> Points) -> State a -> Int
+score rater = rater . yakus
+
+type Scores = Map Player Points

src/Hanafuda/Year.hs

@@ -1,54 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-module Hanafuda.Year where
-
-import Hanafuda.Card (Flower(Paulownia))
-import Hanafuda.Month (Month(..), flower, next, score, winner)
-import qualified Hanafuda.Month as Month (On(..), Over(..), new)
-import Hanafuda.Game (Game(..), Player(Player1), Scores, deal)
-import Data.Map (insert, (!))
-import System.Random (StdGen)
-
-data Mode = FirstAt Int | WholeYear
-
-data On = On {
-      mode :: Mode
-    , month :: Month.On
-    , scores :: Scores
-  }
-data Over = Over {
-    finalScores :: Scores
-  }
-
-newtype Year = Year (Either Over On)
-
-go :: On -> IO Year
-go = return . Year . Right
-
-new :: Mode -> IO Year
-new mode = do
-  month <- Month.new Player1
-  go $ On {mode , month , scores = deal $ cycle [0]}
-
-consolidate :: On -> Player -> Int -> IO Year
-consolidate on@(On {mode, month, scores}) winner score =
-  case mode of
-    FirstAt n | n <= newScore -> stop
-    FirstAt n -> continue
-    WholeYear | flower month == Paulownia -> stop
-    WholeYear -> continue
-  where
-    newScore = scores ! winner + score
-    newScores = insert winner newScore scores
-    stop = return . Year . Left $ Over {finalScores = newScores}
-    continue = do
-      nextMonth <- next month
-      go $ on {scores = newScores, month = nextMonth}
-
-instance Game On (IO Year) where
-  play on@(On {mode, month}) move =
-    fmap after $ play month move
-    where
-      after (Month (Left (Month.Over {winner, score}))) = consolidate on winner score
-      after (Month (Right newMonth)) = go $ on {month = newMonth}