112 lines
3.4 KiB
Haskell
112 lines
3.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Hanafuda.KoiKoi.Yaku (
|
|
Score
|
|
, Yaku(..)
|
|
, meldInto
|
|
, sumYakus
|
|
) where
|
|
|
|
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 (asks)
|
|
|
|
data Yaku =
|
|
Lights
|
|
| InoShikaCho
|
|
| Tane
|
|
| Akatan
|
|
| Aotan
|
|
| Tan
|
|
| Kasu
|
|
| TsukimiZake
|
|
| HanamiZake
|
|
| TsukiFuda
|
|
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
|
|
a == b = yaku a == yaku b
|
|
|
|
instance Ord YakuFinder where
|
|
compare a b = compare (yaku a) (yaku b)
|
|
|
|
type YakusByCard = 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)) -> YakusByCard
|
|
index (yaku, cards, scorer) =
|
|
let pack = packOfCards cards 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
|
|
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)
|
|
, (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, plains, moreThan 9)
|
|
, (TsukimiZake, [SakeCup, FullMoon], fixed 3)
|
|
, (HanamiZake, [SakeCup, CampCurtain], fixed 3)
|
|
, (TsukiFuda, monthCards, fixed 5)
|
|
]
|
|
where
|
|
inoshikacho = [Butterflies, Boar, Deer]
|
|
aotan = [PeonyBlue, ChrysanthemumBlue, MapleBlue]
|
|
akatan = [PinePoetry, PlumPoetry, CherryPoetry]
|
|
plains = (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..9]]) ++ Lightning : [Paulownia0 .. Sand]
|
|
|
|
meldInto :: [Card] -> Pack -> Monthly (Score, Pack)
|
|
meldInto cards pack = do
|
|
yakusToCheck <- fmap toCheck finders
|
|
return (foldl scored M.empty yakusToCheck, newPack)
|
|
where
|
|
newPack = foldl add pack cards
|
|
toCheck yakusByCard = foldl (\set key -> S.union set (yakusByCard M.! key)) S.empty cards
|
|
scored score (YakuFinder {yaku, rater}) = foldr (M.insert yaku) score $ rater newPack
|
|
|
|
sumYakus :: Score -> Points
|
|
sumYakus s
|
|
| null s = 6
|
|
| otherwise = foldl (+) 0 s
|