http://proggitquiz.com/challenge/12/

poker.hs

import Data.Char (ord)
import Data.List (sort, group, intersperse)
import Text.ParserCombinators.Parsec

-- types

type Card = Int
type Suit = Int
type SuitCard = Int

data Hand = Hand [SuitCard]
    deriving (Show)

type Score = (Int, [Int])

niks :: Score
niks = (0, [0])

deHand :: Hand -> [Int]
deHand (Hand hs) = hs

card :: SuitCard -> Card
card h = h `mod` 13

suit :: SuitCard -> Suit
suit h = h `div` 13

cards :: Hand -> [Card]
cards (Hand hs) = sort $ map card hs

suits :: Hand -> [Suit]
suits (Hand hs) = map suit hs

-- flush

allEqual :: [Int] -> Bool
allEqual (x:xs) = and $ map (== x) xs

flush :: Hand -> Score
flush hand
    | flush'    = (6, reverse $ cards hand)
    | otherwise = niks
    where
        flush' = allEqual $ suits hand

flushTests =
    [ (Hand [0, 1, 2, 3, 4],        (6, [4, 3, 2, 1, 0]))
    , (Hand [20, 21, 22, 23, 24],   (6, [11, 10, 9, 8, 7]))
    , (Hand [0, 1, 2, 3, 13],       niks)
    , (Hand [0, 13, 26, 1, 1],      niks) ]

-- straight

isSucc :: Int -> Int -> Bool
isSucc x y = x == y-1

increasing :: [Int] -> Bool
increasing xs = and $ zipWith isSucc xs $ tail xs

straight :: [Card] -> Score
straight xs
    | straight' = (5, [maximum xs])
    | fiveHigh  = (5, [3])
    | otherwise = niks
    where
        straight' = increasing xs
        fiveHigh = xs == [0, 1, 2, 3, 12]

straightTests =
    [ (Hand [1, 2, 3, 4, 15],   niks)
    , (Hand [3, 0, 1, 2, 12],   (5, [3]))
    , (Hand [8, 9, 10, 11, 12], (5, [12]))
    , (Hand [8, 9, 10, 11, 25], (5, [12])) ]

-- straight flush

straightFlush :: Hand -> Score
straightFlush hand
    | s /= 0 && f /= 0  = (9, ss)
    | otherwise         = niks
    where
        (s, ss) = straight $ cards hand
        (f, _) = flush hand

straightFlushTests =
    [ (Hand [1, 8, 3, 15, 3],   niks)
    , (Hand [8, 9, 10, 11, 12], (9, [12]))
    , (Hand [8, 9, 10, 11, 25], niks) ]

-- four of a kind

countN :: Int -> [Card] -> [Card]
countN n = (map head) . (filter ((== n) . length)) . group

four :: [Card] -> Score
four = checkPairs 4 1 8

fourTests =
    [ (Hand [1, 8, 3, 15, 3],       niks)
    , (Hand [8, 8, 8, 11, 8],       (8, [8, 11]))
    , (Hand [12, 9, 12, 12, 25],    (8, [12, 9])) ]

-- full house

fullHouse :: [Card] -> Score
fullHouse xs
    | fullHouse'    = (7, [head three', head two'])
    | otherwise     = niks
    where
        fullHouse' = three' /= [] && two' /= []
        three' = countN 3 xs
        two' = countN 2 xs

fullHouseTests =
    [ (Hand [1, 8, 3, 15, 3],   niks)
    , (Hand [8, 8, 8, 11, 11],  (7, [8, 11]))
    , (Hand [12, 9, 12, 12, 9], (7, [12, 9])) ]

-- util functions

remove :: [Card] -> [Card] -> [Card]
remove ys = filter (\x -> not $ elem x ys)

scoreRest :: [Card] -> [Card] -> [Card]
scoreRest ys xs = ys ++ (reverse $ sort $ remove ys xs)

checkPairs :: Int -> Int -> Int -> [Card] -> Score
checkPairs n len score xs
    | length ps == len  = (score, scoreRest ps xs)
    | otherwise         = niks
    where
        ps = reverse $ sort $ countN n xs

-- three of a kind

three :: [Card] -> Score
three = checkPairs 3 1 4

threeTests =
    [ (Hand [1, 8, 3, 15, 3],   niks)
    , (Hand [8, 8, 8, 11, 12],  (4, [8, 12, 11]))
    , (Hand [12, 9, 12, 12, 0], (4, [12, 9, 0])) ]

-- two pairs

twoPairs :: [Card] -> Score
twoPairs = checkPairs 2 2 3

twoPairsTests =
    [ (Hand [1, 8, 3, 15, 3],   niks)
    , (Hand [8, 8, 11, 11, 12], (3, [11, 8, 12]))
    , (Hand [12, 9, 12, 12, 0], niks) ]

-- one pair

onePair :: [Card] -> Score
onePair = checkPairs 2 1 2

