91 lines
3.0 KiB
Haskell
91 lines
3.0 KiB
Haskell
{-# 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
|