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

麻雀の役判定処理を Haskell で書いてみようかと思って、スモールスタートとしてポーカーの役判定処理を書いてみた。

最初はすべてのカードをデータコンストラクタとして定義する方法を検討していたんだけど、データコンストラクタが多くなりすぎてパターンマッチがしづらくなることがわかった。

カード番号を Int で持つ方法は汎用的なんだけど、番号は 1〜13 までしか存在しないという規約を型で表現できなくなってしまうのが微妙なところ。

たった 5 枚のカードの組み合わせで、ブタ合わせて 10 種類しか役がないポーカーで、こんなに長いコードになってしまうのなら、麻雀は一体どうなってしまうのだろうか・・・？

module Poker (
  Card,
  Hand,
  HandRank,
  ranking
) where

import Data.List (sort)

data Card = S Int | H Int | D Int | C Int deriving (Read, Show, Ord, Eq)
data Hand = Hand Card Card Card Card Card deriving (Show, Eq)
data HandRank = RoyalStraightFlush
              | StraightFlush
              | FourCard
              | FullHouse
              | Flush
              | Straight
              | ThreeCard
              | TwoPair
              | OnePair
              | HighCard deriving (Show, Read, Eq, Ord, Enum)

num :: Card -> Int
num (S n) = n
num (H n) = n
num (D n) = n
num (C n) = n

sort' :: Hand -> Hand
sort' (Hand c1 c2 c3 c4 c5) = Hand (h !! 0) (h !! 1) (h !! 2) (h !! 3) (h !! 4)
  where h = sort [c1, c2, c3, c4, c5]

ranking :: Hand -> HandRank
ranking = ranking' . sort'

ranking' :: Hand -> HandRank
ranking' h = case isRoyalStraightFlush h of
  True -> RoyalStraightFlush
  _ -> case isStraightFlush h of
    True -> StraightFlush
    _ -> case isFourCard h of
      True -> FourCard
      _ -> case isFullHouse h of
        True -> FullHouse
        _ -> case isFlush h of
          True -> Flush
          _ -> case isStraight h of
            True -> Straight
            _ -> case isThreeCard h of
              True -> ThreeCard
              _ -> case isTwoPair h of
                True -> TwoPair
                _ -> case isOnePair h of
                  True -> OnePair
                  _ -> HighCard

isRoyalStraightFlush :: Hand -> Bool
isRoyalStraightFlush (Hand (S 1) (S 10) (S 11) (S 12) (S 13)) = True
isRoyalStraightFlush (Hand (H 1) (H 10) (H 11) (H 12) (H 13)) = True
isRoyalStraightFlush (Hand (D 1) (D 10) (D 11) (D 12) (D 13)) = True
isRoyalStraightFlush (Hand (C 1) (C 10) (C 11) (C 12) (C 13)) = True
isRoyalStraightFlush _ = False

isStraightFlush :: Hand -> Bool
isStraightFlush h = case isFlush h of
  True -> isStraight h
  _ -> False

isFourCard :: Hand -> Bool
isFourCard (Hand c1 c2 c3 c4 c5) = case (n1 == n2, n1 == n3, n1 == n4, n1 == n5) of
  (True, True, True, _) -> True
  (True, True, _, True) -> True
  (True, _, True, True) -> True
  (_, True, True, True) -> True
  _ -> False
  where
    n1 = num c1
    n2 = num c2
    n3 = num c3
    n4 = num c4
    n5 = num c5

isFullHouse :: Hand -> Bool
isFullHouse = isFullHouse' . sort'
isFullHouse' :: Hand -> Bool
isFullHouse' (Hand c1 c2 c3 c4 c5) = isFullHouse'' $ sort [num c1, num c2, num c3, num c4, num c5]
isFullHouse'' :: [Int] -> Bool
isFullHouse'' (n1:n2:n3:n4:n5:[]) = (n1 == n2 && n1 == n3 && n4 == n5) || (n1 == n2 && n3 == n4 && n3 == n5)

isFlush :: Hand -> Bool
isFlush (Hand (S _) (S _) (S _) (S _) (S _)) = True
isFlush (Hand (H _) (H _) (H _) (H _) (H _)) = True
isFlush (Hand (D _) (D _) (D _) (D _) (D _)) = True
isFlush (Hand (C _) (C _) (C _) (C _) (C _)) = True
isFlush _ = False

isStraight :: Hand -> Bool
isStraight (Hand c1 c2 c3 c4 c5) = isStraight' (num c1) (num c2) (num c3) (num c4) (num c5)
isStraight' :: Int -> Int -> Int -> Int -> Int -> Bool
isStraight' 1 2 3 4 5 = True
isStraight' 2 3 4 5 6 = True
isStraight' 3 4 5 6 7 = True
isStraight' 4 5 6 7 8 = True
isStraight' 5 6 7 8 9 = True
isStraight' 6 7 8 9 10 = True
isStraight' 7 8 9 10 11 = True
isStraight' 8 9 10 11 12 = True
isStraight' 9 10 11 12 13 = True
isStraight' 1 10 11 12 13 = True
isStraight' _ _ _ _ _ = False

isThreeCard :: Hand -> Bool
isThreeCard (Hand c1 c2 c3 c4 c5) = case (n1 == n2, n1 == n3, n1 == n4, n1 == n5) of
  (_, _, True, True) -> True
  (_, True, _, True) -> True
  (_, True, True, _) -> True
  (True, _, _, True) -> True
  (True, _, True, _) -> True
  (True, True, _, _) -> True
  _ -> False
  where
    n1 = num c1
    n2 = num c2
    n3 = num c3
    n4 = num c4
    n5 = num c5

isTwoPair :: Hand -> Bool
isTwoPair (Hand c1 c2 c3 c4 c5) = case (n1 == n2, n1 == n3, n1 == n4, n1 == n5) of
  (True, _, _, _) -> isTwoPair' n3 n4 n5
  (_, True, _, _) -> isTwoPair' n2 n4 n5
  (_, _, True, _) -> isTwoPair' n2 n3 n5
  (_, _, _, True) -> isTwoPair' n2 n3 n4
  _ -> case (n2 == n3, n2 == n4, n2 == n5) of
    (True, _, _) -> n4 == n5
    (_, True, _) -> n3 == n5
    (_, _, True) -> n3 == n4
    _ -> False
  where
    n1 = num c1
    n2 = num c2
    n3 = num c3
    n4 = num c4
    n5 = num c5
    isTwoPair' n1 n2 n3 = case (n1 == n2, n1 == n2) of
      (True, _) -> True
      (_, True) -> True
      _ -> n2 == n3

isOnePair :: Hand -> Bool
isOnePair (Hand c1 c2 c3 c4 c5) = case (n1 == n2, n1 == n3, n1 == n4, n1 == n5) of
  (True, _, _, _) -> True
  (_, True, _, _) -> True
  (_, _, True, _) -> True
  (_, _, _, True) -> True
  _ -> case (n2 == n3, n2 == n4, n2 == n5) of
    (True, _, _) -> True
    (_, True, _) -> True
    (_, _, True) -> True
    _ -> case (n3 == n4, n3 == n5) of
      (True, _) -> True
      (_, True) -> True
      _ -> n4 == n5
  where
    n1 = num c1
    n2 = num c2
    n3 = num c3
    n4 = num c4
    n5 = num c5