hanafuda/lib
1
1
Fork 0
Code Issues Pull requests Releases Wiki Activity

Add IDs handling directly in library + add a couple useful functions on Hanafuda cards

Browse source
This commit is contained in:
Tissevert 2019-08-24 23:04:37 +02:00
parent f1ee562809
commit 61eeac8bc6
10 changed files with 129 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
ChangeLog.md
View file

@ -1,5 +1,10 @@
# Revision history for hanafuda
## 0.3.3.0 -- 2019-08-24
* Add IDs handling directly in library : it's a newtype phantom type to generate IDs for any type and it's used to make IDs for players and KoiKoi games which allows to decrease the arity of the Player constructor
* Some more useful function were added to the Hanafuda module : they simplify Yakus a bit and will be useful for Hannah, the bot to come soon — Yakus were extended further by defining a notion of distance to a Yaku that will hopefully help a bot determine how close it is from scoring a Yaku
## 0.3.2.0 -- 2019-08-12
* Handle the end of games

11
hanafuda.cabal
View file

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: hanafuda
version: 0.3.2.0
version: 0.3.3.0
synopsis: A game of Hanafuda (a family of japanese card games)
description: This is a library to represent the cards and the players
of games in this family. It also implements one such game
@ -13,11 +13,11 @@ description: This is a library to represent the cards and the players
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/hanafuda
homepage: https://git.marvid.fr/hanafuda
license: BSD3
license-file: LICENSE
author: Sasha
maintainer: sasha+frama@marvid.fr
author: Tissevert
maintainer: tissevert+devel@marvid.fr
-- copyright:
category: Game
build-type: Simple
@ -25,12 +25,13 @@ extra-source-files: ChangeLog.md
cabal-version: >=1.10
source-repository head
type: git
location: https://framagit.org/hanafuda/lib
location: https://git.marvid.fr/hanafuda/lib
library
exposed-modules: Hanafuda
, Hanafuda.KoiKoi
, Hanafuda.Player
, Hanafuda.ID
other-modules: Hanafuda.KoiKoi.Game
, Hanafuda.KoiKoi.Round
, Hanafuda.KoiKoi.Turn

17
src/Hanafuda.hs
View file

@ -5,16 +5,20 @@ module Hanafuda (
, Pack
, add
, cards
, cardsOf
, cardsOfPack
, contains
, difference
, empty
, flower
, intersection
, match
, packOfCards
, remove
, sameMonth
, shuffle
, size
, union
) where
import Data.Word (Word64)
@ -26,6 +30,7 @@ import Data.Bits (
, testBit
, xor
, (.&.)
, (.|.)
, countTrailingZeros
)
import System.Random (randomRIO)
@ -111,8 +116,14 @@ intersection = portBinary (.&.)
difference :: Pack -> Pack -> Pack
difference = portBinary (\a b -> a `xor` (a .&. b))
sameMonth :: Card -> Pack
sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
union :: Pack -> Pack -> Pack
union = portBinary (.|.)
cardsOf :: Flower -> Pack
cardsOf = Pack . shift 0xf . (* 4) . fromEnum
sameMonth :: Card -> Pack -> Pack
sameMonth card (Pack p) = Pack $ (0xf `shift` (fromEnum card .&. 0xfc)) .&. p
cards :: [Card]
cards = [Pine0 .. Phoenix]
@ -130,7 +141,7 @@ shuffle l =
match :: Card -> Pack -> Either String (Pack, [Card])
match card pack =
let sameMonthCards = sameMonth card `intersection` pack in
let sameMonthCards = sameMonth card pack in
case size sameMonthCards of
0 -> Right (add pack card, [])
1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)

10
src/Hanafuda/ID.hs Normal file
View file

@ -0,0 +1,10 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hanafuda.ID (
ID(..)
, getID
) where
newtype ID a = ID Int deriving (Eq, Ord, Enum, Read, Show)
getID :: ID a -> String
getID (ID n) = show n

18
src/Hanafuda/KoiKoi.hs
View file

