Restructure project to expose only what's needed to play KoiKoi and hide

all the inner logic in that module

ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for hanafuda
 
+## 0.2.0.0  -- 2018-03-16
+
+* Restructured the project to expose only the cards, a parametric type for players, and a module to play KoiKoi
+
 ## 0.1.0.0  -- 2018-03-03
 
 * Game automaton, packaged with cabal

hanafuda.cabal

@@ -2,9 +2,17 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hanafuda
-version:             0.1.0.0
+version:             0.2.0.0
 synopsis:            A game of Hanafuda (a family of japanese card games)
--- description:         
+description:         This is a library to represent the cards and the players
+                     of games in this family. It also implements one such game
+                     named KoiKoi as an example of its possibilities.
+                     The Hanafuda.KoiKoi module in itself provides a
+                     representation of the game's state, and exposes the
+                     constructors you need to interact with it : initializing a
+                     new game and playing moves. Its approach is move-by-move :
+                     a game's state is computed from the previous state and a
+                     move.
 homepage:            https://framagit.org/sasha/hanafuda
 license:             BSD3
 license-file:        LICENSE
@@ -15,12 +23,16 @@ category:            Game
 build-type:          Simple
 extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
+source-repository head
+  type:              git
+  location:          https://framagit.org/sasha/hanafuda
 
 library
   exposed-modules:     Hanafuda
                      , Hanafuda.KoiKoi
                      , Hanafuda.Player
-  other-modules:       Hanafuda.KoiKoi.Round
+  other-modules:       Hanafuda.KoiKoi.Game
+                     , Hanafuda.KoiKoi.Round
                      , Hanafuda.KoiKoi.Turn
                      , Hanafuda.KoiKoi.Yaku
   -- other-modules:

src/Hanafuda.hs

@@ -6,6 +6,7 @@ module Hanafuda (
     , add
     , cards
     , contains
+    , empty
     , flower
     , intersection
     , match

src/Hanafuda/KoiKoi.hs

@@ -1,63 +1,53 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
 module Hanafuda.KoiKoi (
-      new
-    , play
-    , Card(..)
+      Card(..)
+    , Game(..)
     , Mode(..)
     , Move(..)
-    , On
+    , On(..)
     , Over(..)
+    , new
+    , play
   ) 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)
+import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
+import qualified Hanafuda.Player as Player (deal)
+import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Move(..), On(..), Over(..), Step(..), raise)
+import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
+import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
+import System.Random (randomIO)
 
-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
+play :: Move -> On -> IO Game
+play move on@(On_ {river, step, trick}) =
+  case (step, move) of
+    (ToPlay, Play card) ->
+      either raise (Turn.catch on card) $ match card river
+    (ToPlay, Capture (card, caught)) ->
+      if card `canCatch` caught
+        then Turn.catch on card (remove river caught, [card, caught])
+        else raise "You can't choose that card"
+    (Turned card, Choose caught) ->
+      if card `canCatch` caught
+        then Turn.end on (remove river caught, [card, caught])
+        else raise "You can't choose that card"
+    (Scored, KoiKoi keepOn) -> (if keepOn then Turn.next else Round.next) on
+    (_, _) -> raise "You can't play this move in that state"
+  where
+    canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
 
 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}
+  playing <- randomIO
+  Round.deal $ On_ {
+        mode
+      , scores = Player.deal [0, 0]
+      , month = Pine
+      , players = undefined
+      , playing
+      , winning = playing
+      , oyake = playing
+      , stock = undefined
+      , river = undefined
+      , step = ToPlay
+      , trick = []
+    }

src/Hanafuda/KoiKoi/Game.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Hanafuda.KoiKoi.Game (
+      Game(..)
+    , Mode(..)
+    , Move(..)
+    , On(..)
+    , Over(..)
+    , Step(..)
+    , end
+    , raise
+    , setPlayer
+    , stop
+  ) where
+
+import Hanafuda (Card, Flower, Pack)
+import Hanafuda.Player (Players, Player, Scores, Seat)
+import Hanafuda.KoiKoi.Yaku (Score)
+import Data.Map (insert)
+
+data Mode = FirstAt Int | WholeYear deriving (Show)
+data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
+data Step = ToPlay | Turned Card | Scored deriving (Show)
+
+data On = On_ {
+      mode :: Mode
+    , scores :: Scores
+    , month :: Flower
+    , players :: Players Score
+    , playing :: Seat
+    , winning :: Seat
+    , oyake :: Seat
+    , stock :: [Card]
+    , river :: Pack
+    , step :: Step
+    , trick :: [Card]
+  } deriving (Show)
+data Over = Over_ {
+    finalScores :: Scores
+  } deriving (Show)
+
+data Game = Error String | Over Over | On On deriving (Show)
+
+setPlayer :: On -> Player Score -> On
+setPlayer on@(On_ {players, playing}) player = on {players = insert playing player players}
+
+end :: On -> IO Game
+end (On_ {scores}) = return . Over $ Over_ {finalScores = scores}
+
+stop :: On -> IO Game
+stop = return . On
+
+raise :: String -> IO Game
+raise = return . Error

src/Hanafuda/KoiKoi/Round.hs

