{-
Compute how often it happens
that a Queen and a King are adjacent in a randomly ordered card set.
-}
module Combinatorics.CardPairs where

import qualified Combinatorics as Comb

import Data.Array (Array, (!), array, )
import Data.Ix (Ix, )
import qualified Data.List.HT as ListHT

import qualified Control.Monad.Trans.State as State
import Control.Monad (liftM, liftM2, liftM3, replicateM, )

import Data.Ratio ((%), )


type CardSet a = [(a, Int)]

data Card = Other | Queen | King
   deriving (Eq, Ord, Enum, Show)

charFromCard :: Card -> Char
charFromCard card =
   case card of
      Other -> ' '
      Queen -> 'q'
      King  -> 'k'

removeEach :: State.StateT (CardSet a) [] a
removeEach =
   State.StateT $
   map (\(pre,(x,n),post) ->
          (x, pre ++
              let m = pred n
              in (if m>0 then ((x,m):) else id)
              post)) .
   ListHT.splitEverywhere

normalizeSet :: CardSet a -> CardSet a
normalizeSet = filter ((>0) . snd)

allPossibilities :: CardSet a -> [[a]]
allPossibilities set =
   State.evalStateT
      (replicateM (sum (map snd set)) removeEach)
      (normalizeSet set)

allPossibilitiesSmall :: [[Card]]
allPossibilitiesSmall =
   allPossibilities [(Other, 4), (Queen, 2), (King, 2)]

allPossibilitiesMedium :: [[Card]]
allPossibilitiesMedium =
   allPossibilities [(Other, 4), (Queen, 4), (King, 4)]

allPossibilitiesSkat :: [[Card]]
allPossibilitiesSkat =
   allPossibilities [(Other, 24), (Queen, 4), (King, 4)]


adjacentCouple :: [Card] -> Bool
adjacentCouple =
   or .
   ListHT.mapAdjacent
      (\x y -> (x==Queen && y==King) || (x==King && y==Queen))

adjacentCouplesSmall :: [[Card]]
adjacentCouplesSmall =
   filter adjacentCouple $
   allPossibilities [(Other, 4), (Queen, 2), (King, 2)]

exampleOutput :: IO ()
exampleOutput =
   mapM_ (print . map charFromCard) allPossibilitiesSmall


{- |
Candidate for utility-ht:
-}
sample :: (a -> b) -> [a] -> [(a,b)]
sample f = map (\x -> (x, f x))


data CardCount i =
   CardCount {otherCount, queenCount, kingCount :: i}
      deriving (Eq, Ord, Ix, Show)


possibilitiesCardsNaive ::
   CardCount Int -> Integer
possibilitiesCardsNaive (CardCount no nq nk) =
   fromIntegral $ length $
   filter adjacentCouple $
   allPossibilities [(Other,no), (Queen,nq), (King,nk)]

possibilitiesCardsDynamic ::
   CardCount Int -> Array (CardCount Int) Integer
possibilitiesCardsDynamic (CardCount mo mq mk) =
   let border =
          liftM3 CardCount [0,1]   [0..mq] [0..mk] ++
          liftM3 CardCount [0..mo] [0,1]   [0..mk] ++
          liftM3 CardCount [0..mo] [0..mq] [0,1]
       p =
          array (CardCount 0 0 0, CardCount mo mq mk) $
             sample possibilitiesCardsNaive border ++
             sample
                (\(CardCount no nq nk) ->
                   -- " ******"
                   p!(CardCount (no-1) nq nk) +
                   -- "q *****"
                   p!(CardCount (no-1) (nq-1) nk) +
                   -- "k *****"
                   p!(CardCount (no-1) nq (nk-1)) +
                   -- The following case is not handled correctly,
                   -- because the second 'q' can be part of a "qk".
                   -- "qq*****"
                   p!(CardCount no (nq-2) nk) +
                   -- "kk*****"
                   p!(CardCount no nq (nk-2)) +
                   -- "kq*****"
                   -- "qk*****"
                   2 * Comb.multinomial [fromIntegral no, fromIntegral nq-1, fromIntegral nk-1])
                (liftM3 CardCount [2..mo] [2..mq] [2..mk])
   in  p


sumCard :: Num i => CardCount i -> i
sumCard (CardCount x y z) = x+y+z

