From dfccff29154b07342ac9a8c5f6815c6474e78dcd Mon Sep 17 00:00:00 2001 From: Sasha Date: Mon, 5 Mar 2018 16:29:10 +0100 Subject: [PATCH] Package with cabal and implement game automaton --- .gitignore | 3 +- ChangeLog.md | 5 ++ LICENSE | 30 +++++++++++ Yaku.hs | 79 ----------------------------- hanafuda.cabal | 33 ++++++++++++ Card.hs => src/Hanafuda/Card.hs | 13 +++-- src/Hanafuda/Day.hs | 62 +++++++++++++++++++++++ src/Hanafuda/Game.hs | 39 ++++++++++++++ src/Hanafuda/Month.hs | 66 ++++++++++++++++++++++++ src/Hanafuda/Yaku.hs | 90 +++++++++++++++++++++++++++++++++ src/Hanafuda/Year.hs | 56 ++++++++++++++++++++ 11 files changed, 390 insertions(+), 86 deletions(-) create mode 100644 ChangeLog.md create mode 100644 LICENSE delete mode 100644 Yaku.hs create mode 100644 hanafuda.cabal rename Card.hs => src/Hanafuda/Card.hs (89%) create mode 100644 src/Hanafuda/Day.hs create mode 100644 src/Hanafuda/Game.hs create mode 100644 src/Hanafuda/Month.hs create mode 100644 src/Hanafuda/Yaku.hs create mode 100644 src/Hanafuda/Year.hs diff --git a/.gitignore b/.gitignore index 1422057..b232802 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1 @@ -*.hi -*.o +/dist/* diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..7a1b7fc --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for hanafuda + +## 0.1.0.0 -- 2018-03-03 + +* Game automaton, packaged with cabal diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6687295 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Sasha + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sasha nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Yaku.hs b/Yaku.hs deleted file mode 100644 index 5d483fe..0000000 --- a/Yaku.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Yaku where - -import Card (Card(..), Flower, Pack, size, contains, intersection, packOfCards) -import Data.Map (Map, empty, insert, unionWith) - -data Yaku = - Goko - | Shiko - | AmeShiko - | Sanko - | InoShikaCho - | Tane - | Akatan - | Aotan - | Tan - | Kasu - | TsukimiZake - | HanamiZake - | TsukiFuda - deriving (Eq, Ord, Show) -type Points = Int -type YakuFinder = Pack -> Maybe (Yaku, Points) -type Score = Map Yaku Points - -fixed :: (Yaku, Points) -> Pack -> YakuFinder -fixed points indicatorSet pack = if pack == indicatorSet then Just points else Nothing - -moreThan :: Int -> Yaku -> (Pack -> YakuFinder) -moreThan count yaku _ pack = - let n = size pack - count in - if n > 0 then Just (yaku, n) else Nothing - -lights :: [Card] -lights = [Crane, CampCurtain, FullMoon, RainMan, Phoenix] - -hikari :: Pack -> YakuFinder -hikari _ pack = rate (size pack) (pack `contains` RainMan) - where - rate 5 _ = Just (Goko, 10) - rate 4 hasRainMan = if hasRainMan then Just (AmeShiko, 7) else Just (Shiko, 8) - rate n hasRainMan = if not hasRainMan && n > 2 then Just (Sanko, 5) else Nothing - -tsukiFuda :: Flower -> ([Card], Pack -> YakuFinder) -tsukiFuda flower = (map toEnum $ map (fromEnum flower * 4 +) [0..3], fixed (TsukiFuda, 8)) - -index :: ([Card], Pack -> YakuFinder) -> Map Card [YakuFinder] -index (cards, scorer) = - let pack = packOfCards cards in - foldl (\map card -> insert card [scorer pack . intersection pack] map) empty cards - -inoshikacho :: [Card] -inoshikacho = [Butterflies, Boar, Deer] - -animals :: [Card] -animals = [BushWarbler, Cuckoo, EightPlankBridge, Geese, SakeCup, Swallow] ++ inoshikacho - -blue :: [Card] -blue = [PeonyBlue, ChrysanthemumBlue, MapleBlue] - -poetry :: [Card] -poetry = [PinePoetry, PlumPoetry, CherryPoetry] - -ribbons = [WisteriaRed, IrisRed, BushCloverRed, WillowRed] ++ blue ++ poetry - -plain :: [Card] -plain = (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..10]]) ++ Lightning : [Paulownia0 .. Sand] - -allYakus :: Map Card [YakuFinder] -allYakus = foldl (\map -> unionWith (++) map . index) empty [ - (lights, hikari) - , (inoshikacho, fixed (InoShikaCho, 5)) - , (animals, moreThan 4 Tane) - , (poetry, fixed (Akatan, 5)) - , (blue, fixed (Aotan, 5)) - , (ribbons, moreThan 4 Tan) - , (plain, moreThan 9 Kasu) - , ([SakeCup, FullMoon], fixed (TsukimiZake, 5)) - , ([SakeCup, CampCurtain], fixed (HanamiZake, 5)) - ] diff --git a/hanafuda.cabal b/hanafuda.cabal new file mode 100644 index 0000000..6de3071 --- /dev/null +++ b/hanafuda.cabal @@ -0,0 +1,33 @@ +-- Initial hanafuda.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: hanafuda +version: 0.1.0.0 +synopsis: A game of Hanafuda (a family of japanese card games) +-- description: +homepage: https://framagit.org/sasha/hanafuda +license: BSD3 +license-file: LICENSE +author: Sasha +maintainer: sasha+frama@marvid.fr +-- copyright: +category: Game +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Hanafuda.Year + , Hanafuda.Month + , Hanafuda.Day + , Hanafuda.Game + , Hanafuda.Yaku + , Hanafuda.Card + -- other-modules: + -- other-extensions: + build-depends: base >=4.10 && <4.11 + , containers + , mtl + , random + hs-source-dirs: src + default-language: Haskell2010 diff --git a/Card.hs b/src/Hanafuda/Card.hs similarity index 89% rename from Card.hs rename to src/Hanafuda/Card.hs index b706427..38ef445 100644 --- a/Card.hs +++ b/src/Hanafuda/Card.hs @@ -1,4 +1,4 @@ -module Card where +module Hanafuda.Card where import Data.Word (Word64) import Data.Bits ( @@ -14,6 +14,7 @@ import Data.Bits ( , countTrailingZeros ) import System.Random (randomRIO) +import Control.Monad.Reader (Reader) data Flower = Pine @@ -48,13 +49,15 @@ data Card = flower :: Card -> Flower flower = toEnum . (`div` 4) . fromEnum +type Monthly a = Reader Flower a + type Pack = Word64 empty :: Pack empty = 0 packOfCards :: [Card] -> Pack -packOfCards = foldl setBit 0 . map fromEnum +packOfCards = foldl add 0 smallest :: Pack -> Card smallest = toEnum . countTrailingZeros @@ -106,10 +109,10 @@ shuffle l = let (top, bottom) = splitAt cut shuffled return $ top ++ h : bottom -pair :: Card -> Pack -> Maybe (Pack, Pack) +pair :: Card -> Pack -> Maybe (Pack, [Card]) pair card pack = let sameMonthCards = sameMonth card `intersection` pack in case size sameMonthCards of - 0 -> Just (add pack card, empty) - 1 -> Just (difference pack sameMonthCards, add sameMonthCards card) + 0 -> Just (add pack card, []) + 1 -> Just (difference pack sameMonthCards, card : cardsOfPack sameMonthCards) _ -> Nothing diff --git a/src/Hanafuda/Day.hs b/src/Hanafuda/Day.hs new file mode 100644 index 0000000..d07729c --- /dev/null +++ b/src/Hanafuda/Day.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Hanafuda.Day where + +import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, packOfCards, pair, remove) +import Hanafuda.Yaku (rate) +import Hanafuda.Game (Game(..), Move(..), PlayerState, meld, yakus) +import Data.Map (Map, adjust, empty, fromList, insert, union, (!)) +import Control.Monad.Reader (runReader) + +data Step = ToPlay | ToChoose (Maybe Card) | Scored | Over Bool + +data Day = Day { + river :: Pack + , month :: Flower + , player :: PlayerState + , next :: Card + , step :: Step + , trick :: [Card] + } + +new :: Pack -> PlayerState -> Card -> Day +new river player next = Day { + river + , month = Pine + , player + , next + , step = ToPlay + , trick = [] + } + +instance Game Day Day where + play day@(Day {river, step, next, trick}) move = + case (step, move) of + (ToPlay, Play card) -> + case pair card river of + Just (newRiver, newCaptured) -> turnOver $ day {river = newRiver, trick = newCaptured} + Nothing -> Right $ day {step = ToChoose (Just card)} + (ToChoose maybeCard, Choose caught) -> + let (continue, card) = maybe (end, next) ((,) turnOver) maybeCard in + if card `canCatch` caught + then turnOver $ + day {river = remove river caught, trick = [card, caught] ++ trick} + else Left "You can't choose that card" + (Scored, KoiKoi win) -> Right $ day {step = Over win} + (_, _) -> Left "You can't play this move in that state" + where + canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 + +turnOver :: Day -> Either String Day +turnOver day@(Day {river, next, trick}) = + case pair next river of + Just (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured} + Nothing -> Right $ day {step = ToChoose Nothing} + +end :: Day -> Either String Day +end day@(Day {month, trick, player}) = + let (scored, newMeld) = runReader (rate (meld player) trick) month in + let updatedPlayer = day {player = player {meld = newMeld, yakus = scored `union` (yakus player)}} in + Right $ if null scored + then updatedPlayer {step = Over False} + else updatedPlayer {step = Scored} diff --git a/src/Hanafuda/Game.hs b/src/Hanafuda/Game.hs new file mode 100644 index 0000000..9eeed3f --- /dev/null +++ b/src/Hanafuda/Game.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module Hanafuda.Game where + +import Data.Map (Map, empty, fromList) +import Hanafuda.Card (Card, Pack, packOfCards) +import Hanafuda.Yaku (Score, Points) + +data Player = + Player1 + | Player2 + deriving (Eq, Ord) + +next :: Player -> Player +next Player1 = Player2 +next _ = Player1 + +data PlayerState = PlayerState { + hand :: Pack + , meld :: Pack + , yakus :: Score + } +type Players = Map Player PlayerState + +initPlayers :: [Card] -> [Card] -> Players +initPlayers hand1 hand2 = + fromList [(Player1, player hand1), (Player2, player hand2)] + where + player cards = PlayerState { + hand = packOfCards cards + , meld = packOfCards [] + , yakus = empty + } + +data Move = Play Card | Choose Card | KoiKoi Bool + +type Scores = Map Player Points + +class Game a b where + play :: a -> Move -> Either String b diff --git a/src/Hanafuda/Month.hs b/src/Hanafuda/Month.hs new file mode 100644 index 0000000..53fe937 --- /dev/null +++ b/src/Hanafuda/Month.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Hanafuda.Month where + +import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards) +import Hanafuda.Day (Day(..)) +import qualified Hanafuda.Day as Day (Step(Over), next, new) +import Hanafuda.Game (Game(..), Move, Player, Players, PlayerState(..), initPlayers) +import qualified Hanafuda.Game as Game (next) +import Data.Map ((!), insert) +import Control.Monad.State (replicateM, runState, state) + +data On = On { + flower :: Flower + , players :: Players + , day :: Day + , playing :: Player + , lastScored :: Player + , oyake :: Player + , stock :: [Card] + } +data Over = Over { + winner :: Player + , score :: Int + } + +type Month = Either Over On + +new :: Player -> [Card] -> On +new playing shuffled = + On { + flower = Pine + , players + , day = Day.new (packOfCards river) (players ! playing) next + , playing + , lastScored = playing + , oyake = playing + , stock + } + where + take8 = state $ splitAt 8 + ([hand1, hand2, river], next:stock) = runState (replicateM 3 take8) shuffled + players = initPlayers hand1 hand2 + +next :: On -> IO On +next month@(On {flower, oyake}) = do + shuffled <- shuffle cards + return $ (new (Game.next oyake) cards) {flower = succ flower} + +instance Game On Month where + play month@(On {flower, day, playing, players, stock = next : moreStock}) move = + fmap after $ play day move + where + after (Day {step = Day.Over True, player = PlayerState {yakus}}) = + Left $ Over {winner = playing, score = foldl (+) 0 yakus} + after (Day {step = Day.Over False, player, river}) = + let otherPlayer = Game.next playing in + Right $ month { + players = insert playing player players + , playing = otherPlayer + , day = (Day.new river (players ! otherPlayer) next) { month = flower } + , stock = moreStock + } + after newDay = Right $ month {day = newDay} diff --git a/src/Hanafuda/Yaku.hs b/src/Hanafuda/Yaku.hs new file mode 100644 index 0000000..ecbda89 --- /dev/null +++ b/src/Hanafuda/Yaku.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Hanafuda.Yaku where + +import Hanafuda.Card (Card(..), Flower, Monthly, Pack, add, contains, intersection, packOfCards, size) +import qualified Data.Map as M (Map, empty, insert, unionWith, (!)) +import qualified Data.Set as S (Set, empty, insert, singleton, union) +import Control.Monad.Reader (reader) + +data Yaku = + Lights + | InoShikaCho + | Tane + | Akatan + | Aotan + | Tan + | Kasu + | TsukimiZake + | HanamiZake + | TsukiFuda + deriving (Eq, Ord, Show) +type YakuRater = Pack -> Maybe Points +type Points = Int +type Score = M.Map Yaku Points + +data YakuFinder = YakuFinder { + yaku :: Yaku + , rater :: YakuRater + } + +instance Eq YakuFinder where + a == b = yaku a == yaku b + +instance Ord YakuFinder where + compare a b = compare (yaku a) (yaku b) + +type YakuByCard = M.Map Card (S.Set YakuFinder) + +lights :: Pack -> YakuRater +lights _ pack = rate (size pack) (pack `contains` RainMan) + where + goko = 10 + shiko = 8 + ameshiko = 7 + sanko = 5 + rate 5 _ = Just goko + rate 4 hasRainMan = if hasRainMan then Just ameshiko else Just shiko + rate n hasRainMan = if not hasRainMan && n > 2 then Just sanko else Nothing + +fixed :: Points -> Pack -> YakuRater +fixed points indicatorSet pack = if pack == indicatorSet then Just points else Nothing + +moreThan :: Int -> (Pack -> YakuRater) +moreThan count _ pack = + let n = size pack - count in + if n > 0 then Just n else Nothing + +index :: (Yaku, [Card], (Pack -> YakuRater)) -> YakuByCard +index (yaku, cards, scorer) = + let pack = packOfCards cards in + let yakuFinder = YakuFinder {yaku, rater = scorer pack . intersection pack} in + foldl (\map card -> M.insert card (S.singleton yakuFinder) map) M.empty cards + +finders :: Monthly YakuByCard +finders = do + monthCardPlus <- reader $ (+) . (4*) . fromEnum + return $ foldl (\map -> M.unionWith S.union map . index) M.empty [ + (Lights, [Crane, CampCurtain, FullMoon, RainMan, Phoenix], lights) + , (InoShikaCho, inoshikacho, fixed 5) + , (Tane, [BushWarbler, Cuckoo, EightPlankBridge, Geese, SakeCup, Swallow] ++ inoshikacho, moreThan 4) + , (Akatan, akatan, fixed 5) + , (Aotan, aotan, fixed 5) + , (Tan, [WisteriaRed, IrisRed, BushCloverRed, WillowRed] ++ aotan ++ akatan, moreThan 4) + , (Kasu, (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..10]]) ++ Lightning : [Paulownia0 .. Sand], moreThan 9) + , (TsukimiZake, [SakeCup, FullMoon], fixed 3) + , (HanamiZake, [SakeCup, CampCurtain], fixed 3) + , (TsukiFuda, map (toEnum . monthCardPlus) [0..3], fixed 5) + ] + where + inoshikacho = [Butterflies, Boar, Deer] + aotan = [PeonyBlue, ChrysanthemumBlue, MapleBlue] + akatan = [PinePoetry, PlumPoetry, CherryPoetry] + +rate :: Pack -> [Card] -> Monthly (Score, Pack) +rate pack cards = do + yakusToCheck <- fmap toCheck finders + return (foldl scored M.empty yakusToCheck, newPack) + where + newPack = foldl add pack cards + toCheck map = foldl (\set key -> S.union set (map M.! key)) S.empty cards + scored score (YakuFinder {yaku, rater}) = foldr (M.insert yaku) score $ rater newPack diff --git a/src/Hanafuda/Year.hs b/src/Hanafuda/Year.hs new file mode 100644 index 0000000..a735eae --- /dev/null +++ b/src/Hanafuda/Year.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Hanafuda.Year where + +import Hanafuda.Card (Flower(Paulownia), cards, shuffle) +import Hanafuda.Month (flower, next, score, winner) +import qualified Hanafuda.Month as Month (On(..), Over(..), new) +import Hanafuda.Game (Game(..), Player(Player1), Scores) +import Data.Map (Map, empty, insert, (!)) +import System.Random (StdGen) + +data Mode = FirstAt Int | WholeYear + +data On = On { + mode :: Mode + , month :: Month.On + , scores :: Scores + } +data Over = Over { + finalScores :: Scores + } + +type Year = IO (Either Over On) + +new :: Mode -> Year +new mode = do + shuffled <- shuffle cards + return . Right $ On { + mode + , month = Month.new Player1 shuffled + , scores = empty + } + +consolidate :: On -> Player -> Int -> Year +consolidate year@(On {mode, month, scores}) winner score = + case mode of + FirstAt n | n <= newScore -> over + FirstAt n -> continue + WholeYear | flower month == Paulownia -> over + WholeYear -> continue + where + newScore = scores ! winner + score + newScores = insert winner newScore scores + over = return . Left $ Over {finalScores = newScores} + continue = do + nextMonth <- next month + return . Right $ year {scores = newScores, month = nextMonth} + +instance Game On Year where + play year@(On {mode, month}) move = + fmap after $ play month move + where + after (Left (Month.Over {winner, score})) = consolidate year winner score + after (Right newMonth) = return . Right $ year {month = newMonth}