perfect-vector-shuffle 0.1.1.1 → 0.1.1.2

raw patch · 5 files changed

+224/−63 lines, 5 filesdep ~MonadRandomdep ~basedep ~primitivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: MonadRandom, base, primitive, vector

API changes (from Hackage documentation)

Files

• perfect-vector-shuffle.cabal +23/−22
• src/Immutable/Shuffle.hs +9/−9
• src/Mutable/Shuffle.hs +44/−31
• test/Mutable/Test.hs +146/−0
• test/Test.hs +2/−1

@@ -4,7 +4,7 @@  name:               perfect-vector-shuffle synopsis:           Library for performing vector shuffles-version:            0.1.1.1+version:            0.1.1.2  author:             Callan McGill maintainer:         callan.mcgill@gmail.com@@ -61,7 +61,7 @@       [4,8,5,2,7,3,9,6,10,1]     @ -extra-source-files: CHANGELOG.md+extra-doc-files: CHANGELOG.md   source-repository head@@ -77,11 +77,11 @@                     -fexpose-all-unfoldings                     -fspecialise-aggressively -  build-depends:    base        >= 4.9      && < 4.14-                  , MonadRandom >= 0.5.1.1  && < 0.6-                  , primitive   ^>= 0.7-                  , random      ^>= 1.1-                  , vector      >= 0.12.0   && < 0.13+  build-depends:    base        >= 4.9      && < 4.20+                  , MonadRandom >= 0.5.1.1  && < 0.7+                  , primitive   >= 0.6.4    && < 0.9+                  , random      >= 1.1      && < 1.3+                  , vector      >= 0.12.0   && < 0.14    exposed-modules:  Immutable.Shuffle                     Mutable.Shuffle@@ -104,17 +104,18 @@                     -fspecialise-aggressively                     -Wincomplete-patterns -  build-depends:    perfect-vector-shuffle ^>= 0.1.1.1-                  , base        >= 4.9      && < 4.14-                  , QuickCheck             ^>= 2.13.2-                  , random                 ^>= 1.1-                  , tasty                  >= 1.2    && < 1.3-                  , tasty-quickcheck       ^>= 0.10-                  , vector                 >= 0.12.0 && < 0.13-                  , quickcheck-instances   >= 0.3.19 && < 0.4+  build-depends:    perfect-vector-shuffle+                  , base                   +                  , QuickCheck             +                  , random                 +                  , tasty                  +                  , tasty-quickcheck       +                  , vector                 +                  , quickcheck-instances        other-modules:    Immutable.Test+                    Mutable.Test    default-language: Haskell2010 @@ -130,15 +131,15 @@                     -fspecialize-aggressively                     -Wincomplete-patterns -  build-depends:    perfect-vector-shuffle ^>= 0.1.1.1-                  , base        >= 4.9      && < 4.14-                  , MonadRandom >= 0.5.1.1  && < 0.6-                  , primitive   ^>= 0.7-                  , random      ^>= 1.1-                  , vector      >= 0.12.0   && < 0.13+  build-depends:    perfect-vector-shuffle+                  , base+                  , MonadRandom+                  , primitive+                  , random+                  , vector    other-modules: Immutable.Shuffle                  Mutable.Shuffle-  +    default-language: Haskell2010

