Restructure project to expose only what's needed to play KoiKoi and hide
all the inner logic in that module
This commit is contained in:
Sasha
parent
d596a220b5
commit
b63c06a317
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ module Hanafuda (
|
|||
, add
|
||||
, cards
|
||||
, contains
|
||||
, empty
|
||||
, flower
|
||||
, intersection
|
||||
, match
|
||||
|
|
|
|||
|
|
@ -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 = []
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue