2015/05/21断面

Cards.hs

module Cards 
  ( Suit(..) 
  , Card
  , allCards
  , cardSuit
  , cardNumber
  , cardStrength
  ) where

data Suit = Hearts | Diamonds | Clubs | Spades
  deriving (Show, Read, Eq, Ord, Enum)
data Card = Card Int Suit
  deriving (Eq, Ord)
instance Show Card where
  show (Card i Hearts) = "H" ++ showCardNumber i
  show (Card i Diamonds) = "D" ++ showCardNumber i
  show (Card i Clubs) = "C" ++ showCardNumber i
  show (Card i Spades) = "S" ++ showCardNumber i

showCardNumber :: Int -> String
showCardNumber 14 = "A_"
showCardNumber 13 = "K_"
showCardNumber 12 = "Q_"
showCardNumber 11 = "J_"
showCardNumber 10 = "10"
showCardNumber x = (show $ x) ++ "_"

allCards :: [Card]
allCards = [ Card num suit | suit <- [Hearts ..], num <- [2..14] ]

allCards' :: [Card]
allCards' = do
  suit <- [Hearts ..]
  num <- [2..14]
  return $ Card num suit

cardSuit :: Card -> Suit
cardSuit (Card _ s) = s

cardNumber :: Card -> Int
cardNumber (Card 14 _) = 1 -- Aは14なので
cardNumber (Card n _) = n

cardStrength :: Card -> Int
cardStrength (Card n _) = n

Hands.hs

module Hands 
  ( Hand
  , toHand, fromHand
  , PokerHand(..)
  , pokerHand 
  ----
  -- hint
  , straightHint
  , flushHint
  , nOfKindHint
  ----
  -- hand
  , straightFlush
  , fourOfAKind
  , fullHouse
  , flush
  , straight
  , threeOfAKind
  , twoPair
  , onePair 
  ) where
import Cards
import Data.List
import Control.Monad

newtype Hand = Hand { fromHand :: [Card] } deriving (Show, Eq, Ord)

toHand :: [Card] -> Maybe Hand
toHand l = 
  if length l == 5 
    then Just $ Hand (sort l)
    else Nothing

pokerHand :: Hand -> (PokerHand, Card)
pokerHand h@(Hand l) = 
    case foldl mplus Nothing $ fmap ($h) hands of
      Just pc -> pc
      Nothing -> (HighCards, last l)
  where
    hands :: [Hand -> Maybe (PokerHand, Card)]
    hands = 
      [ straightFlush
      , fourOfAKind
      , fullHouse
      , flush
      , straight
      , threeOfAKind
      , twoPair
      , onePair 
      ]

-------

-- ポーカー・ハンド
data PokerHand 
  = HighCards
  | OnePair
  | TwoPair
  | ThreeOfAKind
  | Straight
  | Flush
  | FullHouse
  | FourOfAKind
  | StraightFlush
  deriving (Show, Read, Eq, Ord, Enum)

-------
-- Hint

straightHint :: Hand -> Maybe Card
straightHint (Hand l) = 
  (judgeStright . extract cardStrength $ l)
  `mplus`
  (judgeStright . sort . extract cardNumber $ l)
    where
      isStright :: [Int] -> Bool
      isStright xs@(x:_) = xs == [x .. x + 4]
      isStright _ = False
      
      judgeStright :: [(Int, Card)] -> Maybe Card
      judgeStright l = 
        if isStright $ map fst l
          then Just . snd . last $ l
          else Nothing

flushHint :: Hand -> Maybe Card
flushHint (Hand (x:xs)) = 
  if all ((cardSuit x==).cardSuit) xs then Just (last xs) else Nothing

nOfKindHint :: Int -> Hand -> Maybe [[Card]]
nOfKindHint n (Hand h) = if cards /= [] then Just cards else Nothing
  where
    cards :: [[Card]]
    cards = filter ((==n).length) 
      $ groupBy (\x y -> cardNumber x == cardNumber y) h

-------
-- PokerHand

straightFlush :: Hand -> Maybe (PokerHand, Card)
straightFlush h = do
  c <- straightHint  h
  d <- flushHint h
  return (StraightFlush, max c d)

fourOfAKind :: Hand -> Maybe (PokerHand, Card)
fourOfAKind h = do
  cs <- nOfKindHint 4 h
  return (FourOfAKind, last $ concat cs)

fullHouse :: Hand -> Maybe (PokerHand, Card)
fullHouse h = do
  cs1 <- nOfKindHint 3 h
  cs2 <- nOfKindHint 2 h
  return (FullHouse, maximum $ concat cs1 ++ concat cs2)

flush :: Hand -> Maybe (PokerHand, Card)
flush h = do
  c <- flushHint h
  return (Flush, c)

straight :: Hand -> Maybe (PokerHand, Card)
straight h = do
  c <- straightHint h
  return (Straight, c)

threeOfAKind :: Hand -> Maybe (PokerHand, Card)
threeOfAKind h = do
  cs <- nOfKindHint 3 h
  return (ThreeOfAKind, last $ concat cs)

twoPair :: Hand -> Maybe (PokerHand, Card)
twoPair h = do
  cs <- nOfKindHint 2 h
  if length cs == 2 
    then Just (TwoPair, last $ concat cs)
    else Nothing
  
onePair :: Hand -> Maybe (PokerHand, Card)
onePair h = do
  cs <- nOfKindHint 2 h
  return (OnePair, last $ concat cs)

onePair' :: Hand -> Maybe (PokerHand, Card)
onePair' = fmap (((,) OnePair) . maximum . join) . nOfKindHint 2 

-------
-- Helper

extract :: (b -> a) -> [b] -> [(a, b)]
extract f cs = map (\c -> (f c, c)) cs