{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Poker.Classify where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Identity
import           Control.Monad.Reader
import           Data.Function          (on)
import qualified Data.List              as L
import           Data.Maybe

import           Poker.Types

-- Hand Classification

data ClassificationEnv = ClassificationEnv
        { base       :: [Card]
        , rankGroups :: [[Card]]
        , suitGroups :: [[Card]]
        } deriving (Show, Read)

type Classification a = ClassifiactionT Identity a

newtype ClassifiactionT m a = ClassifiactionT { unClassificationT :: ReaderT ClassificationEnv m a }
        deriving ( Functor, Applicative, Monad
                 , MonadReader ClassificationEnv
                 )

runClassification :: ClassificationEnv -> Classification [Maybe Hand] -> [Maybe Hand]
runClassification env = runIdentity . runClassificationT env

runClassificationT :: ClassificationEnv -> ClassifiactionT m a -> m a
runClassificationT env = flip runReaderT env . unClassificationT

class MonadClassification m where
    getBase   :: m [Card]
    getRankGroups :: m [[Card]]
    getSuitGroups :: m [[Card]]

instance (Monad m) => MonadClassification (ClassifiactionT m) where
    getBase       = liftM base ask
    getRankGroups = liftM rankGroups ask
    getSuitGroups = liftM suitGroups ask

classify :: [Classification (Maybe Hand)] -> [Card] -> Hand
classify classes cards = head $ catMaybes $ runClassification (createClassificationEnv cards) $ sequence classes

createClassificationEnv :: [Card] -> ClassificationEnv
createClassificationEnv cards = ClassificationEnv
        { base = cards'
        , rankGroups = L.groupBy ((==) `on` rank) cards'
        , suitGroups = L.groupBy ((==) `on` suit) $ L.sortBy (compare `on` suit) cards
        }
    where cards' = L.sort cards

defaultHandRules :: [ClassifiactionT Identity (Maybe Hand)]
defaultHandRules = [ straightFlush, fourOfAKind, fullHouse, flush, straight, threeOfAKind, pairs, highCard ]

highCard :: (Monad m) => ClassifiactionT m (Maybe Hand)
highCard = do
        (Card r s:_) <- getBase
        return $ Just $ HighCard (r, s)

pairs :: (Monad m) => ClassifiactionT m (Maybe Hand)
pairs = do
        p <- liftM (foldl collapse (Nothing, Nothing)) getRankGroups
        case p of
            (Just (r0, s0), Just (r1, s1)) -> return $ Just $ TwoPair (r0, s0) (r1, s1)
            (  Just (r, s),       Nothing) -> return $ Just $ OnePair (r, s)
            _                              -> return Nothing
    where collapse (Nothing, Nothing) [Card r s, _] = (Just (r, s),     Nothing)
          collapse (      a, Nothing) [Card r s, _] = (         a , Just (r, s))
          collapse                 o             _  = o

threeOfAKind :: (Monad m) => ClassifiactionT m (Maybe Hand)
threeOfAKind = liftM (foldl collapse Nothing) getRankGroups
    where collapse Nothing [Card r s, _, _] = Just $ ThreeOfAKind (r, s)
          collapse       o               _  = o

straight :: (Monad m) => ClassifiactionT m (Maybe Hand)
straight = do
        x <- liftM (foldl collapse (dc, dc, 1::Int) . L.nubBy ((==) `on` rank)) getBase
        case x of
            (Card r s, _, i) | i >= 5 -> return $ Just $ Straight (r, s)
            _                         -> return Nothing
    where dc = Card Two Clubs
          collapse (o, s, i) c | rank s == maxBound      = (c, c,     1)
                               | succ (rank s) == rank c = (o, c, i + 1)
                               | i >= 5                  = (o, c,     i)
                               | otherwise               = (c, c,     1)

flush :: (Monad m) => ClassifiactionT m (Maybe Hand)
flush = liftM (foldl collapse Nothing) getSuitGroups
    where collapse Nothing [Card r s, _, _, _, _] = Just $ Flush (r, s)
          collapse       o                     _  = o

fullHouse :: (Monad m) => ClassifiactionT m (Maybe Hand)
fullHouse = do
        three <- liftM extract threeOfAKind
        two   <- liftM extract pairs
        case (three, two) of
            (Just (r, s), Just (r', s')) -> return $ Just $ FullHouse (r, s) (r', s')
            _                            -> return Nothing
    where extract :: Maybe Hand -> Maybe Scale
          extract (Just (OnePair (r, s)))      = Just (r, s)
          extract (Just (TwoPair (r, s) _))    = Just (r, s)
          extract (Just (ThreeOfAKind (r, s))) = Just (r, s)
          extract _                            = Nothing

fourOfAKind :: (Monad m) => ClassifiactionT m (Maybe Hand)
fourOfAKind = liftM (foldl collapse Nothing) getRankGroups
    where collapse Nothing [Card r s, _, _, _] = Just $ FourOfAKind (r, s)
          collapse       o                  _  = o

straightFlush :: (Monad m) => ClassifiactionT m (Maybe Hand)
straightFlush = liftM (foldl collapse Nothing) getSuitGroups
    where collapse Nothing cs | length cs >= 5 = do mStraight <- runClassificationT (createClassificationEnv cs) straight
                                                    case mStraight of
                                                        Just (Straight (r, s)) -> Just $ StraightFlush (r, s)
                                                        _                      -> Nothing
                              | otherwise      = Nothing
          collapse o _ = o
