ポーカーの勝敗判定

haskell入門中

■参考
http://www6.airnet.ne.jp/spade/poker/rule/yaku.html

import Data.List
import Data.Maybe
import Random

data Suit = Spade | Heart | Diamond | Club deriving (Eq, Enum, Show)
type Rank = Int
data Card = Card Rank Suit deriving Show
data Pair = Pair Rank Int deriving Show
data Role = HighCard
          | OnePair
          | TwoPair
          | ThreeOfAKind
          | Straight
          | Flush
          | FullHouse
          | FourOfAKind
          | StraightFlush
          | RoyalFlush  deriving (Eq, Ord, Show)
data Hand = Hand Role [Rank] deriving Show

run :: [Card] -> [Card] -> Ordering
run p1 p2 = deal (analysis p1) (analysis p2)

deal :: Hand -> Hand -> Ordering
deal (Hand h1 r1) (Hand h2 r2)
    | h1 /= h2  = h2 `compare` h1
    | otherwise = r2 `compare` r1

analysis :: [Card] -> Hand
analysis cs  = let rs = sortRank cs
                   s  = straight rs
                   f  = flash cs
                   ps = pair rs
                   hs = highcard rs
               in hand s f ps hs
    where
      sortRank :: [Card] -> [Rank]
      sortRank = sortRoyal . toRanks
          where
            toRanks = map $ \(Card r _) -> r
            sortRoyal rs | rs == [1, 2, 3, 4, 5] = rs
                         | otherwise             = sort $ map (\r -> if r == 1 then 14 else r) rs

      straight :: [Rank] -> Bool
      straight rs = all (== 1) $ zipWith (-) (tail rs) rs

      flash :: [Card] -> Bool
      flash = same . toSuits
          where
            toSuits = map $ \(Card _ s) -> s
            same (s:ss) = all (== s) ss

      pair :: [Rank] -> [Pair]
      pair = (map (\xs -> Pair (head xs) (length xs))) . (filter ((> 1) . length)) . group

      highcard :: [Rank] -> [Rank]
      highcard = concat . (filter ((== 1) . length)) . group

hand :: Bool -> Bool -> [Pair] -> [Rank] -> Hand
hand True  True  [                        ] rs | rs == [10, 11, 12, 13, 14] = Hand RoyalFlush []
                                               | otherwise                  = Hand StraightFlush [head rs]
hand False False [(Pair r  4)             ] rs = Hand FourOfAKind $ r:reverse rs
hand False False [(Pair r2 2), (Pair r3 3)] _  = Hand FullHouse [r3, r2]
hand False False [(Pair r3 3), (Pair r2 2)] _  = Hand FullHouse [r3, r2]
hand False True  [                        ] rs = Hand Flush [head rs]
hand True  False [                        ] rs = Hand Straight [head rs]
hand False False [(Pair r  3)             ] rs = Hand ThreeOfAKind $ r:reverse rs
hand False False [(Pair r1 2), (Pair r2 2)] rs = Hand TwoPair $ r2:r1:reverse rs
hand False False [(Pair r  2)             ] rs = Hand OnePair $ r:reverse rs
hand False False [                        ] rs = Hand HighCard $ reverse rs

ランダムに対戦させてみる。

cards = [(Card r s) | r <- [1 .. 13], s <- [Spade .. Club]]
main = do cards' <- getStdGen >>= (\g -> return $ shuffle g cards)
          mapM_ (\(p1, p2) -> poker p1 p2) $ oddEvenList $ splits 5 cards'
    where
      poker :: [Card] -> [Card] -> IO ()
      poker p1 p2 = do print $ "p1 = " ++ (show p1)
                       print $ "   = " ++ (show $ analysis p1)
                       print $ "p2 = " ++ (show p2)
                       print $ "   = " ++ (show $ analysis p2)
                       print $ msg $ run p1 p2
          where
            msg LT = "P1 Win!!"
            msg GT = "P1 Lose..."
            msg EQ = "even"

splits :: Int -> [a] -> [[a]]
splits n xs | length xs >= n = let (x, xs') = splitAt n xs
                               in x : splits n xs'
            | otherwise      = []

oddEvenList :: [a] -> [(a, a)]
oddEvenList xs = zip (oddList xs) (evenList xs)
    where
      filterList :: ([a] -> Bool) -> [a] -> [a]
      filterList p []                  = []
      filterList p (x:xs)  | p xs      = x : filterList p xs
                           | otherwise = filterList p xs

      oddList = filterList (odd . length)
      evenList = filterList (even . length)

shuffle g [] = []
shuffle g xs = x : shuffle g' rest
    where
      (n, g')   = randomR (0, length xs - 1) g
      (x, rest) = pick n xs

pick :: Int -> [a] -> (a, [a])
pick n xs = let (ys, p:zs) = splitAt n xs
            in (p, ys++zs)