module Data.Random.Dovetail
(
splitDeck
, generalizedSplitDeck
, riffleDecks
, generalizedRiffleDecks
, inverseRiffleDecks
, generalizedInverseRiffleDecks
, dovetail
, generalizedDovetail
, dovetails
, generalizedDovetails
, inverseDovetail
, generalizedInverseDovetail
, faceUpFaceDown
)
where
import Control.Applicative ((<$>))
import Control.Monad
import Data.Random.RVar
import Data.Random.Distribution.Binomial
import Data.Random.Distribution.Uniform
import Data.Foldable (foldr1)
import Data.Sequence hiding (replicateM)
import Prelude hiding (null, length, splitAt, replicate, foldr1, reverse)
splitDeck :: Seq a -> RVar (Seq a, Seq a)
splitDeck s = flip splitAt s <$> binomial (length s) (0.5 :: Double)
generalizedSplitDeck :: Int -> Seq a -> RVar [Seq a]
generalizedSplitDeck n s = split s <$> replicateM (n 1) bin
where bin = binomial (length s) (1 / fromIntegral n :: Double)
split t [] = [t]
split t (p:ps) = let (l, r) = splitAt p t in
l : split r ps
riffleDecks :: Seq a -> Seq a -> RVar (Seq a)
riffleDecks a b | null a = return b
| null b = return a
| otherwise = deterministicRiffle =<< uniform 1 len
where lenA = length a
lenB = length b
len = lenA + lenB
deterministicRiffle n | n <= lenA =
let (a1 :< as) = viewl a in
(a1 <|) <$> riffleDecks as b
| otherwise =
let (b1 :< bs) = viewl b in
(b1 <|) <$> riffleDecks a bs
generalizedRiffleDecks :: [Seq a] -> RVar (Seq a)
generalizedRiffleDecks [] = return empty
generalizedRiffleDecks (x:xs) = riffleDecks x =<< generalizedRiffleDecks xs
inverseRiffleDecks :: Seq a -> RVar (Seq a, Seq a)
inverseRiffleDecks s | null s = return (empty, empty)
| otherwise = let (s1 :< ss) = viewl s in
liftM2 (unriffle s1) (inverseRiffleDecks ss) (uniform False True)
where unriffle a (l, r) left = case left of
True -> (a <| l, r)
False -> (l, a <| r)
generalizedInverseRiffleDecks :: Int -> Seq a -> RVar (Seq (Seq a))
generalizedInverseRiffleDecks n s | null s = return $ replicate n empty
| otherwise = liftM2 (unriffle s1) next (uniform 0 (n 1))
where unriffle a t i = adjust (a <|) i t
(s1 :< ss) = viewl s
next = generalizedInverseRiffleDecks n ss
dovetail :: Seq a -> RVar (Seq a)
dovetail s = uncurry riffleDecks =<< splitDeck s
generalizedDovetail :: Int -> Seq a -> RVar (Seq a)
generalizedDovetail n s = generalizedRiffleDecks =<< generalizedSplitDeck n s
dovetails :: Int -> Seq a -> RVar (Seq a)
dovetails n s | n > 0 = dovetail =<< dovetails (n 1) s
| otherwise = return s
generalizedDovetails :: Int -> Int -> Seq a -> RVar (Seq a)
generalizedDovetails shuffles parts s | shuffles > 0 = step =<< next
| otherwise = return s
where next = generalizedDovetails (shuffles 1) parts s
step = generalizedDovetail parts
inverseDovetail :: Seq a -> RVar (Seq a)
inverseDovetail s = uncurry (><) <$> inverseRiffleDecks s
generalizedInverseDovetail :: Int -> Seq a -> RVar (Seq a)
generalizedInverseDovetail n s | null s = return empty
| otherwise = foldr1 (><) <$> generalizedInverseRiffleDecks n s
faceUpFaceDown :: Seq a -> RVar (Seq a)
faceUpFaceDown s = uncurry (riffleDecks . reverse) =<< splitDeck s