onePairTests =
    [ (Hand [1, 8, 3, 15, 7],   niks)
    , (Hand [8, 8, 5, 11, 12],  (2, [8, 12, 11, 5]))
    , (Hand [12, 9, 12, 1, 0],  (2, [12, 9, 1, 0])) ]

-- high card

highCard :: [Card] -> Score
highCard xs = (1, reverse xs)

highCardTests =
    [ (Hand [1, 8, 3, 15, 3],   (1, [8, 3, 3, 2, 1]))
    , (Hand [8, 8, 8, 11, 12],  (1, [12, 11, 8, 8, 8]))
    , (Hand [12, 9, 12, 12, 0], (1, [12, 12, 12, 9, 0])) ]

-- hand score

handScore :: Hand -> Score
handScore hand =
    maximum
        [ straightFlush hand
        , four xs
        , fullHouse xs
        , flush hand
        , straight xs
        , three xs
        , twoPairs xs
        , onePair xs
        , highCard xs ]
    where
        xs = cards hand

handScoreTests =
    [ (Hand [1, 8, 3, 15, 3],   (2, [3, 8, 2, 1]))
    , (Hand [8, 8, 8, 11, 11],  (7, [8, 11]))
    , (Hand [3, 1, 0, 25, 2],   (5, [3]))
    , (Hand [12, 9, 10, 11, 8], (9, [12])) ]

-- texas holdem

holdem :: Hand -> Hand -> [[Int]]
holdem cs ps = combinate 5 $ (deHand cs) ++ (deHand ps)

-- omaha

omaha :: Hand -> Hand -> [[Int]]
omaha cs ps = [c ++ p | c <- commCombs, p <- playerCombs]
    where
        commCombs = combinate 3 (deHand cs)
        playerCombs = combinate 2 (deHand ps)

playerHands = omaha

playerScore :: Hand -> Hand -> Score
playerScore cs ps = maximum $ (map (handScore . Hand)) $ playerHands cs ps

-- combinate

combinate :: Int -> [a] -> [[a]]
combinate _ [] = []
combinate 1 xs = [[x] | x <- xs]
combinate n (x:xs) = met ++ zonder
    where 
        met = [x:ys | ys <- combinate (n-1) xs]
        zonder = combinate n xs

-- find winners

solve :: Hand -> [Hand] -> [Int]
solve community players = [i | (x, i) <- winners]
    where
        winners = filter (\(x,i) -> x == best) $ zip scores [0..]
        best = maximum scores
        scores = map (playerScore community) players

-- parsing

readInt :: IO Int
readInt = readLn

readHand :: IO Hand
readHand = do
    s <- getLine
    return (parseHand s)

parseHand :: String -> Hand
parseHand input =
    case (parse parser "" input) of
        Right hand -> decodeHand hand
        Left _ -> error "parser error"
    where
        parser = sepBy (many alphaNum) (char ' ')

decodeHand :: [String] -> Hand
decodeHand hand = Hand (map decodeCS hand)

decodeCS :: String -> Int
decodeCS sc = (decodeCard (sc!!0)) + (decodeSuit (sc!!1)) * 12

decodeCard :: Char -> Int
decodeCard 'T' = 8
decodeCard 'J' = 9
decodeCard 'Q' = 10
decodeCard 'K' = 11
decodeCard 'A' = 12
decodeCard c = (ord c) - (ord '2')

decodeSuit :: Char -> Int
decodeSuit 'h' = 0
decodeSuit 'd' = 1
decodeSuit 's' = 2
decodeSuit 'c' = 3

readPlayer :: Int -> [Hand] -> IO [Hand]
readPlayer 0 ps = do return ps
readPlayer n ps = do
    player <- readHand
    readPlayer (n-1) $ ps ++ [player]

-- main

main :: IO ()
main = do
    --showTests
    t <- readInt
    mainLoop t

mainLoop :: Int -> IO ()
mainLoop 0 = do return ()
mainLoop t = do
    n <- readInt
    community <- readHand
    players <- readPlayer n []
    putStrLn $ formatResult $ solve community players
    mainLoop $ (t-1)

formatResult :: [Int] -> String
formatResult rs = concat $ intersperse " " $ map show rs

-- tests

showTest _ [] = do return ()
showTest f ((i, o):ts) = do
    putStrLn $ show (f i == o)
        ++ "\t" ++ show(o)
        ++ "\t" ++ show(f i)
        ++ "\t" ++ show(i)
    showTest f ts

showTests = do
    putStrLn "flush"
    showTest flush flushTests
    putStrLn "straight"
    showTest (straight . cards) straightTests
    putStrLn "straight flush"
    showTest flush flushTests
    putStrLn "four"
    showTest (four . cards) fourTests
    putStrLn "fullHouse"
    showTest (fullHouse . cards) fullHouseTests
    putStrLn "three"
    showTest (three . cards) threeTests
    putStrLn "twoPairs"
    showTest (twoPairs . cards) twoPairsTests
    putStrLn "onePair"
    showTest (onePair . cards) onePairTests
    putStrLn "highCard"
    showTest (highCard . cards) highCardTests
    putStrLn "handScore"
    showTest handScore handScoreTests