Card as enum and packs with bit sets
This commit is contained in:
Sasha
parent
e7619af640
commit
6dbd72cf36
3 changed files with 162 additions and 175 deletions
72
CCard.hs
72
CCard.hs
|
|
@ -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
|
||||
164
Card.hs
164
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
|
||||
|
|
|
|||
101
KoiKoi.hs
101
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"
|
||||
-}
|
||||
|
|
|
|||
Loading…
Reference in a new issue