@@ -1,68 +1,43 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hanafuda.KoiKoi.Round where
+module Hanafuda.KoiKoi.Round (
+      deal
+    , next
+  ) 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 Hanafuda (Flower(Paulownia), cards, shuffle, packOfCards)
+import Hanafuda.KoiKoi.Yaku (sumYakus)
+import Hanafuda.KoiKoi.Game (Game, Mode(..), On(..), Step(..), end, stop)
+import qualified Hanafuda.Player as Player (deal, next, new, score)
+import Data.Map ((!), 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
+deal :: On -> IO On
+deal on = do
+  ([hand1, hand2, river], stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
+  return on {
+        players = fmap Player.new $ Player.deal [hand1, hand2]
       , stock
+      , river = packOfCards river
     }
   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
+next :: On -> IO Game
+next on@(On_ {mode, scores, month, players, oyake, winning}) =
+  case mode of
+    FirstAt n | n <= newScore -> end scored
+    FirstAt n -> continue
+    WholeYear | month == Paulownia -> end scored
+    WholeYear -> continue
   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}
+    playing = Player.next oyake
+    newScore = (scores ! winning) + Player.score sumYakus (players ! winning)
+    scored = on {scores = insert winning newScore scores}
+    continue =
+      deal (scored {
+            month = succ month
+          , playing
+          , winning = playing
+          , oyake = playing
+          , step = ToPlay
+        }) >>= stop

src/Hanafuda/KoiKoi/Turn.hs

@@ -1,64 +1,48 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hanafuda.KoiKoi.Turn where
+module Hanafuda.KoiKoi.Turn (
+      catch
+    , end
+    , next
+    , popNextCard
+  ) where
 
-import Hanafuda (Card, Pack, Flower(Pine), contains, flower, match, remove)
-import Hanafuda.KoiKoi.Yaku (Score, meldInto)
-import Hanafuda.Player (Move(..), State(..), plays)
+import Hanafuda (Card, Pack, empty, match)
+import Hanafuda.Player (Players, Player(..), plays)
+import qualified Hanafuda.Player as Player (next)
+import Hanafuda.KoiKoi.Yaku (meldInto)
+import Hanafuda.KoiKoi.Game (Game, On(..), Step(..), raise, setPlayer, stop)
+import qualified Hanafuda.KoiKoi.Round as Round (next)
+import Data.Map ((!))
 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"
+catch :: On -> Card -> (Pack, [Card]) -> IO Game
+catch on@(On_ {players, playing}) card (river, trick) =
+  either raise (popNextCard . setPlayer (on {river, trick})) played
   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}
+    played = (players ! playing) `plays` card
 
-turnOver :: Turn -> Either String Turn
-turnOver turn@(Turn {river, next, trick}) =
+popNextCard :: On -> IO Game
+popNextCard on@(On_ {river, stock = next : others, trick}) =
+  let pop = on {stock = others} in
   case match next river of
-    Right (newRiver, newCaptured) -> end $ turn {river = newRiver, trick = trick ++ newCaptured}
-    Left _ -> Right $ turn {step = Turned next}
+    Right (newRiver, newCaptured) -> end pop (newRiver, newCaptured)
+    Left _ -> stop $ pop {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}
+end :: On -> (Pack, [Card]) -> IO Game
+end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do
+  let updatedGame = setPlayer (on {river, trick = []}) updatedPlayer
+  if null scored
+    then next updatedGame
+    else stop $ updatedGame {step = Scored, winning = playing}
+  where
+    newTrick = newCaptured ++ trick
+    player = players ! playing
+    (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
+    updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}
+
+next :: On -> IO Game
+next on@(On_ {players, playing}) =
+  let newPlaying = Player.next playing in
+  if hand (players ! newPlaying) == empty
+    then Round.next $ on
+    else stop $ on {playing = newPlaying, step = ToPlay}

src/Hanafuda/KoiKoi/Yaku.hs

@@ -2,7 +2,7 @@
 module Hanafuda.KoiKoi.Yaku where
 
 import Hanafuda (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size)
-import qualified Data.Map as M (Map, empty, insert, union, unionWith, (!))
+import qualified Data.Map as M (Map, empty, insert, null, union, unionWith, (!))
 import qualified Data.Set as S (Set, empty, singleton, union)
 import Control.Monad.Reader (reader)
 
@@ -91,4 +91,6 @@ meldInto cards pack = do
     scored score (YakuFinder {yaku, rater}) = foldr (M.insert yaku) score $ rater newPack
 
 sumYakus :: Score -> Points
-sumYakus = foldl (+) 0
+sumYakus s
+  | null s = 6
+  | otherwise = foldl (+) 0 s

src/Hanafuda/Player.hs

@@ -1,47 +1,52 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 module Hanafuda.Player where
 
-import Data.Map (Map, empty, fromList)
 import Hanafuda (Card, Pack, contains, packOfCards, remove)
+import Data.Map (Map, fromList)
+import System.Random (Random(..))
 
-data Player =
+data Seat =
     Player1
   | Player2
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Enum)
 
-next :: Player -> Player
+instance Random Seat where
+  randomR (lo, hi) g =
+    let (n, g') = randomR (fromEnum lo, fromEnum hi) g in
+    (toEnum n, g')
+
+  random = randomR (Player1, Player2)
+
+next :: Seat -> Seat
 next Player1 = Player2
 next _ = Player1
 
-data State a = State {
+data Player a = Player {
       hand :: Pack
     , meld :: Pack
     , yakus :: a
   } deriving (Show)
-type Players a = Map Player (State a)
+type Players a = Map Seat (Player a)
 
-deal :: [a] -> Map Player a
+deal :: [a] -> Map Seat a
 deal = fromList . zip [Player1, Player2]
 
-new :: Monoid a => [Card] -> State a
-new cards = State {
+new :: Monoid a => [Card] -> Player a
+new cards = Player {
       hand = packOfCards cards
     , meld = packOfCards []
     , yakus = mempty
   }
 
-plays :: State a -> Card -> Either String (State a)
-plays player@(State {hand}) card =
+plays :: Player a -> Card -> Either String (Player a)
+plays player@(Player {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 :: (a -> Points) -> Player a -> Int
 score rater = rater . yakus
 
-type Scores = Map Player Points
+type Scores = Map Seat Points