Dovetail.hs

{-# LANGUAGE FlexibleContexts #-}

{- |
Module       : Data.Random.Dovetail
Copyright    : 2010 Aristid Breitkreuz
License      : BSD3
Stability    : experimental
Portability  : portable

Functions for splitting a deck of cards like game players.

Decks are represented by 'Seq's, because these efficiently support the required operations.

[See:] Bayer, Diaconis /Trailing the Dovetail Shuffle to its Lair/ <http://projecteuclid.org/euclid.aoap/1177005705>
-}

module Data.Random.Dovetail
(
  -- * Splitting decks
  splitDeck
, generalizedSplitDeck
  -- * Riffling decks together
, riffleDecks
, generalizedRiffleDecks
  -- ** Inverse riffling
, inverseRiffleDecks
, generalizedInverseRiffleDecks
  -- * Dovetail shuffling
, dovetail
, generalizedDovetail
  -- ** Repeated dovetail shuffling
, dovetails
, generalizedDovetails
  -- ** Inverse dovetail shuffling
, inverseDovetail
, generalizedInverseDovetail
  -- * Face up, face down shuffling
, 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)

-- | Split a deck into two /roughly equal/ halves.
splitDeck :: Seq a -> RVar (Seq a, Seq a)
splitDeck s = flip splitAt s <$> binomial (length s) (0.5 :: Double)

-- | Split a deck into /n/ /roughly equal/ parts.
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

-- | Riffle two halves of a deck into one deck.
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

-- | Riffle /n/ parts into one deck.
generalizedRiffleDecks :: [Seq a] -> RVar (Seq a)
generalizedRiffleDecks []     = return empty
generalizedRiffleDecks (x:xs) = riffleDecks x =<< generalizedRiffleDecks xs

-- | Perform an inverse riffle, i.e. letting the cards from a deck drop 
-- randomly into two heaps.
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)

-- | Perform an inverse riffle, i.e. letting the cards from a deck drop
-- randomly into /n/ heaps.
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 shuffle a deck, i.e. split the deck with splitDeck and riffle 
-- the resulting halves with 'riffleDecks'.
dovetail :: Seq a -> RVar (Seq a)
dovetail s = uncurry riffleDecks =<< splitDeck s

-- | Dovetail shuffle a deck (generalized), i.e. split the deck into /n/ parts
-- and riffle them back together.
generalizedDovetail :: Int -> Seq a -> RVar (Seq a)
generalizedDovetail n s = generalizedRiffleDecks =<< generalizedSplitDeck n s

-- | Dovetail shuffle a deck repeatedly for /n/ times.
dovetails :: Int -> Seq a -> RVar (Seq a)
dovetails n s | n > 0     = dovetail =<< dovetails (n - 1) s
              | otherwise = return s

-- | Dovetail shuffle a deck repeatedly for /shuffles/ times, 
-- using /parts/ parts.
-- 
-- /Invocation:/ @generalizedDovetails shuffles parts deck@
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

-- | Perform an inverse dovetail shuffle, i.e. letting the cards from 
-- a deck drop randomly into two heaps and then stack these heaps.
inverseDovetail :: Seq a -> RVar (Seq a)
inverseDovetail s = uncurry (><) <$> inverseRiffleDecks s

-- | Perform a generalized inverse dovetail shuffle, i.e. letting the cards
-- from a deck drop randomly into /n/ heaps and then stack them back together.
generalizedInverseDovetail :: Int -> Seq a -> RVar (Seq a)
generalizedInverseDovetail n s | null s    = return empty
                               | otherwise = foldr1 (><) <$> generalizedInverseRiffleDecks n s

-- | Perform a /face up, face down/ shuffle, which is like a dovetail shuffle
-- where the lower of the two halves is reversed.
faceUpFaceDown :: Seq a -> RVar (Seq a)
faceUpFaceDown s = uncurry (riffleDecks . reverse) =<< splitDeck s