diff --git a/Game.hs b/Game.hs deleted file mode 100644 index b0fedfc..0000000 --- a/Game.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Game where - -import Card - -data Yaku = - Junk Int - | Ribbons Int - | SpecialRibbons Int - | Animals Int - | InoShikaCho - | Sake Int - | Lights Int - -data Taken = Taken { - junk :: [ Flower ] - , animals :: [ Animal ] - , ribbons :: [ Ribbon ] - , lights :: [ Light ] - } - -data Player = Player { - hand :: [ Card ] - , taken :: Taken - } - -score :: Yaku -> Int -score (Junk n) = 1 + n -score (Ribbons n) = 1 + n -score (SpecialRibbons 0) = 3 -score (SpecialRibbons _) = 9 -score (Animals n) = 1 + n -score InoShikaCho = 5 -score (Sake 0) = 5 -score (Sake _) = 15 -score (Lights 0) = 5 -score (Lights 1) = 8 -score (Lights 2) = 10 -score (Lights 3) = 15 diff --git a/KoiKoi.hs b/KoiKoi.hs deleted file mode 100644 index d35c2c0..0000000 --- a/KoiKoi.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# 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" --}