{-
Candidate for utility-ht: slice

http://hackage.haskell.org/packages/archive/event-list/0.1/doc/html/Data-EventList-Relative-TimeBody.html#v:slice
could be rewritten for plain lists.
-}

{- |
Count the number of card set orderings
with adjacent queen and king.
We return a triple where the elements count with respect to an additional condition:
(card set starts with an ordinary card ' ',
 start with queen 'q',
 start with king 'k')
-}
possibilitiesCardsBorderNaive ::
   CardCount Int -> CardCount Integer
possibilitiesCardsBorderNaive (CardCount no nq nk) =
   foldl (\n (card:_) ->
      case card of
         Other -> n{otherCount = 1 + otherCount n}
         Queen -> n{queenCount = 1 + queenCount n}
         King  -> n{kingCount  = 1 + kingCount n})
      (CardCount 0 0 0) $
   filter adjacentCouple $
   allPossibilities [(Other,no), (Queen,nq), (King,nk)]

possibilitiesCardsBorderDynamic ::
   CardCount Int -> Array (CardCount Int) (CardCount Integer)
possibilitiesCardsBorderDynamic (CardCount mo mq mk) =
   let p =
          array (CardCount 0 0 0, CardCount mo mq mk) $
             liftM  (\ nq -> (CardCount 0 nq 0, CardCount 0 0 0)) [1..mq] ++
             liftM  (\ nk -> (CardCount 0 0 nk, CardCount 0 0 0)) [1..mk] ++
             liftM2 (\ nq nk -> ((CardCount 0 nq nk),
                       let s = fromIntegral $ nq+nk-1
                       in  CardCount 0
                              (Comb.binomial s (fromIntegral nk))
                              (Comb.binomial s (fromIntegral nq))))
                [1..mq] [1..mk] ++
             -- (CardCount 0 0 0) is redundant in the list,
             -- its number is not needed anyway
             liftM2 (\ no nk -> (CardCount no 0 nk, CardCount 0 0 0)) [0..mo] [0..mk] ++
             liftM2 (\ no nq -> (CardCount no nq 0, CardCount 0 0 0)) [0..mo] [0..mq] ++
             sample
                (\(CardCount no nq nk) ->
                   let allP = Comb.multinomial [fromIntegral no, fromIntegral nq-1, fromIntegral nk-1]
                   in  CardCount
                          (-- " ******"
                           sumCard (p ! CardCount (no-1) nq nk))
                          (-- "q *****"
                           otherCount (p ! CardCount no (nq-1) nk) +
                           -- "qq*****"
                           queenCount (p ! CardCount no (nq-1) nk) +
                           -- "qk*****"
                           allP)
                          (-- "k *****"
                           otherCount (p ! CardCount no nq (nk-1)) +
                           -- "kk*****"
                           kingCount  (p ! CardCount no nq (nk-1)) +
                           -- "kq*****"
                           allP))
                (liftM3 CardCount [1..mo] [1..mq] [1..mk])
   in  p

possibilitiesCardsBorder2Dynamic ::
   CardCount Int -> Array (CardCount Int) (CardCount Integer)
possibilitiesCardsBorder2Dynamic (CardCount mo mq mk) =
   let p =
          array (CardCount 0 0 0, CardCount mo mq mk) $
          flip sample (liftM3 CardCount [0..mo] [0..mq] [0..mk]) $
          \(CardCount no nq nk) ->
             let allP = Comb.multinomial [fromIntegral no, fromIntegral nq-1, fromIntegral nk-1]
                 test0 n f g =
                    if n==0
                      then 0
                      else g $ p ! f (n-1)
             in  CardCount
                    (test0 no (\io -> CardCount io nq nk) $
                       -- " ******"
                       sumCard)
                    (test0 nq (\iq -> CardCount no iq nk) $ \pc ->
                       -- "q *****"
                       otherCount pc +
                       -- "qq*****"
                       queenCount pc +
                       -- "qk*****"
                       allP)
                    (test0 nk (\ik -> CardCount no nq ik) $ \pc ->
                       -- "k *****"
                       otherCount pc +
                       -- "kk*****"
                       kingCount  pc +
                       -- "kq*****"
                       allP)
   in  p