@@ -9,7 +9,7 @@ import           Control.Monad.Primitive import           Control.Monad.Random    (MonadRandom (..)) import           Control.Monad.ST        (runST)-import           Data.Vector+import           Data.Vector.Generic import qualified Mutable.Shuffle         as MS import           Prelude                 hiding (length, take) import           System.Random           (RandomGen (..))@@ -19,7 +19,7 @@ -- Perform a shuffle on an immutable vector with a given random generator returning a shuffled vector and a new generator. -- -- This uses the Fisher--Yates--Knuth algorithm.-shuffle :: forall a g. RandomGen g => Vector a -> g -> (Vector a, g)+shuffle :: forall a g v. (RandomGen g, Vector v a) => v a -> g -> (v a, g) shuffle v g   | length v <= 1 = (v, g)   | otherwise     =@@ -35,7 +35,7 @@ -- Perform a shuffle on an input immutable vector in a monad which has a source of randomness. -- -- This uses the Fisher--Yates--Knuth algorithm.-shuffleM :: forall m a . (MonadRandom m, PrimMonad m) => Vector a -> m (Vector a)+shuffleM :: forall m a v . (MonadRandom m, PrimMonad m, Vector v a) => v a -> m (v a) shuffleM v   | length v <= 1 = pure v   | otherwise =@@ -49,7 +49,7 @@ -- Perform a shuffle on the first k elements of a vector in a monad which has a -- source of randomness. ---shuffleK :: forall m a . (MonadRandom m, PrimMonad m) => Int -> Vector a -> m (Vector a)+shuffleK :: forall m a v. (MonadRandom m, PrimMonad m, Vector v a) => Int -> v a -> m (v a) shuffleK k v   | length v <= 1 = pure v   | otherwise =@@ -61,7 +61,7 @@  -- | -- Get a random sample of k elements without replacement from a vector.-sampleWithoutReplacement :: forall m a . (MonadRandom m, PrimMonad m) => Int -> Vector a -> m (Vector a)+sampleWithoutReplacement :: forall m a v . (MonadRandom m, PrimMonad m, Vector v a) => Int -> v a -> m (v a) {-# INLINEABLE sampleWithoutReplacement #-} sampleWithoutReplacement k v = take k <$> shuffleK k v @@ -71,7 +71,7 @@ -- indices form a maximal cycle. -- -- This uses the Sattolo algorithm.-maximalCycle :: forall a g. RandomGen g => Vector a -> g -> (Vector a, g)+maximalCycle :: forall a g v. (RandomGen g, Vector v a) => v a -> g -> (v a, g) maximalCycle v g   | length v <= 1 = (v, g)   | otherwise     =@@ -87,7 +87,7 @@ -- indices form a maximal cycle in a monad with a source of randomness. -- -- This uses the Sattolo algorithm.-maximalCycleM :: forall m a . (MonadRandom m, PrimMonad m) => Vector a -> m (Vector a)+maximalCycleM :: forall m a v . (MonadRandom m, PrimMonad m, Vector v a) => v a -> m (v a) maximalCycleM v   | length v <= 1 = pure v   | otherwise =@@ -105,7 +105,7 @@ -- __Note:__ It is assumed the input vector consists of distinct values. -- -- This uses the "early refusal" algorithm.-derangement :: forall a g. (Eq a, RandomGen g) => Vector a -> g -> (Vector a, g)+derangement :: forall a g v . (Eq a, RandomGen g, Vector v a) => v a -> g -> (v a, g) derangement v g   | length v <= 1 = (v, g)   | otherwise     =@@ -124,7 +124,7 @@ -- __Note:__ It is assumed the input vector consists of distinct values. -- -- This uses the "early refusal" algorithm.-derangementM :: forall m a . (Eq a, MonadRandom m, PrimMonad m) => Vector a -> m (Vector a)+derangementM :: forall m a v . (Eq a, MonadRandom m, PrimMonad m, Vector v a) => v a -> m (v a) derangementM v   | length v <= 1 = pure v   | otherwise =

@@ -8,11 +8,11 @@ module Mutable.Shuffle where  import           Control.Monad.Primitive-import           Control.Monad.Random    (MonadRandom (..))-import           Data.Vector.Mutable-import           Prelude                 hiding (length, read, tail)-import           System.Random           (RandomGen)-import qualified System.Random           as SR+import           Control.Monad.Random        (MonadRandom (..))+import           Data.Vector.Generic.Mutable+import           Prelude                     hiding (length, read, tail)+import           System.Random               (RandomGen)+import qualified System.Random               as SR   -- |@@ -20,17 +20,19 @@ -- -- This uses the Fisher--Yates--Knuth algorithm shuffle-  :: forall m a g+  :: forall m a g v   . ( PrimMonad m     , RandomGen g+    , MVector v a     )-  => MVector (PrimState m) a -> g -> m g+  => v (PrimState m) a -> g -> m g {-# INLINABLE shuffle #-} shuffle mutV gen = go mutV gen (length mutV - 1)   where-    go :: MVector (PrimState m) a -> g -> Int -> m g+    go :: v (PrimState m) a -> g -> Int -> m g     {-# INLINE go #-}-    go _ g 0   =  pure g+    go _ g (- 1)  = pure g+    go _ g 0      =  pure g     go v g maxInd =       do         let (ind, newGen) :: (Int, g) = SR.randomR (0, maxInd) g@@ -44,38 +46,41 @@ -- -- This uses the Fisher--Yates--Knuth algorithm shuffleM-  :: forall m a+  :: forall m a v   . ( PrimMonad m     , MonadRandom m+    , MVector v a     )-  => MVector (PrimState m) a  -> m ()+  => v (PrimState m) a  -> m () {-# INLINABLE shuffleM #-} shuffleM mutV = go mutV (length mutV - 1)   where-    go :: MVector (PrimState m) a -> Int -> m ()+    go :: v (PrimState m) a -> Int -> m ()     {-# INLINE go #-}-    go _ 0   =  pure ()+    go _ (- 1)  = pure ()+    go _ 0      = pure ()     go v maxInd =       do         ind <-  getRandomR (0, maxInd)         swap v 0 ind         go (tail v) (maxInd - 1) -{-# SPECIALISE shuffleM :: MVector RealWorld a -> IO () #-}+-- {-# SPECIALISE shuffleM :: MVector RealWorld a -> IO () #-}  -- | -- Shuffle the first k elements of a vector. -- shuffleK-  :: forall m a+  :: forall m a v   . ( PrimMonad m     , MonadRandom m+    , MVector v a     )-  => Int -> MVector (PrimState m) a  -> m ()+  => Int -> v (PrimState m) a  -> m () {-# INLINABLE shuffleK #-} shuffleK numberOfShuffles mutV = go mutV (numberOfShuffles - 1)   where-    go :: MVector (PrimState m) a -> Int -> m ()+    go :: v (PrimState m) a -> Int -> m ()     {-# INLINE go #-}     go _ k | k < 0       = error "Cannot pass negative value to ShuffleK"@@ -95,16 +100,18 @@ -- -- This uses the Sattolo algorithm. maximalCycle-  :: forall m a g+  :: forall m a g v   . ( PrimMonad m     , RandomGen g+    , MVector v a     )-  => MVector (PrimState m) a -> g -> m g+  => v (PrimState m) a -> g -> m g {-# INLINABLE maximalCycle #-} maximalCycle mutV gen = go mutV gen (length mutV - 1)   where-    go :: MVector (PrimState m) a -> g -> Int -> m g+    go :: v (PrimState m) a -> g -> Int -> m g     {-# INLINE go #-}+    go _ g (- 1)  =  pure g     go _ g 0      =  pure g     go v g maxInd =       do@@ -119,24 +126,26 @@ -- -- This uses the Sattolo algorithm. maximalCycleM-  :: forall m a+  :: forall m a v   . ( PrimMonad m     , MonadRandom m+    , MVector v a     )-  => MVector (PrimState m) a  -> m ()+  => v (PrimState m) a  -> m () {-# INLINABLE maximalCycleM #-} maximalCycleM mutV = go mutV (length mutV - 1)   where-    go :: MVector (PrimState m) a -> Int -> m ()+    go :: v (PrimState m) a -> Int -> m ()     {-# INLINE go #-}-    go _ 0   =  pure ()+    go _ (- 1)  =  pure ()+    go _ 0      =  pure ()     go v maxInd =       do         ind <-  getRandomR (1, maxInd)         swap v 0 ind         go (tail v) (maxInd - 1) -{-# SPECIALISE maximalCycleM :: MVector RealWorld a -> IO () #-}+-- {-# SPECIALISE maximalCycleM :: MVector RealWorld a -> IO () #-}   @@ -147,19 +156,21 @@ -- -- This uses the "early refusal" algorithm. derangement-  :: forall m a g+  :: forall m a g v   . ( PrimMonad m     , RandomGen g     , Eq a+    , MVector v a     )-  => MVector (PrimState m) a -> g -> m g+  => v (PrimState m) a -> g -> m g {-# INLINABLE derangement #-} derangement mutV gen = do   mutV_copy <- clone mutV   go mutV_copy mutV gen 0 (length mutV - 1)   where-    go :: MVector (PrimState m) a -> MVector (PrimState m) a -> g -> Int -> Int -> m g+    go :: v (PrimState m) a -> v (PrimState m) a -> g -> Int -> Int -> m g     {-# INLINE go #-}+    go _ _ g _ (- 1)   = pure g     go c v g lastInd 0 =       do         v_last_old <- read c lastInd@@ -192,19 +203,21 @@ -- -- This uses the "early refusal" algorithm derangementM-  :: forall m a+  :: forall m a v   . ( PrimMonad m     , MonadRandom m     , Eq a+    , MVector v a     )-  => MVector (PrimState m) a -> m ()+  => v (PrimState m) a -> m () {-# INLINABLE derangementM #-} derangementM mutV = do   mutV_copy <- clone mutV   go mutV_copy mutV 0 (length mutV - 1)   where-    go :: MVector (PrimState m) a -> MVector (PrimState m) a -> Int -> Int -> m ()+    go :: v (PrimState m) a -> v (PrimState m) a -> Int -> Int -> m ()     {-# INLINE go #-}+    go _ _ _  (- 1)  = pure ()     go c v lastInd 0 =       do         v_last_old <- read c lastInd

@@ -0,0 +1,146 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+module Mutable.Test+  ( testSuite+  ) where++import           Data.List                        (sort)+import           Data.Vector                      (Vector, freeze, thaw, (!))+import qualified Data.Vector                      as V++import           Mutable.Shuffle+import           System.Random+import           Test.QuickCheck.Instances.Vector ()+import           Test.QuickCheck.Monadic+import           Test.Tasty+import           Test.Tasty.QuickCheck            as QC hiding (shuffle)+++testSuite :: TestTree+testSuite = testGroup ""+  [ localOption (QuickCheckTests 10000) shuffleTestSuite+  , localOption (QuickCheckTests 10000) maximalCycleTestSuite+  , localOption (QuickCheckTests 10000) derangementTestSuite+  ]++shuffleTestSuite :: TestTree+shuffleTestSuite = testGroup "shuffleM"+  [ QC.testProperty+      "shuffleM: Shuffling preserves length and elements"+       (monadicIO . isPermutationM @Int)+  , QC.testProperty+      "shuffle: Shuffling preserves length and elements"+       (monadicIO . isPermutation  @Int)+  ]+++maximalCycleTestSuite :: TestTree+maximalCycleTestSuite = testGroup "maximalCycleM"+  [ QC.testProperty+      "maximalCycleM: maximal cycle does indeed produce a maximal cycle on [0..n]"+      (monadicIO . isMaximalCycleM)+  , QC.testProperty+      "maximalCycle: maximal cycle does indeed produce a maximal cycle on [0..n]"+      (monadicIO . isMaximalCycle)+  ]+++derangementTestSuite :: TestTree+derangementTestSuite = testGroup "derangementM"+  [ QC.testProperty+      "derangementM: derangement does indeed produce a derangment on [0..n]."+      (monadicIO . isDerangementM)+  , QC.testProperty+      "derangement: derangement does indeed produce a derangment on [0..n]."+      (monadicIO . isDerangement)+  ]+++isPermutationM :: forall a . (Ord a , Show a, Arbitrary a) => Vector a -> PropertyM IO Property+isPermutationM v =+  do+    mv  <- run $ thaw v+    run $ shuffleM mv+    v'  <- run $ freeze mv+    let ls  = V.toList v+    let ls' = V.toList v'+    pure $ sort ls === sort ls'+++isPermutation+  :: forall a . (Ord a , Show a, Arbitrary a)+  => Vector a -> PropertyM IO Property+isPermutation v =+  do+    mv <- run $ thaw v+    g  <- run $ getStdGen+    _  <- run $ shuffle mv g+    v' <- run $ freeze mv+    let ls  = V.toList v+    let ls' = V.toList v'+    pure $ sort ls === sort ls'+++isMaximalCycleM :: Positive Int -> PropertyM IO Property+isMaximalCycleM (Positive n) =+  do+    let v = V.fromList [0..n]+    mv <- run $ thaw v+    run $ maximalCycleM mv+    v' <- run $ freeze mv+    pure $ cycleLength v' === (n + 1)++   where+     cycleLength :: Vector Int -> Int+     cycleLength v = go (V.head v) v++     go :: Int -> Vector Int -> Int+     go k xs = if k == 0+                       then 1+                     else+                       1 + go (xs ! k) xs++isMaximalCycle :: Positive Int -> PropertyM IO Property+isMaximalCycle (Positive n) =+  do+    let v = V.fromList [0..n]+    g  <- run getStdGen+    mv <- run $ thaw v+    _  <- run $ maximalCycle mv g+    v' <- run $ freeze mv+    pure $ cycleLength v' === (n + 1)++   where+     cycleLength :: Vector Int -> Int+     cycleLength v = go (V.head v) v++     go :: Int -> Vector Int -> Int+     go k xs = if k == 0+                       then 1+                     else+                       1 + go (xs ! k) xs+++isDerangementM :: Positive Int -> PropertyM IO Property+isDerangementM (Positive n) =+  do+    let v = V.fromList [0..n]+    mv <- run $ thaw v+    run $ derangementM mv+    v' <- run $ freeze mv+    let perm    = V.indexed v'+    let unmoved = V.filter (uncurry (==)) perm+    pure $ null unmoved === True+++isDerangement :: Positive Int -> PropertyM IO Property+isDerangement (Positive n) =+  do+    let v = V.fromList [0..n]+    g  <- run getStdGen+    mv <- run $ thaw v+    _  <- run $ derangement mv g+    v' <- run $ freeze mv+    let perm    = V.indexed v'+    let unmoved = V.filter (uncurry (==)) perm+    pure $ null unmoved === True

@@ -1,6 +1,7 @@ module Main where  import qualified Immutable.Test as Immutable+import qualified Mutable.Test   as Mutable import           Test.Tasty  @@ -11,5 +12,5 @@ testSuite :: TestTree testSuite = testGroup "Perfect Vector Sort"   [ Immutable.testSuite+  , Mutable.testSuite   ]-