Haskell でポーカーの役判定処理 #2

Haskell でポーカーの役判定処理 - satosystemsの日記 の続き。

ポーカーの役判定処理をイチから書き直した。
改善されたのは以下。

• エースが数値で最も強いルールに改善
• 絵柄による役の強さに改善
• ジョーカーがあっても判定できるように改善
• いくつかのバグを修正
• ロジックの改善

今ひとつよくわからない点は、コード内にコメントしてある。

ほとんどが Card というデータ型に関する悩み。具体的には Card は Card Suit Rank というコンストラクタと C2, C3, C4 というコンストラクタがあって、ロジックでは前者を、リテラルで書きたいときや入出力では後者を利用したいという要求から、Card データ型は Read, Show, Ord, Eq, Enum をすべて定義している。その実装が冗長なので何とかしたい。

module Poker (
  Suit(..),
  Rank(..),
  Card(..),
  Hand,
  HandRank(..),
  ranking,
) where

import Data.List (find, findIndices, sort)

-- 絵柄の弱い順に定義
-- J はジョーカーを表し、B は役判定処理でのブランクカードを表す
data Suit = J | B | C | D | H | S deriving (Show, Ord, Eq, Enum)

instance Read Suit where
  readsPrec _ s = readSuit s

readSuit :: ReadS Suit
readSuit ""       = []
readSuit ('J':cs) = [(J, cs)]
readSuit ('B':cs) = [(B, cs)]
readSuit ('C':cs) = [(C, cs)]
readSuit ('D':cs) = [(D, cs)]
readSuit ('H':cs) = [(H, cs)]
readSuit ('S':cs) = [(S, cs)]
readSuit _        = []

-- 数値の弱い順に定義
-- Zero はジョーカーとブランクカードでのみ利用される
data Rank = Zero | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King | Ace deriving (Ord, Eq, Enum)

instance Read Rank where
  readsPrec _ s = readRank s

-- この部分をエレガントに書けないものか
readRank :: ReadS Rank
readRank ""           = []
readRank ('0':cs)     = [(Zero, cs)]
readRank ('2':cs)     = [(Two, cs)]
readRank ('3':cs)     = [(Three, cs)]
readRank ('4':cs)     = [(Four, cs)]
readRank ('5':cs)     = [(Five, cs)]
readRank ('6':cs)     = [(Six, cs)]
readRank ('7':cs)     = [(Seven, cs)]
readRank ('8':cs)     = [(Eight, cs)]
readRank ('9':cs)     = [(Nine, cs)]
readRank ('1':'0':cs) = [(Ten, cs)]
readRank ('1':'1':cs) = [(Jack, cs)]
readRank ('1':'2':cs) = [(Queen, cs)]
readRank ('1':'3':cs) = [(King, cs)]
readRank ('1':cs)     = [(Ace, cs)]
readRank _            = []

-- この部分をエレガントに書けないものか
instance Show Rank where
  show Zero  = "0"
  show Two   = "2"
  show Three = "3"
  show Four  = "4"
  show Five  = "5"
  show Six   = "6"
  show Seven = "7"
  show Eight = "8"
  show Nine  = "9"
  show Ten   = "10"
  show Jack  = "11"
  show Queen = "12"
  show King  = "13"
  show Ace   = "1"

data Card = Card { suit :: Suit, rank :: Rank }
  | J0 | B0
  | C2 | D2 | H2 | S2 | C3 | D3 | H3 | S3 | C4 | D4 | H4 | S4
  | C5 | D5 | H5 | S5 | C6 | D6 | H6 | S6 | C7 | D7 | H7 | S7
  | C8 | D8 | H8 | S8 | C9 | D9 | H9 | S9 | C10 | D10 | H10 | S10
  | C11 | D11 | H11 | S11 | C12 | D12 | H12 | S12
  | C13 | D13 | H13 | S13 | C1 | D1 | H1 | S1

