diff --git a/ChangeLog.md b/ChangeLog.md index 91acd35..3ce6232 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/hanafuda.cabal b/hanafuda.cabal index 7b54aa9..35e7cc2 100644 --- a/hanafuda.cabal +++ b/hanafuda.cabal @@ -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 diff --git a/src/Hanafuda.hs b/src/Hanafuda.hs index e1fe004..924efba 100644 --- a/src/Hanafuda.hs +++ b/src/Hanafuda.hs @@ -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) diff --git a/src/Hanafuda/ID.hs b/src/Hanafuda/ID.hs new file mode 100644 index 0000000..d9bb031 --- /dev/null +++ b/src/Hanafuda/ID.hs @@ -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 diff --git a/src/Hanafuda/KoiKoi.hs b/src/Hanafuda/KoiKoi.hs index 07749b3..28f4a2d 100644 --- a/src/Hanafuda/KoiKoi.hs +++ b/src/Hanafuda/KoiKoi.hs @@ -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] diff --git a/src/Hanafuda/KoiKoi/Game.hs b/src/Hanafuda/KoiKoi/Game.hs index 2b0a03b..3f45905 100644 --- a/src/Hanafuda/KoiKoi/Game.hs +++ b/src/Hanafuda/KoiKoi/Game.hs @@ -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} diff --git a/src/Hanafuda/KoiKoi/Round.hs b/src/Hanafuda/KoiKoi/Round.hs index 0d453d2..34798f4 100644 --- a/src/Hanafuda/KoiKoi/Round.hs +++ b/src/Hanafuda/KoiKoi/Round.hs @@ -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 diff --git a/src/Hanafuda/KoiKoi/Turn.hs b/src/Hanafuda/KoiKoi/Turn.hs index aba4873..27fcabd 100644 --- a/src/Hanafuda/KoiKoi/Turn.hs +++ b/src/Hanafuda/KoiKoi/Turn.hs @@ -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 diff --git a/src/Hanafuda/KoiKoi/Yaku.hs b/src/Hanafuda/KoiKoi/Yaku.hs index 2341411..fb5501e 100644 --- a/src/Hanafuda/KoiKoi/Yaku.hs +++ b/src/Hanafuda/KoiKoi/Yaku.hs @@ -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] diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs index 1744a78..779f05f 100644 --- a/src/Hanafuda/Player.hs +++ b/src/Hanafuda/Player.hs @@ -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)