module Hand
  ( Hand
  , PokerHand
  , PokerHandView (..)
  , mkPokerHand
  , view
  ) where

import Card

import Control.Arrow ( (***), (&&&) )
import Data.Bool ( bool )
import Data.List ( partition )
import Data.Monoid ( First (..) )
import Data.Ord ( Down (..) )
import GHC.Exts ( groupWith )

type Hand = [Card]

data PokerHand
  = HighCard      Hand
  | OnePair       Hand
  | TwoPair       Hand
  | ThreeOfAKind  Hand
  | Straight      Hand
  | Flush         Hand
  | FullHouse     Hand
  | FourOfAKind   Hand
  | StraightFlush Hand
  deriving ( Show, Eq, Ord )

data PokerHandView
  = HighCardView
  | OnePairView
  | TwoPairView
  | ThreeOfAKindView
  | StraightView
  | FlushView
  | FullHouseView
  | FourOfAKindView
  | StraightFlushView
  deriving ( Show, Eq, Ord )

view :: PokerHand -> PokerHandView
view (HighCard      _) = HighCardView
view (OnePair       _) = OnePairView
view (TwoPair       _) = TwoPairView
view (ThreeOfAKind  _) = ThreeOfAKindView
view (Straight      _) = StraightView
view (Flush         _) = FlushView
view (FullHouse     _) = FullHouseView
view (FourOfAKind   _) = FourOfAKindView
view (StraightFlush _) = StraightFlushView

mkPokerHand :: Hand -> Maybe PokerHand
mkPokerHand = getFirst . mconcat . fmap First . flip fmap hands . flip id
  where
  hands = [ mkStraightFlush
          , mkFourOfAKind
          , mkFullHouse
          , mkFlush
          , mkStraight
          , mkThreeOfAKind
          , mkTwoPair
          , mkOnePair
          , mkHighCard
          ]
  mkStraightFlush = mkPokerHand' StraightFlush isStraightFlush
    where
    isStraightFlush = tupleIs straightFlush . partSingle
    straightFlush = ((&&) <$> sameSuitInSequence <*> isLength 5) *** isLength 0
    sameSuitInSequence = (&&) <$> sameSuit <*> inSequence
  mkFourOfAKind = mkPokerHand' FourOfAKind isFourOfAKind
    where
    isFourOfAKind = tupleIs quadrupleSingle . partQuadruple
    quadrupleSingle = isLength 1 *** isLength 1
  mkFullHouse = mkPokerHand' FullHouse isFullHouse
    where
    isFullHouse = tupleIs triplePair . partTriple
    triplePair = isLength 1 *** isLength 1
  mkFlush = mkPokerHand' Flush isFlush
    where
    isFlush = tupleIs flushFiveSingles . partSingle
    flushFiveSingles = ((&&) <$> sameSuit <*> isLength 5) *** isLength 0
  mkStraight = mkPokerHand' Straight isStraight
    where
    isStraight = tupleIs straightFiveSingles . partSingle
    straightFiveSingles = ((&&) <$> inSequence <*> isLength 5) *** isLength 0
  mkThreeOfAKind = mkPokerHand' ThreeOfAKind isThreeOfAKind
    where
    isThreeOfAKind = tupleIs tripleTwoKickers . partTriple 
    tripleTwoKickers = isLength 1 *** isLength 2
  mkTwoPair = mkPokerHand' TwoPair isTwoPair
    where
    isTwoPair = tupleIs twoPairOneKicker . partPair
    twoPairOneKicker = isLength 2 *** isLength 1
  mkOnePair = mkPokerHand' OnePair isOnePair
    where
    isOnePair = tupleIs onePairThreeKickers . partPair
    onePairThreeKickers = isLength 1 *** isLength 3
  mkHighCard = mkPokerHand' HighCard isHighCard
    where
    isHighCard = tupleIs fiveSingles . partSingle
    fiveSingles = isLength 5 *** isLength 0
  mkPokerHand' mk is
    = uncurry (bool Nothing . Just) . (mk . concat &&& is) . groupWith (Down . rank)
  sameSuit = andBy id suit
  inSequence  = andBy (fmap succ) rank
  andBy f g = and . (zipWith (==) <*> f . tail) . fmap g . concat
  isLength 0 xs = null xs
  isLength n xs = length xs == n
  partIsLen = partition . isLength
  partSingle    = partIsLen 1
  partPair      = partIsLen 2
  partTriple    = partIsLen 3
  partQuadruple = partIsLen 4
  tupleIs = (uncurry (&&) .)