-- Card のコンストラクタとほとんどかぶるこのリスト定義はなんとかならないか
labels = [ "J0", "B0"
         , "C2", "D2", "H2", "S2", "C3", "D3", "H3", "S3", "C4", "D4", "H4", "S4"
         , "C5", "D5", "H5", "S5", "C6", "D6", "H6", "S6", "C7", "D7", "H7", "S7"
         , "C8", "D8", "H8", "S8", "C9", "D9", "H9", "S9", "C10", "D10", "H10", "S10"
         , "C11", "D11", "H11", "S11", "C12", "D12", "H12", "S12"
         , "C13", "D13", "H13", "S13", "C1", "D1", "H1", "S1"
         ]

-- これも何とかならないものか
instance Show Card where
  show (Card su ra) = show su ++ show ra
  show J0           = labels !! 0
  show B0           = labels !! 1
  show C2           = labels !! 2
  show D2           = labels !! 3
  show H2           = labels !! 4
  show S2           = labels !! 5
  show C3           = labels !! 6
  show D3           = labels !! 7
  show H3           = labels !! 8
  show S3           = labels !! 9
  show C4           = labels !! 10
  show D4           = labels !! 11
  show H4           = labels !! 12
  show S4           = labels !! 13
  show C5           = labels !! 14
  show D5           = labels !! 15
  show H5           = labels !! 16
  show S5           = labels !! 17
  show C6           = labels !! 18
  show D6           = labels !! 19
  show H6           = labels !! 20
  show S6           = labels !! 21
  show C7           = labels !! 22
  show D7           = labels !! 23
  show H7           = labels !! 24
  show S7           = labels !! 25
  show C8           = labels !! 26
  show D8           = labels !! 27
  show H8           = labels !! 28
  show S8           = labels !! 29
  show C9           = labels !! 30
  show D9           = labels !! 31
  show H9           = labels !! 32
  show S9           = labels !! 33
  show C10          = labels !! 34
  show D10          = labels !! 35
  show H10          = labels !! 36
  show S10          = labels !! 37
  show C11          = labels !! 38
  show D11          = labels !! 39
  show H11          = labels !! 40
  show S11          = labels !! 41
  show C12          = labels !! 42
  show D12          = labels !! 43
  show H12          = labels !! 44
  show S12          = labels !! 45
  show C13          = labels !! 46
  show D13          = labels !! 47
  show H13          = labels !! 48
  show S13          = labels !! 49
  show C1           = labels !! 50
  show D1           = labels !! 51
  show H1           = labels !! 52
  show S1           = labels !! 53

instance Read Card where
  readsPrec _ s = readCard s

readCard :: ReadS Card
readCard "" = []
readCard s = case readSuit s of
  []          -> []
  [(su, cs1)] -> case readRank cs1 of
    []          -> []
    [(ra, cs2)] -> [(Card su ra, cs2)]

instance Ord Card where
  compare ca1 ca2 = compare (fromEnum ca1) (fromEnum ca2)

instance Enum Card where
  toEnum n = read $ labels !! n
  fromEnum ca = findIndices (show ca ==) labels !! 0

instance Eq Card where
  x == y = (fromEnum x) == (fromEnum y)

-- 配列にするとロジックが書きやすい
type Hand = [Card]

-- 役の弱い順に定義
data HandRank = HighCard Card
              | OnePair Rank Card
              | TwoPair Rank Rank Card
              | ThreeCard Rank
              | Straight Card
              | Flush Card
              | FullHouse Rank
              | FourCard Rank
              | StraightFlush Card
              | RoyalStraightFlush Suit
              | FiveCard Rank deriving (Show, Read, Eq, Ord)

wildcard :: Hand -> [Card]
wildcard ha = filter (\ca -> find (ca ==) ha == Nothing) [B0 .. S1]

ranking :: Hand -> HandRank
ranking = ranking' . sort . map (toEnum . fromEnum) -- 正規化してからロジックに渡す

