module Game.Poker.Hands
( Hand
, toHand, fromHand
, PokerHand(..)
, pokerHand
, straightHint
, flushHint
, nOfKindHint
, straightFlush
, fourOfAKind
, fullHouse
, flush
, straight
, threeOfAKind
, twoPair
, onePair
, DiscardList
, Deck
, getHand
, drawHand
, getDiscardList
, judgeVictory
) where
import Game.Poker.Cards
import Data.List
import Safe
import Control.Monad
import Control.Applicative
import Data.Char
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)
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
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
cs <- nOfKindHint 3 h
nOfKindHint 2 h
return (FullHouse, last $ concat cs)
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)
type DiscardList = [Card]
type Deck = [Card]
getHand :: Deck -> Maybe (Hand, Deck)
getHand deck = do
hand <- toHand . take 5 $ deck
return (hand, drop 5 deck)
drawHand :: Deck -> DiscardList -> Hand -> Maybe (Hand, Deck)
drawHand deck dis h = let
nl = filter (flip notElem dis) (fromHand h)
nr = drop (5 length nl) deck
in (,) <$> toHand (take 5 $ nl ++ deck) <*> Just nr
getDiscardList :: Hand -> IO (Maybe DiscardList)
getDiscardList h = do
input <- getLine
return $ do
intList <- toIntList input
res <- selectByIndexes (fromHand h) intList
return res
judgeVictory :: (PokerHand, Card) -> (PokerHand, Card) -> Ordering
judgeVictory l r = compare (pullStrength l) (pullStrength r)
where
pullStrength :: (PokerHand, Card) -> (PokerHand, Int)
pullStrength = fmap cardStrength
extract :: (b -> a) -> [b] -> [(a, b)]
extract f cs = map (\c -> (f c, c)) cs
toIntList :: String -> Maybe [Int]
toIntList str = if and $ map isDigit str then Just $ reads str else Nothing
where
reads :: String -> [Int]
reads = map $ read . (:[])
selectByIndexes :: [a] -> [Int] -> Maybe [a]
selectByIndexes l = sequence . map ((atMay l).(subtract 1))