Card as enum and packs with bit sets

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

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 =
+data Card =
-    Red
+      Pine0 | Pine1 | PinePoetry | Crane
-  | Blue
+    | Plum0 | Plum1 | PlumPoetry | BushWarbler
-  | Poetry
+    | 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 =
+flower :: Card -> Flower
-    BushWarbler
+flower = toEnum . (`div` 4) . fromEnum
-  | Cuckoo
-  | EightPlankBridge
-  | Butterflies
-  | Boar
-  | Geese
-  | SakeCup
-  | Deer
-  | Swallow
 
-data Light =
+type Pack = Word64
-    Crane
-  | CampCurtain
-  | FullMoon
-  | RainMan
-  | ChinesePhoenix
 
-data Value =
+empty :: Pack
-    Plain
+empty = 0
-  | Sand
-  | Lightning
-  | Ribbon Ribbon
-  | Animal Animal
-  | Light Light
 
-data Card = Card {
+packOfCards :: [Card] -> Pack
-      flower::Flower
+packOfCards = foldl setBit 0 . map fromEnum
-    , value::Value
-  } 
 
-deck :: [ Card ]
+smallest :: Pack -> Card
-deck = [
+smallest = toEnum . countTrailingZeros
-      Card Pine Plain
-    , Card Pine Plain
-    , Card Pine (Ribbon Poetry)
-    , Card Pine (Light Crane)
 
-    , Card Plum Plain
+cardsOfPack :: Pack -> [Card]
-    , Card Plum Plain
+cardsOfPack 0 = []
-    , Card Plum (Ribbon Poetry)
+cardsOfPack pack =
-    , Card Plum (Animal BushWarbler)
+  let n = countTrailingZeros pack in
+  toEnum n : cardsOfPack (clearBit pack n)
 
-    , Card Cherry Plain
+port :: (Bits a, Enum e) => (a -> Int -> b) -> a -> e -> b
-    , Card Cherry Plain
+port f bits = f bits . fromEnum
-    , Card Cherry (Ribbon Poetry)
-    , Card Cherry (Light CampCurtain)
 
-    , Card Wisteria Plain
+contains :: Pack -> Card -> Bool
-    , Card Wisteria Plain
+contains = port testBit
-    , Card Wisteria (Ribbon Red)
-    , Card Wisteria (Animal Cuckoo)
 
-    , Card Iris Plain
+add :: Pack -> Card -> Pack
-    , Card Iris Plain
+add = port setBit
-    , Card Iris (Ribbon Red)
-    , Card Iris (Animal EightPlankBridge)
 
-    , Card Peony Plain
+remove :: Pack -> Card -> Pack
-    , Card Peony Plain
+remove = port clearBit
-    , Card Peony (Ribbon Blue)
-    , Card Peony (Animal Butterflies)
 
-    , Card BushClover Plain
+union :: Pack -> Pack -> Pack
-    , Card BushClover Plain
+union = (.|.)
-    , Card BushClover (Ribbon Red)
-    , Card BushClover (Animal Boar)
 
-    , Card SusukiGrass Plain
+intersection :: Pack -> Pack -> Pack
-    , Card SusukiGrass Plain
+intersection = (.&.)
-    , Card SusukiGrass (Animal Geese)
-    , Card SusukiGrass (Light FullMoon)
 
-    , Card Chrysanthemum Plain
+difference :: Pack -> Pack -> Pack
-    , Card Chrysanthemum Plain
+difference a b = a `xor` (a .&. b)
-    , Card Chrysanthemum (Ribbon Blue)
-    , Card Chrysanthemum (Animal SakeCup)
 
-    , Card Maple Plain
+sameMonth :: Card -> Pack
-    , Card Maple Plain
+sameMonth card = 0xf `shift` (fromEnum card .&. 0xfc)
-    , Card Maple (Ribbon Blue)
-    , Card Maple (Animal Deer)
 
-    , Card Willow Lightning
+cards :: [Card]
-    , Card Willow (Ribbon Red)
+cards = [Pine0 .. Phoenix]
-    , Card Willow (Animal Swallow)
-    , Card Willow (Light RainMan)
 
-    , Card Paulownia Plain
+shuffle :: [a] -> IO [a]
-    , Card Paulownia Plain
+shuffle l =
-    , Card Paulownia Sand
+  aux (length l) l
-    , Card Paulownia (Light ChinesePhoenix)
+  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 :: Card -> Pack -> Maybe (Pack, Pack)
-pair card1 card2 = flower card1 == flower card2
+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

KoiKoi.hs

@@ -2,8 +2,8 @@
 module KoiKoi where
 
 import CCard
-import Data.Bits (popCount, (.|.), (.&.), shift, xor)
+import Data.Bits (popCount, (.|.), (.&.))
-import Data.Map (Map, empty, insert, unionWith, (!))
+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 Turn = Player1 | Player2 deriving (Eq, Ord, Show)
-data Step = PlayACard | ChooseWhichCard | Scored
+
+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 :: Flower -> Pack -> [Card] -> (Score, Pack)
-capture (Game {month}) card pack =
+capture month pack cards =
-  let newPack = add pack card in
+  let newPack = foldl add pack cards in
-  let yakuFinders = (unionWith (++) yakus . index $ tsukiFuda month) ! card in
+  let monthYakus = (unionWith (++) yakus . index $ tsukiFuda month) in
-  (newPack, foldl (\score -> foldr (uncurry insert) score . ($newPack)) empty yakuFinders)
+  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 players = fromList [
-  let p2 = Player {hand = packOfCards hand2, captured = packOfCards [], scored = empty}
+            (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"
+-}