```{-
Compute how often it happens
that a Queen and a King are adjacent in a randomly ordered card set.
-}
module Combinatorics.CardPairs (
-- * general
Card(..), CardCount(..),
charFromCard,
allPossibilities,
numberOfAllPossibilities,
possibilitiesCardsNaive,
possibilitiesCardsDynamic,
possibilitiesCardsBorderNaive,
possibilitiesCardsBorderDynamic,
possibilitiesCardsBorder2Dynamic,
-- * examples
cardSetSizeSkat, numberOfPossibilitiesSkat, probabilitySkat,
cardSetSizeRummy, numberOfPossibilitiesRummy, probabilityRummy,
cardSetSizeRummyJK, numberOfPossibilitiesRummyJK, probabilityRummyJK,
-- * tests
testCardsBorderDynamic,
exampleOutput,
allPossibilitiesSmall,
allPossibilitiesMedium,
allPossibilitiesSkat,
) where

import qualified Combinatorics as Comb

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

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)]

or .
(\x y -> (x==Queen && y==King) || (x==King && y==Queen))

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 \$
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

could be rewritten for plain lists.
-}

{- |
Count the number of card set orderings
We return a triple where the elements count with respect to an additional condition:
(card set starts with an ordinary card ' ',
-}
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) \$
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
```