@ -3,10 +3,13 @@
module Hanafuda.KoiKoi (
Action(..)
, Card(..)
, Game(..)
, Environment
, Game
, GameBlueprint(..)
, GameID
, Mode(..)
, Move(..)
, PlayerID
, Score
, Source(..)
, Step(..)
@ -18,13 +21,16 @@ module Hanafuda.KoiKoi (
import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
import qualified Hanafuda.Player as Player (players, random, scores)
import Hanafuda.KoiKoi.Yaku (Yaku(..), Score)
import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Mode(..), Move(..), Source(..), Step(..))
import Hanafuda.KoiKoi.Game (
Action(..), Environment, Game, GameBlueprint(..), GameID, Mode(..), Move(..), PlayerID
, Source(..), Step(..)
)
import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO)
play :: (Environment m, Ord player) => Move -> Game player -> m (Game player)
play :: Environment m => Move -> Game -> m Game
play move game@(Game {river, step}) =
case (step, move) of
(ToPlay, Play card) ->
@ -43,8 +49,8 @@ play move game@(Game {river, step}) =
where
canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
new :: (MonadIO m, Ord player) => [player] -> Mode -> m (Game player)
new playersList mode = do
new :: MonadIO m => (PlayerID, PlayerID) -> Mode -> m Game
new (playerA, playerB) mode = do
playing <- Player.random players
Round.deal $ Game {
mode
@ -61,4 +67,4 @@ new playersList mode = do
, rounds = []
}
where
players = Player.players playersList
players = Player.players [playerA, playerB]

33
src/Hanafuda/KoiKoi/Game.hs
View file

