192 lines
5.9 KiB
Haskell
192 lines
5.9 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module KoiKoi where
|
|
|
|
import CCard
|
|
import Data.Bits (popCount, (.|.), (.&.))
|
|
import Data.Map (Map, adjust, empty, fromList, 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
|
|
} deriving (Show)
|
|
|
|
data Turn = Player1 | Player2 deriving (Eq, Ord, Show)
|
|
|
|
switch :: Turn -> Turn
|
|
switch Player1 = Player2
|
|
switch _ = Player1
|
|
|
|
data Step = PlayACard | ChooseWhichCard Card | Scored deriving (Show)
|
|
|
|
data Game = Game {
|
|
players :: Map Turn Player
|
|
, river :: Pack
|
|
, deck :: [ Card ]
|
|
, turn :: Turn
|
|
, month :: Flower
|
|
, step :: Step
|
|
} | Over {
|
|
winner :: Turn
|
|
} deriving (Show)
|
|
|
|
data Move = Drop Card | Take (Card, Card) | Choose 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 :: Flower -> Pack -> [Card] -> (Score, Pack)
|
|
capture month pack cards =
|
|
let newPack = foldl add pack cards in
|
|
let monthYakus = (unionWith (++) yakus . index $ tsukiFuda month) in
|
|
let yakuFinders = foldl (\finders card -> monthYakus ! card ++ finders) [] cards in
|
|
(foldl (\score -> foldr (uncurry insert) score . ($newPack)) empty yakuFinders, newPack)
|
|
|
|
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 players = fromList [
|
|
(Player1, Player {hand = packOfCards hand1, captured = packOfCards [], scored = empty})
|
|
, (Player2, Player {hand = packOfCards hand2, captured = packOfCards [], scored = empty})
|
|
]
|
|
return $ Game {
|
|
players
|
|
, river = packOfCards river
|
|
, deck
|
|
, turn = Player1
|
|
, month = Pine
|
|
, step = PlayACard
|
|
}
|
|
|
|
makeSure :: Bool -> String -> Either String ()
|
|
makeSure check message = if check then return () else fail message
|
|
|
|
{-
|
|
playACard :: Game -> Card -> Card -> Either String Game
|
|
playACard (Game {players, river, month}) c1 c2 = do
|
|
makeSure (hand `contains` c1) "You don't have that card"
|
|
capture
|
|
-}
|
|
|
|
turnOver :: Game -> Either String Game
|
|
turnOver game@(Game { players, river, deck, turn, month, step }) =
|
|
case deck of
|
|
[] -> fail "Deck got empty"
|
|
next : cards ->
|
|
let game = game { deck = cards } in
|
|
let canTake = sameMonth next .&. river in
|
|
Right $ case popCount canTake of
|
|
0 -> game { river = add river next }
|
|
1 ->
|
|
let current@(Player { captured, scored }) = players ! turn in
|
|
let (score, newPack) = capture month captured (next:cardsOfPack canTake) in
|
|
let game = game { players = insert turn (current { captured = newPack, scored = unionWith max scored score }) players } in
|
|
if null score
|
|
then game { step = PlayACard, turn = switch turn }
|
|
else game { step = Scored }
|
|
_ -> game { step = ChooseWhichCard next }
|
|
|
|
{-
|
|
play :: Game -> Move -> Either String Game
|
|
play game@(Game { players, river, deck, turn, month, step }) = playFrom step
|
|
where
|
|
playFrom PlayACard (Drop card) = do
|
|
makeSure (month card .&. river == 0) "This card takes another one in the river"
|
|
return $ game {
|
|
player =
|
|
river = add card river
|
|
}
|
|
playFrom PlayACard (Take (card1, card2)) = do
|
|
makeSure (card1 `pair` card2) "Cards aren't from the same month"
|
|
makeSure (river `contains` card2) "That card isn't in the river"
|
|
let player = case turn of
|
|
Player1 -> fst players
|
|
_ -> snd players
|
|
playACard player c1 c2
|
|
|
|
playFrom (ChooseWhichCard card1) (Choose card2) =
|
|
makeSure (card1 `pair` card2) "Cards aren't from the same month"
|
|
makeSure (river `contains` card2) "That card isn't in the river"
|
|
|
|
playFrom Scored (KoiKoi yes) =
|
|
|
|
playFrom _ _ = fail "Invalid move"
|
|
-}
|