Haskell でポーカーの役判定処理 #3
Haskell でポーカーの役判定処理 #2 - satosystemsの日記 の続き。
だいぶ良くなったと思う。
改善したのは以下の箇所。
最初に書いた実装で、なんか変だなと思う部分は、やっぱりエレガントに書き直せる。
まだ書き直せそうな部分はコメントしてある。
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