@ -3,10 +3,14 @@
{-# LANGUAGE ConstraintKinds #-}
module Hanafuda.KoiKoi.Game (
Action(..)
, Game(..)
, Environment
, Game
, GameBlueprint(..)
, GameID
, ID
, Mode(..)
, Move(..)
, PlayerID
, Source(..)
, Step(..)
, end
@ -17,8 +21,10 @@ import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Writer (MonadWriter)
import Hanafuda (Card, Flower, Pack)
import Hanafuda.ID (ID)
import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score)
import Hanafuda.Player (Players, Player, Scores, set)
import Hanafuda.KoiKoi.Yaku (Score)
import qualified Hanafuda.Player as Player (ID)
data Mode = FirstAt Int | WholeYear deriving (Show)
data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
@ -31,24 +37,27 @@ data Action = Action {
} deriving (Show)
type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
type PlayerID = Player.ID KoiKoi.Score
type GameID = ID Game
data Game player = Game {
data GameBlueprint deckType = Game {
mode :: Mode
, scores :: Scores player
, scores :: Scores KoiKoi.Score
, month :: Flower
, players :: Players player Score
, playing :: player
, winning :: player
, oyake :: player
, deck :: [Card]
, players :: Players KoiKoi.Score
, playing :: PlayerID
, winning :: PlayerID
, oyake :: PlayerID
, deck :: deckType
, river :: Pack
, step :: Step
, trick :: [Card]
, rounds :: [(player, Score)]
, rounds :: [(PlayerID, KoiKoi.Score)]
} deriving (Show)
type Game = GameBlueprint [Card]
setPlayer :: Ord player => Game player -> Player player Score -> Game player
setPlayer :: Game -> Player KoiKoi.Score -> Game
setPlayer game@(Game {players, playing}) player = game {players = set playing player players}
end :: Monad m => Game player -> m (Game player)
end :: Monad m => Game -> m Game
end game = return $ game {step = Over}

6
src/Hanafuda/KoiKoi/Round.hs
View file

@ -6,13 +6,13 @@ module Hanafuda.KoiKoi.Round (
import Hanafuda (Flower(Paulownia), cards, shuffle, packOfCards)
import Hanafuda.KoiKoi.Yaku (sumYakus)
import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Step(..), end)
import Hanafuda.KoiKoi.Game (Game, GameBlueprint(..), Mode(..), Step(..), end)
import qualified Hanafuda.Player as Player (deal, get, next, score, yakus)
import Data.Map ((!), insert)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State (runState, state)
deal :: (MonadIO m, Ord player) => Game player -> m (Game player)
deal :: MonadIO m => Game -> m Game
deal game@(Game {players}) = do
((hand1, hand2, river), deck) <- runState getTriple <$> shuffle cards
return game {
@ -24,7 +24,7 @@ deal game@(Game {players}) = do
take8 = state $ splitAt 8
getTriple = (,,) <$> take8 <*> take8 <*> take8
next :: (MonadIO m, Ord player) => Game player -> m (Game player)
next :: MonadIO m => Game -> m Game
next game@(Game {mode, scores, month, players, oyake, winning, rounds}) =
case mode of
FirstAt n | n <= newScore -> end scored

10
src/Hanafuda/KoiKoi/Turn.hs
View file

@ -11,7 +11,7 @@ import Hanafuda (Card, Pack, empty, match)
import Hanafuda.Player (Player(..), plays)
import qualified Hanafuda.Player as Player (get, next)
import Hanafuda.KoiKoi.Yaku (meldInto)
import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Source(..), Step(..), setPlayer)
import Hanafuda.KoiKoi.Game (Action(..), Environment, Game, GameBlueprint(..), Source(..), Step(..), setPlayer)
import qualified Hanafuda.KoiKoi.Round as Round (next)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO)
@ -27,14 +27,14 @@ log source played cards = tell [
captures [_, captured] = Just captured
captures _ = Nothing
catch :: (Environment m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player)
catch :: Environment m => Game -> Card -> (Pack, [Card]) -> m Game
catch game@(Game {players, playing}) card (river, trick) = do
log Hand card trick
(setPlayer (game {river, trick})) <$> played >>= popNextCard
where
played = (Player.get playing players) `plays` card
popNextCard :: (Environment m, Ord player) => Game player -> m (Game player)
popNextCard :: Environment m => Game -> m Game
popNextCard (Game {deck = []}) = throwError "No more cards in the stack"
popNextCard game@(Game {river, deck = turned : others}) =
let pop = game {deck = others} in
@ -42,7 +42,7 @@ popNextCard game@(Game {river, deck = turned : others}) =
Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured)
Left _ -> return $ pop {step = Turned turned}
end :: (MonadWriter [Action] m, MonadIO m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player)
end :: (MonadWriter [Action] m, MonadIO m) => Game -> Card -> (Pack, [Card]) -> m Game
end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
log Deck card newCaptured
let updatedGame = setPlayer (game {river, trick = []}) updatedPlayer
@ -55,7 +55,7 @@ end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
(scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}
next :: (MonadIO m, Ord player) => Game player -> m (Game player)
next :: MonadIO m => Game -> m Game
next game@(Game {players, playing}) =
let newPlaying = Player.next players playing in
if hand (Player.get newPlaying players) == empty

29
src/Hanafuda/KoiKoi/Yaku.hs
View file

@ -1,11 +1,20 @@
{-# LANGUAGE NamedFieldPuns #-}
module Hanafuda.KoiKoi.Yaku where
module Hanafuda.KoiKoi.Yaku (
Score
, Yaku(..)
, meldInto
, sumYakus
) where
import Hanafuda (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size)
import Hanafuda (
Card(..), Monthly, Pack
, add, cardsOf, cardsOfPack, contains, difference, intersection, packOfCards
, size
)
import Hanafuda.Player (Points)
import qualified Data.Map as M (Map, empty, insert, unionWith, (!))
import qualified Data.Set as S (Set, empty, singleton, union)
import Control.Monad.Reader (reader)
import Control.Monad.Reader (asks)
data Yaku =
Lights
@ -18,13 +27,15 @@ data Yaku =
| TsukimiZake
| HanamiZake
| TsukiFuda
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Read, Show)
type YakuRater = Pack -> Maybe Points
type YakuDistance = Pack -> Int
type Score = M.Map Yaku Points
data YakuFinder = YakuFinder {
yaku :: Yaku
, rater :: YakuRater
, distance :: YakuDistance
}
instance Eq YakuFinder where
@ -57,12 +68,16 @@ moreThan count _ pack =
index :: (Yaku, [Card], (Pack -> YakuRater)) -> YakusByCard
index (yaku, cards, scorer) =
let pack = packOfCards cards in
let yakuFinder = YakuFinder {yaku, rater = scorer pack . intersection pack} in
let yakuFinder = YakuFinder {
yaku
, rater = scorer pack . intersection pack
, distance = size . difference pack
} in
foldl (\yakusByCard card -> M.insert card (S.singleton yakuFinder) yakusByCard) M.empty cards
finders :: Monthly YakusByCard
finders = do
monthCardPlus <- reader $ (+) . (4*) . fromEnum
monthCards <- cardsOfPack <$> asks cardsOf
return $ foldl (\yakusByCard -> M.unionWith S.union yakusByCard . index) M.empty [
(Lights, [Crane, CampCurtain, FullMoon, RainMan, Phoenix], lights)
, (InoShikaCho, inoshikacho, fixed 5)
@ -73,7 +88,7 @@ finders = do
, (Kasu, plains, moreThan 9)
, (TsukimiZake, [SakeCup, FullMoon], fixed 3)
, (HanamiZake, [SakeCup, CampCurtain], fixed 3)
, (TsukiFuda, map (toEnum . monthCardPlus) [0..3], fixed 5)
, (TsukiFuda, monthCards, fixed 5)
]
where
inoshikacho = [Butterflies, Boar, Deer]

58
src/Hanafuda/Player.hs
View file

@ -3,21 +3,23 @@
module Hanafuda.Player where
import Hanafuda (Card, Pack, contains, packOfCards, remove)
import qualified Hanafuda.ID as Hanafuda (ID)
import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
import qualified Data.Map as Map (filter)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Except (MonadError(..))
import System.Random (Random(..))
data Player key yakus = Player {
type ID yakus = Hanafuda.ID (Player yakus)
data Player yakus = Player {
hand :: Pack
, meld :: Pack
, nextPlayer :: key
, nextPlayer :: ID yakus
, yakus :: yakus
} deriving (Show)
newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show)
newtype Players yakus = Players (Map (ID yakus) (Player yakus)) deriving (Show)
new :: Monoid yakus => key -> Player key yakus
new :: Monoid yakus => (ID yakus) -> Player yakus
new nextPlayer = Player {
hand = packOfCards []
, meld = packOfCards []
@ -25,49 +27,51 @@ new nextPlayer = Player {
, yakus = mempty
}
players :: (Ord key, Monoid yakus) => [key] -> Players key yakus
players :: Monoid yakus => [ID yakus] -> Players yakus
players [] = Players empty
players [player] = Players $ singleton player $ new player
players (alice:others@(bob:_)) =
let Players playersByKey = players others in
let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByKey in
Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByKey
let Players playersByID = players others in
let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByID in
Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByID
where
setNextPlayer nextPlayer player = player {nextPlayer}
next :: Ord key => Players key yakus -> key -> key
next (Players playersByKey) = nextPlayer . (playersByKey !)
next :: Players yakus -> (ID yakus) -> (ID yakus)
next (Players playersByID) = nextPlayer . (playersByID !)
random :: MonadIO m => Players key yakus -> m key
random (Players playersByKey) =
fst . ($ playersByKey) . elemAt <$> randomIndex
random :: MonadIO m => Players yakus -> m (ID yakus)
random (Players playersByID) =
fst . ($ playersByID) . elemAt <$> randomIndex
where
randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
randomIndex = liftIO $ randomRIO (0, size playersByID - 1)
get :: Ord key => key -> Players key yakus -> Player key yakus
get key (Players playersByKey) = playersByKey ! key
get :: (ID yakus) -> Players yakus -> Player yakus
get playerID (Players playersByID) = playersByID ! playerID
set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus
set key player (Players playersByKey) = Players $ insert key player playersByKey
set :: (ID yakus) -> Player yakus -> Players yakus -> Players yakus
set playerID player (Players playersByID) = Players $ insert playerID player playersByID
deal :: (Ord key, Monoid yakus) => Players key yakus -> [[Card]] -> Players key yakus
deal (Players playersByKey) hands =
Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands
deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus
deal (Players playersByID) hands =
Players $ snd $ foldl dealTo (fst $ findMin playersByID, playersByID) hands
where
setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards}
dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m)
setHand cards (Player {nextPlayer}) =
(new nextPlayer) {hand = packOfCards cards}
dealTo (playerID, m) hand =
(nextPlayer $ m ! playerID, adjust (setHand hand) playerID m)
plays :: MonadError String m => Player key yakus -> Card -> m (Player key yakus)
plays :: MonadError String m => Player yakus -> Card -> m (Player yakus)
plays player@(Player {hand}) card =
if hand `contains` card
then return $ player {hand = remove hand card}
else throwError "You don't have this card"
type Points = Int
type Scores key = Map key Points
type Scores yakus = Map (ID yakus) Points
score :: (yakus -> Points) -> Player key yakus -> Points
score :: (yakus -> Points) -> Player yakus -> Points
score rater = rater . yakus
scores :: Ord key => Players key yakus -> [Points] -> Scores key
scores :: Players yakus -> [Points] -> Scores yakus
scores (Players playersByKey) = fromList . zip (keys playersByKey)