From 6dbd72cf364c4a4cb7b7e15a55fbc77f9efa8e87 Mon Sep 17 00:00:00 2001 From: Sasha Date: Mon, 5 Feb 2018 18:14:11 +0100 Subject: [PATCH] Card as enum and packs with bit sets --- CCard.hs | 72 ------------------------ Card.hs | 164 ++++++++++++++++++++++++++---------------------------- KoiKoi.hs | 101 +++++++++++++++++++++++++++------ 3 files changed, 162 insertions(+), 175 deletions(-) delete mode 100644 CCard.hs diff --git a/CCard.hs b/CCard.hs deleted file mode 100644 index 4e6cee2..0000000 --- a/CCard.hs +++ /dev/null @@ -1,72 +0,0 @@ -module CCard where - -import Data.Word (Word64) -import Data.Bits (clearBit, testBit, setBit, Bits) -import System.Random (randomRIO) - -data Flower = - Pine - | Plum - | Cherry - | Wisteria - | Iris - | Peony - | BushClover - | SusukiGrass - | Chrysanthemum - | Maple - | Willow - | Paulownia - deriving (Eq, Ord, Enum, Show) - -data Card = - Pine0 | Pine1 | PinePoetry | Crane - | Plum0 | Plum1 | PlumPoetry | BushWarbler - | Cherry0 | Cherry1 | CherryPoetry | CampCurtain - | Wisteria0 | Wisteria1 | WisteriaRed | Cuckoo - | Iris0 | Iris1 | IrisRed | EightPlankBridge - | Peony0 | Peony1 | PeonyBlue | Butterflies - | BushClover0 | BushClover1 | BushCloverRed | Boar - | SusukiGrass0 | SusukiGrass1 | Geese | FullMoon - | Chrysanthemum0 | Chrysanthemum1 | ChrysanthemumBlue | SakeCup - | Maple0 | Maple1 | MapleBlue | Deer - | Lightning | WillowRed | Swallow | RainMan - | Paulownia0 | Paulownia1 | Sand | Phoenix - deriving (Eq, Ord, Enum, Show) - -flower :: Card -> Flower -flower = toEnum . (`div` 4) . fromEnum - -type Pack = Word64 - -packOfCards :: [Card] -> Pack -packOfCards = foldl setBit 0 . map fromEnum - -port :: (Bits a, Enum e) => (a -> Int -> b) -> a -> e -> b -port f bits = f bits . fromEnum - -contains :: Pack -> Card -> Bool -contains = port testBit - -add :: Pack -> Card -> Pack -add = port setBit - -remove :: Pack -> Card -> Pack -remove = port clearBit - -pair :: Card -> Card -> Bool -pair card1 card2 = flower card1 == flower card2 - -cards :: [Card] -cards = [Pine0 .. Phoenix] - -shuffle :: [a] -> IO [a] -shuffle l = - aux (length l) l - where - aux n [] = return [] - aux n (h:t) = do - cut <- randomRIO (0, n-1) - shuffled <- shuffle t - let (top, bottom) = splitAt cut shuffled - return $ top ++ h : bottom diff --git a/Card.hs b/Card.hs index 6773f4f..a71b409 100644 --- a/Card.hs +++ b/Card.hs @@ -1,5 +1,20 @@ module Card where +import Data.Word (Word64) +import Data.Bits ( + clearBit + , popCount + , setBit + , shift + , testBit + , xor + , Bits + , (.&.) + , (.|.) + , countTrailingZeros + ) +import System.Random (randomRIO) + data Flower = Pine | Plum @@ -13,106 +28,85 @@ data Flower = | Maple | Willow | Paulownia - deriving (Eq) + deriving (Eq, Ord, Enum, Show) -data Ribbon = - Red - | Blue - | Poetry +data Card = + Pine0 | Pine1 | PinePoetry | Crane + | Plum0 | Plum1 | PlumPoetry | BushWarbler + | Cherry0 | Cherry1 | CherryPoetry | CampCurtain + | Wisteria0 | Wisteria1 | WisteriaRed | Cuckoo + | Iris0 | Iris1 | IrisRed | EightPlankBridge + | Peony0 | Peony1 | PeonyBlue | Butterflies + | BushClover0 | BushClover1 | BushCloverRed | Boar + | SusukiGrass0 | SusukiGrass1 | Geese | FullMoon + | Chrysanthemum0 | Chrysanthemum1 | ChrysanthemumBlue | SakeCup + | Maple0 | Maple1 | MapleBlue | Deer + | Lightning | WillowRed | Swallow | RainMan + | Paulownia0 | Paulownia1 | Sand | Phoenix + deriving (Eq, Ord, Enum, Show) -data Animal = - BushWarbler - | Cuckoo - | EightPlankBridge - | Butterflies - | Boar - | Geese - | SakeCup - | Deer - | Swallow +flower :: Card -> Flower +flower = toEnum . (`div` 4) . fromEnum -data Light = - Crane - | CampCurtain - | FullMoon - | RainMan - | ChinesePhoenix +type Pack = Word64 -data Value = - Plain - | Sand - | Lightning - | Ribbon Ribbon - | Animal Animal - | Light Light +empty :: Pack +empty = 0 -data Card = Card { - flower::Flower - , value::Value - } +packOfCards :: [Card] -> Pack +packOfCards = foldl setBit 0 . map fromEnum -deck :: [ Card ] -deck = [ - Card Pine Plain - , Card Pine Plain - , Card Pine (Ribbon Poetry) - , Card Pine (Light Crane) +smallest :: Pack -> Card +smallest = toEnum . countTrailingZeros - , Card Plum Plain - , Card Plum Plain - , Card Plum (Ribbon Poetry) - , Card Plum (Animal BushWarbler) +cardsOfPack :: Pack -> [Card] +cardsOfPack 0 = [] +cardsOfPack pack = + let n = countTrailingZeros pack in + toEnum n : cardsOfPack (clearBit pack n) - , Card Cherry Plain - , Card Cherry Plain - , Card Cherry (Ribbon Poetry) - , Card Cherry (Light CampCurtain) +port :: (Bits a, Enum e) => (a -> Int -> b) -> a -> e -> b +port f bits = f bits . fromEnum - , Card Wisteria Plain - , Card Wisteria Plain - , Card Wisteria (Ribbon Red) - , Card Wisteria (Animal Cuckoo) +contains :: Pack -> Card -> Bool +contains = port testBit - , Card Iris Plain - , Card Iris Plain - , Card Iris (Ribbon Red) - , Card Iris (Animal EightPlankBridge) +add :: Pack -> Card -> Pack +add = port setBit - , Card Peony Plain - , Card Peony Plain - , Card Peony (Ribbon Blue) - , Card Peony (Animal Butterflies) +remove :: Pack -> Card -> Pack +remove = port clearBit - , Card BushClover Plain - , Card BushClover Plain - , Card BushClover (Ribbon Red) - , Card BushClover (Animal Boar) +union :: Pack -> Pack -> Pack +union = (.|.) - , Card SusukiGrass Plain - , Card SusukiGrass Plain - , Card SusukiGrass (Animal Geese) - , Card SusukiGrass (Light FullMoon) +intersection :: Pack -> Pack -> Pack +intersection = (.&.) - , Card Chrysanthemum Plain - , Card Chrysanthemum Plain - , Card Chrysanthemum (Ribbon Blue) - , Card Chrysanthemum (Animal SakeCup) +difference :: Pack -> Pack -> Pack +difference a b = a `xor` (a .&. b) - , Card Maple Plain - , Card Maple Plain - , Card Maple (Ribbon Blue) - , Card Maple (Animal Deer) +sameMonth :: Card -> Pack +sameMonth card = 0xf `shift` (fromEnum card .&. 0xfc) - , Card Willow Lightning - , Card Willow (Ribbon Red) - , Card Willow (Animal Swallow) - , Card Willow (Light RainMan) +cards :: [Card] +cards = [Pine0 .. Phoenix] - , Card Paulownia Plain - , Card Paulownia Plain - , Card Paulownia Sand - , Card Paulownia (Light ChinesePhoenix) - ] +shuffle :: [a] -> IO [a] +shuffle l = + aux (length l) l + where + aux n [] = return [] + aux n (h:t) = do + cut <- randomRIO (0, n-1) + shuffled <- shuffle t + let (top, bottom) = splitAt cut shuffled + return $ top ++ h : bottom -pair :: Card -> Card -> Bool -pair card1 card2 = flower card1 == flower card2 +pair :: Card -> Pack -> Maybe (Pack, Pack) +pair card pack = + let sameMonthCards = sameMonth card `intersection` pack in + case popCount sameMonthCards of + 0 -> Just (add pack card, empty) + 1 -> Just (difference pack sameMonthCards, add sameMonthCards card) + _ -> Nothing diff --git a/KoiKoi.hs b/KoiKoi.hs index 22f9e46..d35c2c0 100644 --- a/KoiKoi.hs +++ b/KoiKoi.hs @@ -2,8 +2,8 @@ module KoiKoi where import CCard -import Data.Bits (popCount, (.|.), (.&.), shift, xor) -import Data.Map (Map, empty, insert, unionWith, (!)) +import Data.Bits (popCount, (.|.), (.&.)) +import Data.Map (Map, adjust, empty, fromList, insert, unionWith, (!)) data Yaku = Goko @@ -28,21 +28,28 @@ data Player = Player { hand :: Pack , captured :: Pack , scored :: Score - } + } deriving (Show) -data Turn = Player1 | Player2 -data Step = PlayACard | ChooseWhichCard | Scored +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 :: (Player, Player) + players :: Map Turn Player , river :: Pack , deck :: [ Card ] - , player :: Turn + , turn :: Turn , month :: Flower , step :: Step - } + } | Over { + winner :: Turn + } deriving (Show) -data Move = Take (Turn, Card, Card) | Choose (Turn, Card) | KoiKoi Bool +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 @@ -99,11 +106,12 @@ yakus = foldl (\map -> unionWith (++) map . index) empty [ , ([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) +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 @@ -114,13 +122,70 @@ 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} + let players = fromList [ + (Player1, Player {hand = packOfCards hand1, captured = packOfCards [], scored = empty}) + , (Player2, Player {hand = packOfCards hand2, captured = packOfCards [], scored = empty}) + ] return $ Game { - players = (p1, p2) + players , river = packOfCards river , deck - , player = Player1 + , 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" +-}