-- ここの case of のネストはなんとかならないものか
ranking' :: Hand -> HandRank
ranking' ha@((Card J _):cs) = last $ sort $ map ranking $ map (\ca -> sort $ ca:cs) (wildcard cs)
ranking' ha = case maybeFiveCard ha of
  Just ra -> FiveCard ra
  Nothing -> case maybeRoyalStraightFlush ha of
    Just su -> RoyalStraightFlush su
    Nothing -> case maybeStraightFlush ha of
      Just ca -> StraightFlush ca
      Nothing -> case maybeFourCard ha of
        Just ra -> FourCard ra
        Nothing -> case maybeFullHouse ha of
          Just ra -> FullHouse ra
          Nothing -> case maybeFlush ha of
            Just ca -> Flush ca
            Nothing -> case maybeStraight ha of
              Just ca -> Straight ca
              Nothing -> case maybeThreeCard ha of
                Just ra -> ThreeCard ra
                Nothing -> case maybeTwoPair ha of
                  Just (ra1, ra2, ca) -> TwoPair ra1 ra2 ca
                  Nothing             -> case maybeOnePair ha of
                    Just (ra, ca) -> OnePair ra ca
                    Nothing       -> HighCard $ ha !! 4

maybeFiveCard :: Hand -> Maybe Rank
maybeFiveCard ha@((Card B _):cs) = maybeFourCard ha
maybeFiveCard _                  = Nothing

maybeRoyalStraightFlush :: Hand -> Maybe Suit
maybeRoyalStraightFlush ha@((Card su ra):cs) = case maybeStraightFlush ha of
  Nothing -> Nothing
  Just ca -> if ra == Ten then Just su else Nothing

maybeStraightFlush :: Hand -> Maybe Card
maybeStraightFlush ha = case maybeFlush ha of
  Nothing -> Nothing
  Just ca -> case maybeStraight ha of
    Nothing -> Nothing
    Just _  -> Just ca

maybeFourCard :: Hand -> Maybe Rank
maybeFourCard ha
  | all (1 ==) $ zipWith (-) (tail ha1) ha1 = Just $ rank $ ha !! 4
  | all (1 ==) $ zipWith (-) (tail ha2) ha2 = Just $ rank $ ha !! 0
  | otherwise                               = Nothing
  where ha1 = map fromEnum $ tail ha
        ha2 = map fromEnum $ init ha

maybeFullHouse :: Hand -> Maybe Rank
maybeFullHouse (Card _ ra1:Card _ ra2:Card _ ra3:Card _ ra4:[Card _ ra5])
  | ra1 == ra2 && ra1 == ra3 && ra4 == ra5 = Just ra1
  | ra1 == ra2 && ra3 == ra4 && ra3 == ra5 = Just ra3
  | otherwise                              = Nothing
maybeFullHouse ha = error $ show ha

maybeFlush :: Hand -> Maybe Card
maybeFlush ((Card B _):_) = Nothing
maybeFlush ha             = if all (\ca -> nu1 == num ca) (tail ha) then Just (ha !! 4) else Nothing
  where num ca  = (fromEnum ca - 2) `mod` 4
        nu1 = num $ ha !! 0

maybeStraight :: Hand -> Maybe Card
maybeStraight ((Card B _):_)          = Nothing
maybeStraight (ca1:ca2:ca3:ca4:[ca5]) = if isStraight [num ca1, num ca2, num ca3, num ca4, num ca5] then Just ca5 else Nothing
  where num ca = (fromEnum ca - 2) `div` 4
isStraight :: [Int] -> Bool
isStraight ns = all (1 ==) (zipWith (-) (tail ns) ns) || ns == [0, 1, 2, 3, 12]

