diff --git a/ChangeLog.md b/ChangeLog.md index 7a1b7fc..8bb2ec3 100644 --- a/ChangeLog.md +++ b/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 diff --git a/hanafuda.cabal b/hanafuda.cabal index c5a479c..2bdda51 100644 --- a/hanafuda.cabal +++ b/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: diff --git a/src/Hanafuda.hs b/src/Hanafuda.hs index 413d25d..761da62 100644 --- a/src/Hanafuda.hs +++ b/src/Hanafuda.hs @@ -6,6 +6,7 @@ module Hanafuda ( , add , cards , contains + , empty , flower , intersection , match diff --git a/src/Hanafuda/KoiKoi.hs b/src/Hanafuda/KoiKoi.hs index 1d521cd..3e8b627 100644 --- a/src/Hanafuda/KoiKoi.hs +++ b/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 = [] + } diff --git a/src/Hanafuda/KoiKoi/Game.hs b/src/Hanafuda/KoiKoi/Game.hs new file mode 100644 index 0000000..46b1b6b --- /dev/null +++ b/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 diff --git a/src/Hanafuda/KoiKoi/Round.hs b/src/Hanafuda/KoiKoi/Round.hs index 92647fe..977244f 100644 --- a/src/Hanafuda/KoiKoi/Round.hs +++ b/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 diff --git a/src/Hanafuda/KoiKoi/Turn.hs b/src/Hanafuda/KoiKoi/Turn.hs index f333aad..38f921d 100644 --- a/src/Hanafuda/KoiKoi/Turn.hs +++ b/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} diff --git a/src/Hanafuda/KoiKoi/Yaku.hs b/src/Hanafuda/KoiKoi/Yaku.hs index b1a666d..c3a8347 100644 --- a/src/Hanafuda/KoiKoi/Yaku.hs +++ b/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 diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs index c4a02df..01b42fe 100644 --- a/src/Hanafuda/Player.hs +++ b/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