{-
for \{o,q,k\} \subset \{1,2,\dots\}
O_{o,q,k} = O_{o-1,q,k} + Q_{o-1,q,k} + K_{o-1,q,k}
Q_{o,q,k} = O_{o,q-1,k} + Q_{o,q-1,k} + M(o,q-1,k-1)
K_{o,q,k} = O_{o,q,k-1} + K_{o,q,k-1} + M(o,q-1,k-1)

O = (O+Q+K)->(1,0,0)
Q = (O+Q)->(0,1,0) + M->(0,1,1)
K = (O+K)->(0,0,1) + M->(0,1,1)

O = (O+Q+K)·x
Q = (O+Q)·y + y·z/(1-x-y-z)
K = (O+K)·z + y·z/(1-x-y-z)

Q·(1-y) = O·y + y·z/(1-x-y-z)
K·(1-z) = O·z + y·z/(1-x-y-z)

O = (O + (O·y + y·z/(1-x-y-z))/(1-y) + (O·z + y·z/(1-x-y-z))/(1-z))·x
O·(1-x-y-z)·(1-x)
   = ((O·y·(1-x-y-z) + y·z)/(1-y) + (O·z·(1-x-y-z) + y·z)/(1-z))·x
O·(1-x-y-z)·(1-x)·(1-y)·(1-z)
   = ((O·(1-x-y-z) + z)·y·(1-z) + (O·(1-x-y-z) + y)·z·(1-y))·x
O·(1-x-y-z + (1+x)·y·z)·(1-x-y-z) = x·y·z·(2-y-z)

O+Q+K = O/x
  = y·z·(2-y-z) / (1-x-y-z + (1+x)·y·z) / (1-x-y-z)
-}


{-
Pascalsches Dreieck als Potenzreihe von 1/(1-x-y)
ausgerechnet mit Matrizen.

/n_{0,2}\   /n_{0,1}\
|n_{1,1}| = |n_{1,0}|
\n_{1,2}/   \n_{1,1}/

/n_{1,1}\   /n_{0,1}\
|n_{2,0}| = |n_{1,0}|
\n_{2,1}/   \n_{1,1}/
-}

testCardsBorderDynamic ::
   (CardCount Integer, CardCount Integer, CardCount Integer)
testCardsBorderDynamic =
   (possibilitiesCardsBorderNaive (CardCount 2 3 5),
    possibilitiesCardsBorderDynamic (CardCount 5 5 5) ! (CardCount 2 3 5),
    possibilitiesCardsBorder2Dynamic (CardCount 5 5 5) ! (CardCount 2 3 5))


numberOfAllPossibilities :: CardCount Int -> Integer
numberOfAllPossibilities (CardCount no nq nk) =
   Comb.multinomial [fromIntegral no, fromIntegral nq, fromIntegral nk]


cardSetSizeSkat :: CardCount Int
cardSetSizeSkat = CardCount 24 4 4

numberOfPossibilitiesSkat :: Integer
numberOfPossibilitiesSkat =
   sumCard $ possibilitiesCardsBorder2Dynamic cardSetSizeSkat ! cardSetSizeSkat

probabilitySkat :: Double
probabilitySkat =
   fromRational $
   numberOfPossibilitiesSkat % numberOfAllPossibilities cardSetSizeSkat


cardSetSizeRummy :: CardCount Int
cardSetSizeRummy = CardCount 44 4 4

numberOfPossibilitiesRummy :: Integer
numberOfPossibilitiesRummy =
   sumCard $ possibilitiesCardsBorder2Dynamic cardSetSizeRummy ! cardSetSizeRummy

probabilityRummy :: Double
probabilityRummy =
   fromRational $
   numberOfPossibilitiesRummy % numberOfAllPossibilities cardSetSizeRummy


{- |
Allow both Jack and King adjacent to Queen.
-}
cardSetSizeRummyJK :: CardCount Int
cardSetSizeRummyJK = CardCount 40 4 8

numberOfPossibilitiesRummyJK :: Integer
numberOfPossibilitiesRummyJK =
   sumCard $ possibilitiesCardsBorder2Dynamic cardSetSizeRummyJK ! cardSetSizeRummyJK

probabilityRummyJK :: Double
probabilityRummyJK =
   fromRational $
   numberOfPossibilitiesRummyJK % numberOfAllPossibilities cardSetSizeRummyJK