module Poker (Value(..), Suit(..), Card(..), Hand, hand) where
import Control.Exception
import Data.List

data Value  = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
            | Jack | Queen | King | Ace deriving (Eq, Ord, Bounded, Enum, Show)
data Suit   = Clubs | Diamonds | Hearts | Spades deriving (Eq, Show)
data Card   = Card {val :: Value, suit :: Suit} deriving (Eq, Show)

data HandType   = HighCard
                | OnePair
                | TwoPairs
                | ThreeOfAKind
                | Straight
                | Flush
                | FullHouse
                | FourOfAKind
                | StraightFlush
                deriving (Eq, Ord, Show)
data Hand       = Hand [Card] deriving (Eq, Show)

hand :: [Card] -> Hand
hand cards =
    assert (length cards == 5) -- A poker hand most consist of five cards
    $ assert (nub cards == cards) -- No two cards may have the same suit/val
    $ Hand $ sortBy (\x y -> val x `compare` val y) cards -- Normalize

{--
valCounts takes a Hand and returns a list of (Value, Count) pairs ordered
first by count greatest to least and then by value also greatest to least.

Example:
valCounts (hand [Card Two Clubs, Card Two Hearts, Card King Diamonds,
                 Card King Spades, Card Ace Spades])
== [(King, 2), (Two, 2), (Ace, 1)] -- The result of this expression is True
--}
valCounts :: Hand -> [(Value, Int)]
valCounts (Hand a) =
    sortBy (\x y -> snd y `compare` snd x) -- Put highest counts first
    $ nubBy sameVal -- Only keep unique vals and their counts in the list
    $ reverse -- Make nub keep only the highest count and put high vals first
    $ scanl1 (\x y -> if sameVal x y then (fst y, snd x + 1) else y) -- inc cnt
           [(val x, 1) | x <- a] -- Ignore suits, initialize counts to 1
    where sameVal x y = fst x == fst y

isAceLowStraight :: Hand -> Bool
isAceLowStraight (Hand a) = map val a == [Two, Three, Four, Five, Ace]

isStraight :: Hand -> Bool
isStraight h@(Hand a)
    | isAceLowStraight h = True
    | otherwise          =
        vals == take 5 [head vals..] -- equal to straight starting at head?
        where vals = map val a

isFlush :: Hand -> Bool
isFlush (Hand a) = (length $ nub $ map suit a) == 1 -- Super easy

handType :: Hand -> HandType
handType a
    | isStraight a && isFlush a     = StraightFlush
    | count 0 == 4                  = FourOfAKind
    | count 0 == 3 && count 1 == 2  = FullHouse
    | isFlush a                     = Flush
    | isStraight a                  = Straight
    | count 0 == 3                  = ThreeOfAKind
    | count 0 == 2 && count 1 == 2  = TwoPairs
    | count 0 == 2                  = OnePair
    | otherwise                     = HighCard
    where count = (map snd (valCounts a) !!)

instance Ord Hand where
    compare a b
        | handType a < handType b   = LT
        | handType a > handType b   = GT
        | otherwise                 =
            map fst (valCounts a') `compare` map fst (valCounts b')
            where
                fixAceLow h@(Hand x) = if isAceLowStraight h
                    then Hand $ drop 4 x ++ take 4 x -- Breaks Hand ordering
                    else h
                a' = fixAceLow a
                b' = fixAceLow b