poker.hs

module Main where

import Data.List
import Data.Char
import Test.Hspec

data Hand = FC | FH | TC | TP | OP
data Suit = S | H | D | C deriving (Read, Show)
data Rank = RA | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | RT | RJ | RQ | RK deriving (Show, Eq, Ord, Enum)
type Card = (Suit, Rank)

instance Show Hand where
  show FC = "4C"
  show FH = "FH"
  show TC = "3C"
  show TP = "2P"
  show OP = "1P"

showdown :: [Card] -> Maybe Hand
showdown cards
  | is4Card cards     = Just FC
  | isFullHouse cards = Just FH
  | is3Card cards     = Just TC
  | is2Pairs cards    = Just TP
  | is1Pair cards     = Just OP
  | otherwise         = Nothing

is4Card, isFullHouse, is3Card, is2Pairs, is1Pair :: [Card] -> Bool
is4Card cards     = (maximum $ map length $ groupByRank cards)  == 4
isFullHouse cards = (sort $ map length $ groupByRank cards)     == [2,3]
is3Card cards     = (maximum $ map length $ groupByRank cards)  == 3
is2Pairs cards    = (sort $ map length $ groupByRank cards)     == [1,2,2]
is1Pair cards     = (maximum $ map length $ groupByRank cards)  == 2

groupByRank :: [Card] -> [[Rank]]
groupByRank xs = group $ sort ranks where
  ranks = map snd xs

str2Cards :: String -> [Card]
str2Cards cs = str2Cards' Nothing cs where
  str2Cards' :: Maybe Suit -> String -> [Card]
  str2Cards' _ [] = []
  str2Cards' Nothing (c:cs) = str2Cards' (Just $ read [c]) cs
  str2Cards' (Just suit) cs = (suit, str2Rank $ takeWhile isRank cs) : str2Cards' Nothing (dropWhile isRank cs)

str2Rank :: String -> Rank
str2Rank cs
  | all isNumber cs = [R2, R3, R4, R5, R6, R7, R8, R9, RT] !! (read cs - 2)
  | otherwise = case cs of
    "A" -> RA
    "J" -> RJ
    "Q" -> RQ
    "K" -> RK

isRank :: Char -> Bool
isRank c
  | isNumber c = True
  | otherwise  = c `elem` "AJQK"

solve :: String -> String
solve cs = case showdown . str2Cards $ cs of
  (Just x)  -> show x
  Nothing   -> "--"

sampleCards = [(D,3),(C,3),(C,10),(D,10),(S,3)]

main = hspec spec

spec :: Spec
spec = do
    describe "Test" $ do
        it "should be 4 Cards" $
            solve "D3C3C10H3S3" `shouldBe` "4C"
        it "should be Full House" $
            solve "D3C3C10D10S3" `shouldBe` "FH"
        it "should be 3 Cards" $
            solve "D3C3C10HQS3" `shouldBe` "3C"
        it "should be 2 Pairs" $
            solve "S8D10HJS10CJ" `shouldBe` "2P"
        it "should be 1 Pair" $
            solve "D3C3C10HQS2" `shouldBe` "1P"
        it "should be Garbage" $
            solve "DAC4C10HQS2" `shouldBe` "--"