diff --git a/Data/Random/Dovetail.hs b/Data/Random/Dovetail.hs new file mode 100644 --- /dev/null +++ b/Data/Random/Dovetail.hs @@ -0,0 +1,134 @@ +{-# 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/ +-} + +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 +) +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) + +-- | 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 + +-- | Performan 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 diff --git a/Data/Random/Extras.hs b/Data/Random/Extras.hs --- a/Data/Random/Extras.hs +++ b/Data/Random/Extras.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {- | -Module : Control.Monad.Random.Extras +Module : Data.Random.Extras Copyright : 2010 Aristid Breitkreuz License : BSD3 Stability : experimental diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,6 @@ +Random-extras 0.15 +------------------ + +This package contains additional monadic functions for random values. + +It is licensed under BSD3 (see LICENSE). diff --git a/random-extras.cabal b/random-extras.cabal --- a/random-extras.cabal +++ b/random-extras.cabal @@ -1,67 +1,33 @@ --- random-extras.cabal auto-generated by cabal init. For additional --- options, see --- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. --- The name of the package. Name: random-extras --- The package version. See the Haskell package versioning policy --- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for --- standards guiding when and how versions should be incremented. -Version: 0.11 - --- A short (one-line) description of the package. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +Version: 0.15 Synopsis: Additional functions for random values. - --- A longer description of the package. Description: Additional functions for random values, based on random-fu. Inspired by random-shuffle. - --- URL for the project homepage or repository. Homepage: http://github.com/aristidb/random-extras - --- The license under which the package is released. License: BSD3 - --- The file containing the license text. License-file: LICENSE - --- The package author(s). Author: Aristid Breitkreuz - --- An email address to which users can send suggestions, bug reports, --- and patches. Maintainer: aristidb@googlemail.com - --- A copyright notice. --- Copyright: - +Copyright: (c) 2010 Aristid Breitkreuz Category: Data, Math - Build-type: Simple - --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: - --- Constraint on the version of Cabal needed to build this package. +Extra-source-files: README Cabal-version: >=1.8 - Library - -- Modules exported by the library. Exposed-modules: + Data.Random.Dovetail, Data.Random.Extras - -- Packages needed in order to build this package. Build-depends: base >=4 && <5, containers ==0.3.*, array ==0.3.*, random-fu ==0.1.* - -- Modules not exported by this package. -- Other-modules: - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: GHC-Options: -Wall