{-# LANGUAGE FlexibleContexts #-} {- | Module : Data.Random.Extras 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