127 lines
3.6 KiB
Haskell
127 lines
3.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module KoiKoi where
|
|
|
|
import CCard
|
|
import Data.Bits (popCount, (.|.), (.&.), shift, xor)
|
|
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
|
|
|
|
data Player = Player {
|
|
hand :: Pack
|
|
, captured :: Pack
|
|
, scored :: Score
|
|
}
|
|
|
|
data Turn = Player1 | Player2
|
|
data Step = PlayACard | ChooseWhichCard | Scored
|
|
|
|
data Game = Game {
|
|
players :: (Player, Player)
|
|
, river :: Pack
|
|
, deck :: [ Card ]
|
|
, player :: Turn
|
|
, month :: Flower
|
|
, step :: Step
|
|
}
|
|
|
|
data Move = Take (Turn, Card, Card) | Choose (Turn, Card) | KoiKoi Bool
|
|
|
|
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 _ =
|
|
(\n -> if n > 0 then Just (yaku, n) else Nothing) . ($count) . (-) . popCount
|
|
|
|
lights :: [Card]
|
|
lights = [Crane, CampCurtain, FullMoon, RainMan, Phoenix]
|
|
|
|
hikari :: Pack -> YakuFinder
|
|
hikari _ pack = rate (popCount 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 . (.&.) 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]
|
|
|
|
yakus :: Map Card [YakuFinder]
|
|
yakus = 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))
|
|
]
|
|
|
|
capture :: Game -> Card -> Pack -> (Pack, Score)
|
|
capture (Game {month}) card pack =
|
|
let newPack = add pack card in
|
|
let yakuFinders = (unionWith (++) yakus . index $ tsukiFuda month) ! card in
|
|
(newPack, foldl (\score -> foldr (uncurry insert) score . ($newPack)) empty yakuFinders)
|
|
|
|
foldApply :: [[a] -> ([a], [a])] -> [[a]] -> [[a]]
|
|
foldApply [] init = init
|
|
foldApply (f:fs) [x] =
|
|
let (a,b) = f x in a : foldApply fs [b]
|
|
|
|
deal :: IO Game
|
|
deal = do
|
|
shuffled <- shuffle cards
|
|
let [hand1,hand2,river,deck] = foldApply (take 3 . repeat $ splitAt 8) [shuffled]
|
|
let p1 = Player {hand = packOfCards hand1, captured = packOfCards [], scored = empty}
|
|
let p2 = Player {hand = packOfCards hand2, captured = packOfCards [], scored = empty}
|
|
return $ Game {
|
|
players = (p1, p2)
|
|
, river = packOfCards river
|
|
, deck
|
|
, player = Player1
|
|
, month = Pine
|
|
, step = PlayACard
|
|
}
|