maybeThreeCard :: Hand -> Maybe Rank
maybeThreeCard (Card _ ra1:Card _ ra2:Card _ ra3:Card _ ra4:[Card _ ra5])
  | ra1 == ra2 && ra1 == ra3 = Just ra1
  | ra2 == ra3 && ra2 == ra4 = Just ra2
  | ra3 == ra4 && ra3 == ra5 = Just ra3
  | otherwise                = Nothing

maybeTwoPair :: Hand -> Maybe (Rank, Rank, Card)
maybeTwoPair (ca1@(Card _ ra1):Card _ ra2:ca3@(Card _ ra3):Card _ ra4:[ca5@(Card _ ra5)])
  | ra1 == ra2 && ra3 == ra4 = if ra2 > ra4 then Just (ra2, ra4, ca5) else Just (ra4, ra2, ca5)
  | ra1 == ra2 && ra4 == ra5 = if ra2 > ra5 then Just (ra2, ra5, ca3) else Just (ra5, ra2, ca3)
  | ra2 == ra3 && ra4 == ra5 = if ra3 > ra5 then Just (ra3, ra5, ca1) else Just (ra5, ra3, ca1)
  | otherwise                = Nothing

maybeOnePair :: Hand -> Maybe (Rank, Card)
maybeOnePair (Card _ ra1:Card _ ra2:ca3@(Card _ ra3):Card _ ra4:[ca5@(Card _ ra5)])
  | ra1 == ra2 = Just (ra2, ca5)
  | ra2 == ra3 = Just (ra3, ca5)
  | ra3 == ra4 = Just (ra4, ca5)
  | ra4 == ra5 = Just (ra5, ca3)
  | otherwise  = Nothing

パターンマッチがまだ結構多い。

例えばスリーカードなら、ソート済みなので [2, 2, 2, 3, 4]、[2, 3, 3, 3, 4]、[2, 3, 4, 4, 4] のような先頭か真ん中か後ろに同じ番号が固まっているパターンしかないんだけど、これを

  | ra1 == ra2 && ra1 == ra3 = Just ra1
  | ra2 == ra3 && ra2 == ra4 = Just ra2
  | ra3 == ra4 && ra3 == ra5 = Just ra3
  | otherwise                = Nothing

のように力技で判定している。リスト操作で 3 枚あるカードがそれぞれ 2 である、3 である、4 である、ということがわかるようには書けないものか。

2014/08/22 追記

Data.List の group を使うと [2, 2, 2, 3, 4]、[2, 3, 3, 3, 4]、[2, 3, 4, 4, 4] がそれぞれ [ [2, 2, 2], [3], [4] ]、[ [2], [3, 3, 3], [4] ]、[ [2], [3], [4, 4, 4] ] のような形になるので、以下のように書き換えられる。

-- 元実装
maybeFullHouse (Card _ ra1:Card _ ra2:Card _ ra3:Card _ ra4:[Card _ ra5])
  | ra1 == ra2 && ra1 == ra3 && ra4 == ra5 = Just ra1
  | ra1 == ra2 && ra3 == ra4 && ra3 == ra5 = Just ra3
  | otherwise                              = Nothing

-- case of で書きなおしたもの
-- Just の使い方が不自然だしパターンマッチが汚い
maybeFullHouse (Card _ ra1:Card _ ra2:Card _ ra3:Card _ ra4:[Card _ ra5]) =
  case Just (group [ra1, ra2, ra3, ra4, ra5]) of
    Just ((ra:_:[_]):[_]) -> Just ra
    Just (_:([ra:_:[_]])) -> Just ra
    Just _                -> Nothing

-- if then else で書きなおしたもの
-- if else のネストが美しくない
maybeFullHouse (Card _ ra1:Card _ ra2:Card _ ra3:Card _ ra4:[Card _ ra5]) =
  if length l /= 2 then Nothing
    else if length l1 == 3 then Just $ l1 !! 0
      else Just $ l2 !! 0
  where l = group [ra1, ra2, ra3, ra4, ra5]
        l1 = l !! 0
        l2 = l !! 1

書きなおした実装がどちらもあまり良くない。