• Bonus set solution by lzm
  • 5 years, 2 months ago
  • Download | Raw
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)) * 13

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

Scoreboard

lzm bas adv bon 200
sirpengi bas adv bon 200
sixthgear bas adv bon 190
mserrano bas adv bon 190
robbinsr bas adv bon 190
synx bas adv bon 50

What do?

  1. Write your program according to the problem description
  2. Download the basic input set. The timer will start.
  3. Feed the input file to your program and save the output.
  4. Upload the output file along with your source code. If it is correct, you will receive points. If not you may try again until the timer expires.
  5. If the timer expires. You may try again, but a new input file will be generated.
  6. Repeat fot each set.

Note: The input sets use unix line endings (\n) and the verifier expects them as well.


Come Chat!

Join channel ##proggit on freenode.

Bugs

Having issues with the the site? Let us know.