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
+      Card(..)
-    , play
+    , Game(..)
-    , Card(..)
     , Mode(..)
     , Move(..)
-    , On
+    , On(..)
     , Over(..)
+    , new
+    , play
   ) where
 
-import Prelude hiding (round)
+import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
-import Hanafuda (Flower(Paulownia), Card(..))
+import qualified Hanafuda.Player as Player (deal)
-import Hanafuda.KoiKoi.Round (Round(..), flower, next, score, winner)
+import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Move(..), On(..), Over(..), Step(..), raise)
-import qualified Hanafuda.KoiKoi.Round as Round (On(..), Over(..), new, play)
+import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
-import Hanafuda.Player (Move(..), Player(Player1), Scores, deal)
+import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
-import Data.Map (insert, (!))
+import System.Random (randomIO)
-import System.Random (StdGen)
 
-data Mode = FirstAt Int | WholeYear deriving (Show)
+play :: Move -> On -> IO Game
-
+play move on@(On_ {river, step, trick}) =
-data On = On {
+  case (step, move) of
-      mode :: Mode
+    (ToPlay, Play card) ->
-    , round :: Round.On
+      either raise (Turn.catch on card) $ match card river
-    , scores :: Scores
+    (ToPlay, Capture (card, caught)) ->
-  } deriving (Show)
+      if card `canCatch` caught
-data Over = Over {
+        then Turn.catch on card (remove river caught, [card, caught])
-    finalScores :: Scores
+        else raise "You can't choose that card"
-  } deriving (Show)
+    (Turned card, Choose caught) ->
-
+      if card `canCatch` caught
-newtype Game = Game (Either Over On) deriving (Show)
+        then Turn.end on (remove river caught, [card, caught])
-
+        else raise "You can't choose that card"
-go :: On -> IO Game
+    (Scored, KoiKoi keepOn) -> (if keepOn then Turn.next else Round.next) on
-go = return . Game . Right
+    (_, _) -> 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
+  playing <- randomIO
-  return $ On {mode , round , scores = deal [0, 0]}
+  Round.deal $ On_ {
-
+        mode
-consolidate :: On -> Player -> Int -> IO Game
+      , scores = Player.deal [0, 0]
-consolidate on@(On {mode, round, scores}) winner score =
+      , month = Pine
-  case mode of
+      , players = undefined
-    FirstAt n | n <= newScore -> stop
+      , playing
-    FirstAt n -> continue
+      , winning = playing
-    WholeYear | flower round == Paulownia -> stop
+      , oyake = playing
-    WholeYear -> continue
+      , stock = undefined
-  where
+      , river = undefined
-    newScore = scores ! winner + score
+      , step = ToPlay
-    newScores = insert winner newScore scores
+      , trick = []
-    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/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 (
-module Hanafuda.KoiKoi.Round where
+      deal
+    , next
+  ) where
 
-import Hanafuda (Card, Flower(Pine), cards, shuffle, packOfCards)
+import Hanafuda (Flower(Paulownia), cards, shuffle, packOfCards)
-import Hanafuda.KoiKoi.Yaku (Score, sumYakus)
+import Hanafuda.KoiKoi.Yaku (sumYakus)
-import Hanafuda.KoiKoi.Turn (Turn(..))
+import Hanafuda.KoiKoi.Game (Game, Mode(..), On(..), Step(..), end, stop)
-import qualified Hanafuda.KoiKoi.Turn as Turn (Step(Over), new, play)
+import qualified Hanafuda.Player as Player (deal, next, new, score)
-import Hanafuda.Player (Move, Player, Players, deal)
+import Data.Map ((!), insert)
-import qualified Hanafuda.Player as Player (next, new, score)
-import Data.Map ((!), empty, insert)
 import Control.Monad.State (replicateM, runState, state)
 
-data On = On {
+deal :: On -> IO On
-      flower :: Flower
+deal on = do
-    , players :: Players Score
+  ([hand1, hand2, river], stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
-    , turn :: Turn
+  return on {
-    , playing :: Player
+        players = fmap Player.new $ Player.deal [hand1, hand2]
-    , 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
+      , river = packOfCards river
     }
   where
     take8 = state $ splitAt 8
 
-next :: On -> IO On
+next :: On -> IO Game
-next (On {flower, oyake}) = do
+next on@(On_ {mode, scores, month, players, oyake, winning}) =
-  on <- new $ Player.next oyake
+  case mode of
-  return $ on {flower = succ flower}
+    FirstAt n | n <= newScore -> end scored
-
+    FirstAt n -> continue
-play :: On -> Move -> Either String Round
+    WholeYear | month == Paulownia -> end scored
-play on@(On {flower, turn, playing, players, stock = next : moreStock}) move =
+    WholeYear -> continue
-  fmap after $ Turn.play turn move
   where
-    after (Turn {step = Turn.Over True, player}) =
+    playing = Player.next oyake
-      Round . Left $ Over {winner = playing, score = Player.score sumYakus player}
+    newScore = (scores ! winning) + Player.score sumYakus (players ! winning)
-    after (Turn {step = Turn.Over False, player, river}) =
+    scored = on {scores = insert winning newScore scores}
-      let otherPlayer = Player.next playing in
+    continue =
-      go $ on {
+      deal (scored {
-          players = insert playing player players
+            month = succ month
-        , playing = otherPlayer
+          , playing
-        , turn = (Turn.new river (players ! otherPlayer) next) { month = flower }
+          , winning = playing
-        , stock = moreStock
+          , oyake = playing
-      }
+          , step = ToPlay
-    after newTurn = go $ on {turn = newTurn}
+        }) >>= stop

src/Hanafuda/KoiKoi/Turn.hs

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