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

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

だいぶ良くなったと思う。

改善したのは以下の箇所。

  • Maybe をモナドとして使用するようにした
  • リストに対してリスト操作関数を適切に使用するようにした
  • ジョーカーを使うとフルハウスで勝敗判定に特別な処理が必要になるケースを実装

最初に書いた実装で、なんか変だなと思う部分は、やっぱりエレガントに書き直せる。
まだ書き直せそうな部分はコメントしてある。

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

import Data.List (find, findIndices, group, sort)

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 ('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 _        = []

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 ('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

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 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 Card
              | Straight Card
              | Flush Card
              | FullHouse Rank Rank Card
              | 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]

normalize :: Card -> Card
normalize = (toEnum . fromEnum)

findMultiple :: Hand -> Int -> Maybe Rank
findMultiple ha n = find ((n ==) . length) (group (map rank ha)) >>= (return . head)

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

-- ここは書き直せそう。
-- Nothing の場合に次の処理を行う、というのが Maybe モナドの
-- 想定される使い方とは違うんじゃないかと。
ranking' :: Hand -> HandRank
ranking' ha@((Card J _):cs) = case last $ sort $ map ranking $ map (\ca -> sort $ ca:cs) (wildcard cs) of
  FullHouse ra1 ra2 _ -> FullHouse ra1 ra2 (last cs)
  other               -> other
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 (ra1, ra2, ca) -> FullHouse ra1 ra2 ca
          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, ca) -> ThreeCard ra ca
                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 $ last ha

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

maybeRoyalStraightFlush :: Hand -> Maybe Suit
maybeRoyalStraightFlush ha@((Card su Ten):_) = maybeStraightFlush ha >> Just su
maybeRoyalStraightFlush _                    = Nothing

maybeStraightFlush :: Hand -> Maybe Card
maybeStraightFlush ha = maybeFlush ha >> maybeStraight ha >>= return

maybeFourCard :: Hand -> Maybe Rank
maybeFourCard ha = findMultiple ha 4

maybeFullHouse :: Hand -> Maybe (Rank, Rank, Card)
maybeFullHouse ha = findMultiple ha 2 >> maybeThreeCard ha >>= (\(ra, ca) -> return (ra, rank ca, last ha))

maybeFlush :: Hand -> Maybe Card
maybeFlush (ca1:cs) = if all (suit ca1 ==) (map suit cs) then Just $ last cs else Nothing

maybeStraight :: Hand -> Maybe Card
maybeStraight ((Card B _):_) = Nothing
maybeStraight ha             = maybeStraight' (map (\ca -> (fromEnum ca - 2) `div` 4) ha) (last ha)
maybeStraight' :: [Int] -> Card -> Maybe Card
maybeStraight' ns ca
  | ns == [0, 1, 2, 3, 12]                = Just ca
  | all (1 ==) (zipWith (-) (tail ns) ns) = Just ca
  | otherwise                             = Nothing

maybeThreeCard :: Hand -> Maybe (Rank, Card)
maybeThreeCard ha = findMultiple ha 3 >>= (\ra -> find (\ca -> ra /= rank ca) (reverse ha) >>= (\ca -> return (ra, ca)))

-- ツーペアとワンペアは group で書き直せる。
-- group の結果、[[a, a], [b, b], [c]] のようになるのがツーペア、
-- [[a], [b], [c, c], [d]] のようになるのがワンペア、
-- つまり length が 3 ならツーペアで 4 ならワンペア、
-- ツーペアの場合は a, b, c を取り出し、ワンペアなら c, d を取り出すという感じになる。
-- この部分の修正はまた今度行おう。
maybeTwoPair :: Hand -> Maybe (Rank, Rank, Card)
maybeTwoPair (ca1@(Card _ ra1):Card _ ra2:ca3@(Card _ ra3):Card _ ra4:[ca5@(Card _ ra5)])
  | ra1 == ra2 && ra3 == ra4 = Just (ra4, ra2, ca5)
  | ra1 == ra2 && ra4 == ra5 = Just (ra5, ra2, ca3)
  | ra2 == ra3 && ra4 == ra5 = 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