permutation 0.2.1 → 0.3

raw patch · 23 files changed

+1488/−454 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• lib/Data/Choose.hs +99/−0
• lib/Data/Choose/Base.hs +130/−0
• lib/Data/Choose/IO.hs +20/−0
• lib/Data/Choose/IOBase.hs +67/−0
• lib/Data/Choose/MChoose.hs +327/−0
• lib/Data/Choose/ST.hs +32/−0
• lib/Data/IntArray.hs +6/−0
• lib/Data/Permute.hs +10/−10
• lib/Data/Permute/Base.hs +9/−6
• lib/Data/Permute/IOBase.hs +2/−3
• lib/Data/Permute/MPermute.hs +8/−8
• lib/Data/Permute/ST.hs +1/−1
• permutation.cabal +24/−11
• tests/Choose.hs +90/−0
• tests/Driver.hs +14/−0
• tests/Main.hs +9/−4
• tests/Makefile +8/−7
• tests/Permute.hs +173/−0
• tests/Pure.hs +0/−173
• tests/ST.hs +0/−231
• tests/STChoose.hs +189/−0
• tests/STPermute.hs +231/−0
• tests/Test/Choose.hs +39/−0

@@ -0,0 +1,99 @@+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Data.Choose+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--+-- Immutable combinations.++module Data.Choose (+    -- * Combinations+    Choose,+    +    -- * Creating combinations+    choose,+    listChoose,++    -- * Accessing combination elements+    at,+    unsafeAt,++    -- * Combination properties+    possible,+    size,+    elems,+    +    -- * Combination functions+    complement,+    complElems,+    next,+    prev,+    +    ) where++import Control.Monad+import Control.Monad.ST+import Data.Choose.Base+import Data.Choose.ST++-- | @choose n k@ returns the first combination of @k@ outcomes from @n@+-- possibilites, namely the subset @{ 0, ..., k-1 }@.+choose :: Int -> Int -> Choose+choose n k = runST $+    unsafeFreeze =<< newChoose n k++-- | Construct a combination from a list of elements.  +-- @listChoose n k is@ creates a combination of @k@ outcomes from @n@+-- possibilities initialized to have the @i@th element equal to @is !! i@.  +-- For the combination to be valid, the elements must all be unique, they +-- must be in sorted order, and they all must be in the range @0 .. n-1@.+listChoose :: Int -> Int -> [Int] -> Choose+listChoose n k is = runST $+    unsafeFreeze =<< newListChoose n k is++-- | @at c i@ gets the value of the @i@th element of the combination+-- @c@.  The index @i@ must be in the range @0..(k-1)@, where @k@ is the+-- size of the combination.+at :: Choose -> Int -> Int+at c i+    | i >= 0 && i < size c =+        unsafeAt c i+    | otherwise =+        error "Invalid index"+{-# INLINE at #-}++-- | Get the inverse of a combination+complement :: Choose -> Choose+complement c = runST $ +    unsafeFreeze =<< getComplement =<< unsafeThaw c++-- | Get a list of the elements in the complement of a combination.+-- If the combination is a subset of @k@ outcomes from @n@ possibilities, then+-- the returned list will be sorted and of length @n-k@.  +complElems :: Choose -> [Int]+complElems c = runST $+    getComplElems =<< unsafeThaw c++-- | Return the next combination in lexicographic order, or @Nothing@ if+-- there are no further combinations.  Starting with the first combination+-- and repeatedly calling this function will iterate through all combinations+-- of a given order.+next :: Choose -> Maybe Choose+next = nextPrevHelp setNext++-- | Return the previous combination in lexicographic order, or @Nothing@+-- if such combination exists.+prev :: Choose -> Maybe Choose+prev = nextPrevHelp setPrev++nextPrevHelp :: (forall s. STChoose s -> ST s Bool) +             -> Choose -> Maybe Choose+nextPrevHelp set c = runST $ do+    c' <- thaw c+    set c' >>= \valid ->+        if valid+            then liftM Just $ unsafeFreeze c'+            else return Nothing

@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Data.Choose.Base+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--++module Data.Choose.Base+    where+        +import Control.Monad+import Control.Monad.ST+import Foreign++import Data.IntArray ( IntArray, STIntArray )+import qualified Data.IntArray as Arr+import qualified Data.IntArray as ArrST+++--------------------------------- Choose ---------------------------------++-- | The immutable combination data type.  A way of representing @k@+-- unordered outcomes from @n@ possiblities.  The possibilites are+-- represented as the indices @0, ..., n-1@, and the outcomes are+-- given as a subset of size @k@.  The subset is stored with the indices+-- in ascending order.+data Choose = Choose {-# UNPACK #-} !Int      -- n+                     {-# UNPACK #-} !IntArray -- the subset of size k++unsafeAt :: Choose -> Int -> Int+unsafeAt (Choose _ arr) i = Arr.unsafeAt arr i+{-# INLINE unsafeAt #-}++-- | Get the number of outcomes, @k@.+size :: Choose -> Int+size (Choose _ arr) = Arr.numElements arr+{-# INLINE size #-}++-- | Get the number of possibilities, @n@.+possible :: Choose -> Int+possible (Choose n _) = n+{-# INLINE possible #-}++-- | Get a list of the @k@ outcomes.+elems :: Choose -> [Int]+elems (Choose _ arr) = Arr.elems arr+{-# INLINE elems #-}++instance Show Choose where+    show c = "listChoose " ++ show n ++ " " ++ show k ++ " " ++ show es+      where+        n  = possible c+        k  = size c+        es = elems c+    +instance Eq Choose where+    (==) c1 c2 = (   (possible c1 == possible c2)+                 &&      (size c1 == size c2)+                 &&     (elems c1 == elems c2)+                 )+++--------------------------------- STChoose --------------------------------++-- | A mutable combination that can be manipulated in the 'ST' monad. The+-- type argument @s@ is the state variable argument for the 'ST' type.+data STChoose s = STChoose {-# UNPACK #-} !Int            -- n+                           {-# UNPACK #-} !(STIntArray s) -- the subset++getSizeSTChoose :: STChoose s -> ST s Int+getSizeSTChoose (STChoose _ marr) = ArrST.getNumElements marr+{-# INLINE getSizeSTChoose #-}++sizeSTChoose :: STChoose s -> Int+sizeSTChoose (STChoose _ marr) = ArrST.numElementsSTIntArray marr+{-# INLINE sizeSTChoose #-}++getPossibleSTChoose :: STChoose s -> ST s Int+getPossibleSTChoose (STChoose n _) = return n+{-# INLINE getPossibleSTChoose #-}++possibleSTChoose :: STChoose s -> Int+possibleSTChoose (STChoose n _) = n+{-# INLINE possibleSTChoose #-}++newSTChoose :: Int -> Int -> ST s (STChoose s)+newSTChoose n k = do+    c@(STChoose _ marr) <- newSTChoose_ n k+    ArrST.writeElems marr [0 .. k-1]+    return c+{-# INLINE newSTChoose #-}++newSTChoose_ :: Int -> Int -> ST s (STChoose s)+newSTChoose_ n k = do+    when (n < 0)          $ fail "invalid number of possibilities"+    when (k < 0 || k > n) $ fail "invalid outcome size"+    liftM (STChoose n) $ ArrST.newArray_ k+{-# INLINE newSTChoose_ #-}++unsafeGetElemSTChoose :: STChoose s -> Int -> ST s Int+unsafeGetElemSTChoose (STChoose _ marr) i = ArrST.unsafeRead marr i+{-# INLINE unsafeGetElemSTChoose #-}++unsafeSetElemSTChoose :: STChoose s -> Int -> Int -> ST s ()+unsafeSetElemSTChoose (STChoose _ marr) i x = ArrST.unsafeWrite marr i x+{-# INLINE unsafeSetElemSTChoose #-}++getElemsSTChoose :: STChoose s -> ST s [Int]+getElemsSTChoose (STChoose _ marr) = ArrST.readElems marr+{-# INLINE getElemsSTChoose #-}++setElemsSTChoose :: STChoose s -> [Int] -> ST s ()+setElemsSTChoose (STChoose _ marr) is = ArrST.writeElems marr is+{-# INLINE setElemsSTChoose #-}++unsafeFreezeSTChoose :: STChoose s -> ST s Choose+unsafeFreezeSTChoose (STChoose n marr) = +    (liftM (Choose n) . ArrST.unsafeFreeze) marr+{-# INLINE unsafeFreezeSTChoose #-}++unsafeThawSTChoose :: Choose -> ST s (STChoose s)+unsafeThawSTChoose (Choose n arr) =+    (liftM (STChoose n) . ArrST.unsafeThaw) arr+{-# INLINE unsafeThawSTChoose #-}++instance Eq (STChoose s) where+    (==) (STChoose _ marr1) (STChoose _ marr2) = +         ArrST.sameSTIntArray marr1 marr2

@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Data.Choose.IO+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--+-- Mutable combinations in the 'IO' monad.++module Data.Choose.IO (+    -- * Combinations+    IOChoose,+    +    -- * Overloaded mutable combination interface+    module Data.Choose.MChoose+    ) where++import Data.Choose.IOBase( IOChoose )+import Data.Choose.MChoose

@@ -0,0 +1,67 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Data.Choose.IOBase+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--++module Data.Choose.IOBase+    where++import Control.Monad+import Control.Monad.ST+import Data.Choose.Base++-- | A mutable combination that can be manipulated in the 'IO' monad.+newtype IOChoose = IOChoose (STChoose RealWorld) deriving Eq++newIOChoose :: Int -> Int -> IO (IOChoose)+newIOChoose n k = liftM IOChoose $ stToIO (newSTChoose n k)+{-# INLINE newIOChoose #-}++newIOChoose_ :: Int -> Int -> IO (IOChoose)+newIOChoose_ n k = liftM IOChoose $ stToIO (newSTChoose_ n k)+{-# INLINE newIOChoose_ #-}++getPossibleIOChoose :: IOChoose -> IO Int+getPossibleIOChoose (IOChoose c) = stToIO $ getPossibleSTChoose c+{-# INLINE getPossibleIOChoose #-}++possibleIOChoose :: IOChoose -> Int+possibleIOChoose (IOChoose c) = possibleSTChoose c+{-# INLINE possibleIOChoose #-}++getSizeIOChoose :: IOChoose -> IO Int+getSizeIOChoose (IOChoose c) = stToIO $ getSizeSTChoose c+{-# INLINE getSizeIOChoose #-}++sizeIOChoose :: IOChoose -> Int+sizeIOChoose (IOChoose c) = sizeSTChoose c+{-# INLINE sizeIOChoose #-}+        +unsafeGetElemIOChoose :: IOChoose -> Int -> IO Int+unsafeGetElemIOChoose (IOChoose c) i = stToIO $ unsafeGetElemSTChoose c i+{-# INLINE unsafeGetElemIOChoose #-}++unsafeSetElemIOChoose :: IOChoose -> Int -> Int -> IO ()+unsafeSetElemIOChoose (IOChoose c) i x = stToIO $ unsafeSetElemSTChoose c i x+{-# INLINE unsafeSetElemIOChoose #-}++getElemsIOChoose :: IOChoose -> IO [Int]+getElemsIOChoose (IOChoose c) = stToIO $ getElemsSTChoose c+{-# INLINE getElemsIOChoose #-}++setElemsIOChoose :: IOChoose -> [Int] -> IO ()+setElemsIOChoose (IOChoose c) is = stToIO $ setElemsSTChoose c is+{-# INLINE setElemsIOChoose #-}++unsafeFreezeIOChoose :: IOChoose -> IO Choose+unsafeFreezeIOChoose (IOChoose c) = stToIO $ unsafeFreezeSTChoose c+{-# INLINE unsafeFreezeIOChoose #-}++unsafeThawIOChoose :: Choose -> IO (IOChoose)+unsafeThawIOChoose c = liftM IOChoose $ stToIO (unsafeThawSTChoose c)+{-# INLINE unsafeThawIOChoose #-}

@@ -0,0 +1,327 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, +        FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Data.Choose.MChoose+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--+-- An overloaded interface to mutable combinations. For combination types which +-- can be used with this interface, see "Data.Choose.IO" and "Data.Choose.ST".+--++module Data.Choose.MChoose (+    -- * Class of mutable combination types+    MChoose, ++    -- * Constructing mutable combinations+    newChoose,+    newChoose_,+    newListChoose,+    newCopyChoose,+    copyChoose,+    setFirst,+    +    -- * Accessing combination elements+    getElem,+    setElem,+    +    -- * Combination properties+    getPossible,+    getSize,+    getElems,+    setElems,+    isValid,++    -- * Combination functions+    getComplement,+    getComplElems,+    setNext,+    setPrev,+    +    -- * Converstions between mutable and immutable combinations+    freeze,+    unsafeFreeze,+    thaw,+    unsafeThaw,+    +    -- * Unsafe operations+    unsafeNewListChoose,+    unsafeGetElem,+    unsafeSetElem,++    ) where++import Control.Monad+import Control.Monad.ST++import Data.Choose.Base+import Data.Choose.IOBase+++--------------------------------- MChoose --------------------------------++-- | Class for representing a mutable combination.  The type is parameterized+-- over the type of the monad, @m@, in which the mutable combination will be+-- manipulated.+class (Monad m) => MChoose c m | c -> m, m -> c where+    -- | Get the number of possibilities, @n@ in the combination.+    getPossible :: c -> m Int+    +    -- | Get the number of outcomes, @k@ in the combination.+    getSize :: c -> m Int++    -- | @newChoose n k@ creates a new combination of @k@ outcomes from @n@ +    -- possibilites initialized to the subset @{ 0, ..., k-1 }@.+    newChoose :: Int -> Int -> m c++    -- | @newChoose n k@ allocates a new combination of @k@ outcomes from+    -- @n@ possibilities but does not initialize it.+    newChoose_ :: Int -> Int -> m c++    unsafeGetElem :: c -> Int -> m Int+    unsafeSetElem :: c -> Int -> Int -> m ()++    -- | Get a lazy list of the combination elements.  The laziness makes this+    -- function slightly dangerous if you are modifying the combination.+    getElems :: c -> m [Int]++    -- | Set all the values of a combination from a list of elements.+    setElems :: c -> [Int] -> m ()++    unsafeFreeze :: c -> m Choose+    unsafeThaw :: Choose -> m c+    +        +-- | Construct a combination from a list of elements.  +-- @newListChoose n k is@ creates a combination of @k@ outcomes from @n@+-- possibilities initialized to have the @i@th element equal to @is !! i@.  +-- For the combination to be valid, the elements must all be unique, they +-- must be in sorted order, and they all must be in the range @0 .. n-1@.+newListChoose :: (MChoose c m) => Int -> Int -> [Int] -> m c+newListChoose n k is = do+    c <- unsafeNewListChoose n k is+    valid <- isValid c+    when (not valid) $ fail "invalid combination"+    return c+{-# INLINE newListChoose #-}++unsafeNewListChoose :: (MChoose c m) => Int -> Int -> [Int] -> m c+unsafeNewListChoose n k is = do+    c <- newChoose_ n k+    setElems c is+    return c+{-# INLINE unsafeNewListChoose #-}++-- | Construct a new combination by copying another.+newCopyChoose :: (MChoose c m) => c -> m c+newCopyChoose c = do+    n  <- getPossible c+    k  <- getSize c+    c' <- newChoose_ n k+    copyChoose c' c+    return c'+{-# INLINE newCopyChoose #-}++-- | @copyChoose dst src@ copies the elements of the combination @src@+-- into the combination @dst@.  The two combinations must have the same+-- size.+copyChoose :: (MChoose c m) => c -> c -> m ()+copyChoose dst src =+    getElems src >>= setElems dst+{-# INLINE copyChoose #-}++-- | Set a combination to be the first subset of its size.+setFirst :: (MChoose c m) => c -> m ()+setFirst c = do+    k <- getSize c+    setElems c [0 .. k-1]+{-# INLINE setFirst #-}++-- | @getElem c i@ gets the value of the @i@th element of the combination+-- @c@.  The index @i@ must be in the range @0..k-1@, where @n@ is the+-- size of the combination.+getElem :: (MChoose c m) => c -> Int -> m Int+getElem c i = do+    k <- getSize c+    when (i < 0 || i >= k) $ fail "getElem: invalid index"+    unsafeGetElem c i+{-# INLINE getElem #-}++-- | @setElem c i x@ sets the value of the @i@th element of the combination+-- @c@.  The index @i@ must be in the range @0..k-1@, where @k@ is the+-- size of the combination.+setElem :: (MChoose c m) => c -> Int -> Int -> m ()+setElem c i x = do+    k <- getSize c+    when (i < 0 || i >= k) $ fail "getElem: invalid index"+    unsafeSetElem c i x+{-# INLINE setElem #-}++-- | Returns whether or not the combination is valid.  For it to be valid,+-- the elements must all be unique, they must be in sorted order, and they+-- all must be in the range @0 .. n-1@, where @n@ is the number of +-- possibilies in the combination.+isValid :: (MChoose c m) => c -> m Bool+isValid c = do+    n  <- getPossible c+    is <- getElems c+    return $! go n (-1) is+  where+    go _ _ []     = True+    go n j (i:is) = i > j && i < n && go n i is+{-# INLINE isValid #-}++-- | Compute the complement of a combination+getComplement :: (MChoose c m) => c -> m c+getComplement c = do+    n <- getPossible c+    k <- getSize c+    d <- newChoose_ n (n-k)+    setElems d =<< getComplElems c+    return $! d+{-# INLINE getComplement #-}++-- | Return a lazy list of the elements in the complement of a combination.+-- If the combination is a subset of @k@ outcomes from @n@ possibilities, then+-- the returned list will be sorted and of length @n-k@.  +-- Due to the laziness, you should be careful when using this function if you+-- are also modifying the combination.+getComplElems :: (MChoose c m) => c -> m [Int]+getComplElems c = do+    n  <- getPossible c+    is <- getElems c+    return $ go n is 0+  where+    go n []     j             = [j .. n-1]+    go n (i:is) j | j == i    = go n is (j+1)+                  | otherwise = [j .. i-1] ++ go n is (i+1)+{-# INLINE getComplElems #-}++-- | Advance a combination to the next in lexicogrphic order and return @True@. +--  If no further combinations are available, return @False@ and leave the +-- combination unmodified.  Starting with @[ 0 .. k-1 ]@ and repeatedly+-- calling @setNext@ will iterate through all subsets of size @k@.+setNext :: (MChoose c m) => c -> m Bool+setNext c = do+    n <- getPossible c+    k <- getSize c+    if k > 0+        then do+            findIncrement (k-1) (n-1) >>=+                maybe (return False) (\(i,i') -> do+                    unsafeSetElem c i (i'+1)+                    setAscending k (i+1) (i'+2)+                    return True+                )+        else +            return False+  where+    findIncrement i m = do+        i' <- unsafeGetElem c i+        if i' /= m then return (Just (i,i')) else recurse+      where+        recurse = if i /= 0 then findIncrement (i-1) (m-1) else return Nothing ++    setAscending k i x | i == k = return ()+                       | otherwise = do+        unsafeSetElem c i x+        setAscending k (i+1) (x+1)+{-# INLINE setNext #-}+        +-- | Step backwards to the previous combination in lexicographic order and+-- return @True@.  If there is no previous combination, return @False@ and+-- leave the combination unmodified.+setPrev :: (MChoose c m) => c -> m Bool+setPrev c = do+    n <- getPossible c+    k <- getSize c+    if k > 0+        then do+            k1' <- unsafeGetElem c (k-1)+            findGap (k-1) k1' >>=+                maybe (return False) (\(i,i') -> do+                    unsafeSetElem c i (i'-1)+                    setAscending k (i+1) (n-k+i+1)+                    return True+                )+        else+            return False+  where+    findGap i i' +        | i == 0 = +            if i' == 0 +                then return $ Nothing+                else return $ Just (0,i') ++        | otherwise = let j = i-1 in do+            j' <- unsafeGetElem c j+            if i' /= j'+1 +                then return $ Just (i,i')+                else findGap j j' +++    setAscending k i x | i == k = return ()+                       | otherwise = do+        unsafeSetElem c i x+        setAscending k (i+1) (x+1)+{-# INLINE setPrev #-}++-- | Convert a mutable combination to an immutable one.+freeze :: (MChoose c m) => c -> m Choose+freeze c = unsafeFreeze =<< newCopyChoose c+{-# INLINE freeze #-}++-- | Convert an immutable combination to a mutable one.+thaw :: (MChoose c m) => Choose -> m c+thaw c = newCopyChoose =<< unsafeThaw c+{-# INLINE thaw #-}+++--------------------------------- Instances ---------------------------------++instance MChoose (STChoose s) (ST s) where+    getPossible = getPossibleSTChoose+    {-# INLINE getPossible #-}+    getSize = getSizeSTChoose+    {-# INLINE getSize #-}+    newChoose = newSTChoose+    {-# INLINE newChoose #-}+    newChoose_ = newSTChoose_+    {-# INLINE newChoose_ #-}+    unsafeGetElem = unsafeGetElemSTChoose+    {-# INLINE unsafeGetElem #-}+    unsafeSetElem = unsafeSetElemSTChoose+    {-# INLINE unsafeSetElem #-}+    getElems = getElemsSTChoose+    {-# INLINE getElems #-}+    setElems = setElemsSTChoose+    {-# INLINE setElems #-}+    unsafeFreeze = unsafeFreezeSTChoose+    {-# INLINE unsafeFreeze #-}+    unsafeThaw = unsafeThawSTChoose+    {-# INLINE unsafeThaw #-}++instance MChoose IOChoose IO where+    getPossible = getPossibleIOChoose+    {-# INLINE getPossible #-}+    getSize = getSizeIOChoose+    {-# INLINE getSize #-}+    newChoose = newIOChoose+    {-# INLINE newChoose #-}+    newChoose_ = newIOChoose_+    {-# INLINE newChoose_ #-}+    unsafeGetElem = unsafeGetElemIOChoose+    {-# INLINE unsafeGetElem #-}+    unsafeSetElem = unsafeSetElemIOChoose+    {-# INLINE unsafeSetElem #-}+    getElems = getElemsIOChoose+    {-# INLINE getElems #-}+    setElems = setElemsIOChoose+    {-# INLINE setElems #-}+    unsafeFreeze = unsafeFreezeIOChoose+    {-# INLINE unsafeFreeze #-}+    unsafeThaw = unsafeThawIOChoose+    {-# INLINE unsafeThaw #-}

@@ -0,0 +1,32 @@+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Data.Choose.ST+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--+-- Mutable combinations in the 'ST' monad.++module Data.Choose.ST (+    -- * Combinations+    STChoose,+    runSTChoose,+    +    -- * Overloaded mutable combination interface+    module Data.Choose.MChoose+    ) where++import Control.Monad.ST++import Data.Choose.Base( Choose, STChoose, unsafeFreezeSTChoose )+import Data.Choose.MChoose++-- | A safe way to create and work with a mutable combination before returning +-- an immutable one for later perusal. This function avoids copying the +-- combination before returning it - it uses unsafeFreeze internally, but this +-- wrapper is a safe interface to that function. +runSTChoose :: (forall s. ST s (STChoose s)) -> Choose+runSTChoose c = runST (c >>= unsafeFreezeSTChoose)+{-# INLINE runSTChoose #-}

@@ -18,6 +18,7 @@     elems,      newArray_,+    sameSTIntArray,          numElementsSTIntArray,     getNumElements,@@ -70,6 +71,11 @@         (# s2#, STIntArray n marr# #) }   where     sizeOfInt = case sizeOf (0 :: Int) of (I# s#) -> s#++{-# INLINE sameSTIntArray #-}+sameSTIntArray :: STIntArray s -> STIntArray s -> Bool+sameSTIntArray (STIntArray _ marr1#) (STIntArray _ marr2#) =+    sameMutableByteArray# marr1# marr2#      {-# INLINE numElementsSTIntArray #-} numElementsSTIntArray :: STIntArray s -> Int

@@ -19,8 +19,8 @@     swapsPermute,      -- * Accessing permutation elements-    apply,-    unsafeApply,+    at,+    unsafeAt,      -- * Permutation properties     size,@@ -56,7 +56,7 @@     unsafeFreeze =<< newPermute n  -- | Construct a permutation from a list of elements.  --- @listPermute n is@ creates a permuation of size @n@ with+-- @listPermute n is@ creates a permutation of size @n@ with -- the @i@th element equal to @is !! i@.  For the permutation to be valid, -- the list @is@ must have length @n@ and contain the indices @0..(n-1)@  -- exactly once each.@@ -65,7 +65,7 @@     unsafeFreeze =<< newListPermute n is  -- | Construct a permutation from a list of swaps.--- @swapsPermute n ss@ creats a permuation of size @n@ given by a+-- @swapsPermute n ss@ creats a permutation of size @n@ given by a -- sequence of swaps. -- If @ss@ is @[(i0,j0), (i1,j1), ..., (ik,jk)]@, the -- sequence of swaps is@@ -76,16 +76,16 @@ swapsPermute n ss = runST $     unsafeFreeze =<< newSwapsPermute n ss --- | @apply p i@ gets the value of the @i@th element of the permutation+-- | @at p i@ gets the value of the @i@th element of the permutation -- @p@.  The index @i@ must be in the range @0..(n-1)@, where @n@ is the -- size of the permutation.-apply :: Permute -> Int -> Int-apply p i+at :: Permute -> Int -> Int+at p i     | i >= 0 && i < size p = -        unsafeApply p i+        unsafeAt p i     | otherwise =         error "Invalid index"-{-# INLINE apply #-}+{-# INLINE at #-}  -- | Get the inverse of a permutation inverse :: Permute -> Permute@@ -100,7 +100,7 @@ next = nextPrevHelp setNext  -- | Return the previous permutation in lexicographic order, or @Nothing@--- if there is no such permutation.+-- if no such permutation exists. prev :: Permute -> Maybe Permute prev = nextPrevHelp setPrev 

@@ -27,13 +27,13 @@ -- | The immutable permutation data type. -- Internally, a permutation of size @n@ is stored as an -- @0@-based array of @n@ 'Int's.  The permutation represents a reordering of--- the integers @0, ..., (n-1)@.  The @i@th element of the array stores--- the value @p[i]@. +-- the integers @0, ..., (n-1)@.  The permutation sents the value p[i] to +-- @i@.  newtype Permute = Permute IntArray -unsafeApply :: Permute -> Int -> Int-unsafeApply (Permute p) i = Arr.unsafeAt p i-{-# INLINE unsafeApply #-}+unsafeAt :: Permute -> Int -> Int+unsafeAt (Permute p) i = Arr.unsafeAt p i+{-# INLINE unsafeAt #-}  -- | Get the size of the permutation. size :: Permute -> Int@@ -70,7 +70,7 @@ newSTPermute n = do     p@(STPermute marr) <- newSTPermute_ n     ArrST.writeElems marr [0 .. n-1]-    return $! p+    return p {-# INLINE newSTPermute #-}  newSTPermute_ :: Int -> ST s (STPermute s)@@ -108,3 +108,6 @@ unsafeThawSTPermute (Permute arr) =     (liftM STPermute . ArrST.unsafeThaw) arr {-# INLINE unsafeThawSTPermute #-}++instance Eq (STPermute s) where+    (==) (STPermute marr1) (STPermute marr2) = ArrST.sameSTIntArray marr1 marr2

@@ -15,9 +15,8 @@ import Control.Monad.ST import Data.Permute.Base --- | A mutable permutation that can be manipulated in the 'IO' monad. The--- type argument @s@ is the state variable argument for the 'IO' type.-newtype IOPermute = IOPermute (STPermute RealWorld)+-- | A mutable permutation that can be manipulated in the 'IO' monad.+newtype IOPermute = IOPermute (STPermute RealWorld) deriving Eq  newIOPermute :: Int -> IO (IOPermute) newIOPermute n = liftM IOPermute $ stToIO (newSTPermute n)

@@ -112,7 +112,7 @@               -- | Construct a permutation from a list of elements.  --- @newListPermute n is@ creates a permuation of size @n@ with+-- @newListPermute n is@ creates a permutation of size @n@ with -- the @i@th element equal to @is !! i@.  For the permutation to be valid, -- the list @is@ must have length @n@ and contain the indices @0..(n-1)@  -- exactly once each.@@ -121,18 +121,18 @@     p <- unsafeNewListPermute n is     valid <- isValid p     when (not valid) $ fail "invalid permutation"-    return $! p+    return  p {-# INLINE newListPermute #-}  unsafeNewListPermute :: (MPermute p m) => Int -> [Int] -> m p unsafeNewListPermute n is = do     p <- newPermute_ n     setElems p is-    return $! p+    return p {-# INLINE unsafeNewListPermute #-}  -- | Construct a permutation from a list of swaps.--- @newSwapsPermute n ss@ creates a permuation of size @n@ given a+-- @newSwapsPermute n ss@ creates a permutation of size @n@ given a -- sequence of swaps. -- If @ss@ is @[(i0,j0), (i1,j1), ..., (ik,jk)]@, the -- sequence of swaps is@@ -152,7 +152,7 @@ newSwapsPermuteHelp swap n ss = do     p <- newPermute n     mapM_ (uncurry $ swap p) ss-    return $! p+    return p {-# INLINE newSwapsPermuteHelp #-}  -- | Construct a new permutation by copying another.@@ -161,11 +161,11 @@     n  <- getSize p     p' <- newPermute_ n     copyPermute p' p-    return $! p'+    return p' {-# INLINE newCopyPermute #-}  -- | @copyPermute dst src@ copies the elements of the permutation @src@--- into the permtuation @dst@.  The two permutations must have the same+-- into the permutation @dst@.  The two permutations must have the same -- size. copyPermute :: (MPermute p m) => p -> p -> m () copyPermute dst src =@@ -225,7 +225,7 @@         i' <- unsafeGetElem p i         valid  <- return $ i' >= 0 && i' < n         unique <- liftM not (i' `existsIn` i)-        return $! valid && unique+        return $ valid && unique      validIndices n = validIndicesHelp n 0 

@@ -24,7 +24,7 @@ import Data.Permute.MPermute  -- | A safe way to create and work with a mutable permutation before returning --- an immutable permutation for later perusal. This function avoids copying the +-- an immutable one for later perusal. This function avoids copying the  -- permutation before returning it - it uses unsafeFreeze internally, but this  -- wrapper is a safe interface to that function.  runSTPermute :: (forall s. ST s (STPermute s)) -> Permute

@@ -1,17 +1,21 @@ name:            permutation-version:         0.2.1+version:         0.3 homepage:        http://stat.stanford.edu/~patperry/code/permutation-synopsis:        A library for representing and applying permutations.+synopsis:        A library for permutations and combinations. description:-    This library includes data types for storing permutations.  It-    implements pure and impure types, the latter of which can be modified-    in-place.  The main utility of the library is converting between-    the linear representation of a permutation and a sequence of swaps.-    This allows, for instance, applying a permutation or its inverse+    This library includes data types for storing permutations and+    combinations.  It implements pure and impure types, the latter of+    which can be modified in-place.  The library uses aggressive+    inlining and MutableByteArray#s internally, so it is very+    efficient.+    .+    The main utility of the library is converting between the linear+    representation of a permutation and a sequence of swaps.  This +    allows, for instance, applying a permutation or its inverse     to an array with O(1) memory use.     .     Much of the interface for the library is based on the permutation -    functions in the GNU Scientific Library (GSL).+    and combination functions in the GNU Scientific Library (GSL).     . category:        Data Structures, Math license:         BSD3@@ -24,21 +28,30 @@ tested-with:     GHC ==6.8.2, GHC ==6.10.1  extra-source-files:  examples/Enumerate.hs+                     tests/Test/Choose.hs                      tests/Test/Permute.hs                      tests/Driver.hs                      tests/Main.hs-                     tests/Pure.hs-                     tests/ST.hs+                     tests/Choose.hs+                     tests/STChoose.hs+                     tests/Permute.hs+                     tests/STPermute.hs                      tests/Makefile  library     hs-source-dirs:  lib-    exposed-modules: Data.Permute+    exposed-modules: Data.Choose+                     Data.Choose.MChoose+                     Data.Choose.IO+                     Data.Choose.ST+                     Data.Permute                      Data.Permute.MPermute                      Data.Permute.IO                      Data.Permute.ST                           other-modules:   Data.IntArray+                     Data.Choose.Base+                     Data.Choose.IOBase                      Data.Permute.Base                      Data.Permute.IOBase 

@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Choose (+    tests_Choose+    ) where+    +import Control.Monad.ST+import Data.Array.ST+import Data.List( foldl' )+import qualified Data.List as List+import Data.Maybe( fromJust )++import Data.Choose++import Driver+import Test.QuickCheck hiding (choose)+    +import Test.Choose()+import qualified Test.Choose as Test+++prop_possible_choose (Index n' k) = let n = n'-1 in+    possible (choose n k) == n+prop_size_choose (Index n' k) = let n = n'-1 in+    size (choose n k) == k+prop_elems_choose (Index n' k) = let n = n'-1 in+    elems (choose n k) == [0 .. k-1]++prop_possible_listChoose (ListChoose n k is) =+    possible (listChoose n k is) == n+prop_size_listChoose (ListChoose n k is) =+    size (listChoose n k is) == k+prop_elems_listChoose (ListChoose n k is) =+    elems (listChoose n k is) == is++prop_at       = prop_at_help at+prop_unsafeAt = prop_at_help unsafeAt+prop_at_help a =+    forAll arbitrary $ \(Index k i) ->+    forAll arbitrary $ \(Nat nk) ->+    forAll (Test.choose (nk+k) k) $ \c ->+        a c i == (elems c) !! i++prop_possible_complement (c :: Choose) =+    possible (complement c) == possible c+prop_size_complement (c :: Choose) =+    size (complement c) == possible c - size c+prop_elems_complement (c :: Choose) =+    all (not . (`elem` is)) is'+  where+    is  = elems c+    is' = elems (complement c)++prop_prev_choose (Index n1 k) = let n = n1-1 in+    prev (choose n k) == Nothing+prop_next_last (Index n1 k) = let n = n1-1 in+    next (listChoose n k $ [(n-k)..(n-1)]) == Nothing++prop_next_prev (c :: Choose) =+    case prev c of+        Just c' -> c == (fromJust $ next c')+        Nothing -> c == choose n k+  where+    n = possible c+    k = size c+    +prop_prev_next (c :: Choose) =+    case next c of+        Just c' -> c == (fromJust $ prev c')+        Nothing -> c == (listChoose n k $ [(n-k)..(n-1)])+  where+    n = possible c+    k = size c++tests_Choose = +    [ ("possible . choose"      , mytest prop_possible_choose)+    , ("size . choose"          , mytest prop_size_choose)+    , ("elems . choose"         , mytest prop_elems_choose)+    , ("possible . listChoose"  , mytest prop_possible_listChoose)+    , ("size . listChoose"      , mytest prop_size_listChoose)+    , ("elems . listChoose"     , mytest prop_elems_listChoose)+    , ("at"                     , mytest prop_at)+    , ("unsafeAt"               , mytest prop_unsafeAt)+    , ("possible . complement"  , mytest prop_possible_complement)+    , ("size . complement"      , mytest prop_size_complement)+    , ("elems . complement"     , mytest prop_elems_complement)+    , ("prev . choose"          , mytest prop_prev_choose)+    , ("next (last choose)"     , mytest prop_next_last)+    , ("next . prev"            , mytest prop_next_prev)+    , ("prev . next"            , mytest prop_prev_next)+    ]

@@ -10,6 +10,7 @@ module Driver (     Natural(..),     Index(..),+    ListChoose(..),         ListPermute(..),     SwapsPermute(..),     Sort(..),@@ -49,6 +50,19 @@         return $ Index (n + 1) i      coarbitrary = undefined++data ListChoose = ListChoose Int Int [Int] deriving (Eq,Show)+instance Arbitrary ListChoose where+    arbitrary = do+        (Nat n) <- arbitrary+        k <- choose (0,n)+        +        xs <- vector n :: Gen [Int]+        return . ListChoose n k $ +            sort $ take k $ (snd . unzip) $ sortBy (comparing fst) $ zip xs [0..]++    coarbitrary = undefined+  data ListPermute = ListPermute Int [Int] deriving (Eq,Show) instance Arbitrary ListPermute where

@@ -4,8 +4,10 @@ import Text.Printf  import Driver-import Pure-import ST+import Choose+import Permute+import STChoose+import STPermute  main :: IO () main = do@@ -36,9 +38,12 @@     when (not . and $ smokeResults ++ results) $ fail "\nNot all tests passed!"  where -    smoke = [ ("STPermute", smoke_STPermute) +    smoke = [ ("STChoose" , smoke_STChoose) +            , ("STPermute", smoke_STPermute)              ] -    tests = [ ("Permute"   , tests_Permute)+    tests = [ ("STChoose"  , tests_Choose)+            , ("STChoose"  , tests_STChoose)+            , ("Permute"   , tests_Permute)             , ("STPermute" , tests_STPermute)             ]

@@ -1,16 +1,17 @@ all:-	ghc -O -i. -i../lib Main.hs --make -o test-permute-	./test-permute+	ghc -O -i. -i../lib Main.hs --make -o test-permutation+	./test-permutation  hpc:-	ghc -fforce-recomp -i. -i../lib -fhpc --make Main.hs -o test-permute-	rm -f test-permute.tix-	./test-permute-	hpc markup test-permute+	ghc -fforce-recomp -i. -i../lib -fhpc --make Main.hs -o test-permutation+	rm -f test-permutation.tix+	./test-permutation+	hpc markup test-permutation  clean: 	find ../lib . -name '*.hi' | xargs rm -f 	find ../lib . -name '*.o'  | xargs rm -f 	find . -name '*.html' | xargs rm -f-	rm -f test-permute test-permute.tix+	rm -f test-permutation test-permutation.tix+	rm -rf .hpc 	

@@ -0,0 +1,173 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Permute (+    tests_Permute+    ) where+    +import Control.Monad.ST+import Data.Array.ST+import Data.List( foldl' )+import qualified Data.List as List+import Data.Maybe( fromJust )++import Data.Permute++import Driver+import Test.QuickCheck+    +import Test.Permute()+import qualified Test.Permute as Test+++prop_size_permute (Nat n) =+    size (permute n) == n+prop_elems_permute (Nat n) =+    elems (permute n) == [0..(n-1)]++prop_size_listPermute (ListPermute n is) =+    size (listPermute n is) == n+prop_elems_listPermute (ListPermute n is) =+    elems (listPermute n is) == is++prop_size_swapsPermute (SwapsPermute n ss) =+    size (swapsPermute n ss) == n+prop_elems_swapsPermute (SwapsPermute n ss) =+    elems (swapsPermute n ss) == map at [0..(n-1)]+  where+    at i = foldl' doSwap i $ reverse ss+    doSwap k (i,j) | k == i    = j+                   | k == j    = i+                   | otherwise = k++prop_at       = prop_at_help at+prop_unsafeAt = prop_at_help unsafeAt+prop_at_help a =+    forAll arbitrary $ \(Index n i) ->+    forAll (Test.permute n) $ \p ->+        a p i == (elems p) !! i++prop_size_inverse (p :: Permute) =+    size (inverse p) == size p+prop_elems_inverse (p :: Permute) =+    all (\i -> is' !! (at p i) == i) [0..(n-1)]+  where+    n   = size p+    is' = elems (inverse p)++prop_swaps (Nat n) =+    forAll (Test.permute n) $ \p ->+    forAll (vector n) $ \xs ->+        let xs' = applySwaps (swaps p) xs+        in all (\i -> xs' !! i == xs !! (at p i)) [0..(n-1)]++prop_invSwaps (Nat n) =+    forAll (Test.permute n) $ \p ->+    forAll (vector n) $ \xs ->+        let xs' = applySwaps (invSwaps p) xs+        in all (\i -> xs' !! (at p i) == xs !! i) [0..(n-1)]++prop_swaps_inverse (Nat n) =+    forAll (Test.permute n) $ \p ->+    forAll (vector n) $ \xs ->+        applySwaps (swaps $ inverse p) xs == (applySwaps (invSwaps p) xs)+    +prop_invSwaps_inverse (Nat n) =+    forAll (Test.permute n) $ \p ->+    forAll (vector n) $ \xs ->+        applySwaps (invSwaps $ inverse p) xs == (applySwaps (swaps p) xs)++prop_prev_permute (Nat n) =+    prev (permute n) == Nothing+prop_next_last (Nat n) =+    next (listPermute n $ reverse [0..(n-1)]) == Nothing++prop_next_prev (p :: Permute) =+    case prev p of+        Just p' -> p == (fromJust $ next p')+        Nothing -> p == permute n+  where+    n = size p+    +prop_prev_next (p :: Permute) =+    case next p of+        Just p' -> p == (fromJust $ prev p')+        Nothing -> p == (listPermute n $ reverse [0..(n-1)])+  where+    n = size p++prop_fst_sort (Sort n xs) = let+    ys = take n xs+    in (fst . sort n) xs == (List.sort ys)+prop_snd_sort (Sort n xs) = let+    ys = take n xs+    in applySwaps (swaps $ snd $ sort n xs) ys == (List.sort ys)++prop_fst_sortBy (SortBy cmp n xs) = let +    ys = take n xs+    in (fst . sortBy cmp n) xs == (List.sortBy cmp ys)+prop_snd_sortBy (SortBy cmp n xs) = let +    ys = take n xs+    in applySwaps (swaps $ snd $ sortBy cmp n xs) ys == (List.sortBy cmp ys)++prop_order (Sort n xs) = let +    ys = take n xs+    in applySwaps (swaps $ order n xs) ys == (List.sort ys)++prop_orderBy (SortBy cmp n xs) = let +    ys = take n xs+    in applySwaps (swaps $ orderBy cmp n xs) ys == (List.sortBy cmp ys)++prop_rank (Sort n xs) = let+    ys = take n xs+    in applySwaps (invSwaps $ rank n xs) ys == (List.sort ys)++prop_rankBy (SortBy cmp n xs) = let+    ys = take n xs+    in applySwaps (invSwaps $ rankBy cmp n xs) ys == (List.sortBy cmp ys)++prop_swapsPermute_swaps (p :: Permute) =+    swapsPermute (size p) (swaps p) == p+++tests_Permute = +    [ ("size . permute"          , mytest prop_size_permute)+    , ("elems . permute"         , mytest prop_elems_permute)+    , ("size . listPermute"      , mytest prop_size_listPermute)+    , ("elems . listPermute"     , mytest prop_elems_listPermute)+    , ("size . swapsPermute"     , mytest prop_size_swapsPermute)+    , ("elems . swapsPermute"    , mytest prop_elems_swapsPermute)+    , ("at"                      , mytest prop_at)+    , ("unsafeAt"                , mytest prop_unsafeAt)+    , ("size . inverse"          , mytest prop_size_inverse)+    , ("elems . inverse"         , mytest prop_elems_inverse)+    , ("swaps"                   , mytest prop_swaps)+    , ("invSwaps"                , mytest prop_invSwaps)+    , ("swaps . inverse"         , mytest prop_swaps_inverse)+    , ("invSwaps . inverse"      , mytest prop_invSwaps_inverse)+    , ("prev . permute"          , mytest prop_prev_permute)+    , ("next (last permutation)" , mytest prop_next_last)+    , ("next . prev"             , mytest prop_next_prev)+    , ("prev . next"             , mytest prop_prev_next)+    , ("fst . sort"              , mytest prop_fst_sort)+    , ("snd . sort"              , mytest prop_snd_sort)+    , ("fst . sortBy"            , mytest prop_fst_sortBy)+    , ("snd . sortBy"            , mytest prop_snd_sortBy)+    , ("order"                   , mytest prop_order)+    , ("orderBy"                 , mytest prop_orderBy)+    , ("rank"                    , mytest prop_rank)+    , ("rankBy"                  , mytest prop_rankBy)+    , ("swapsPermute . swaps"    , mytest prop_swapsPermute_swaps)+    ]+++applySwaps :: [(Int,Int)] -> [Int] -> [Int]+applySwaps ss xs = runST $ do+    arr <- newListArray (0,length xs - 1) xs :: ST s (STUArray s Int Int) +    mapM_ (swap arr) ss+    getElems arr+  where+    swap arr (i,j) = do+        i' <- readArray arr i+        j' <- readArray arr j+        writeArray arr j i'+        writeArray arr i j'+

@@ -1,173 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-module Pure (-    tests_Permute-    ) where-    -import Control.Monad.ST-import Data.Array.ST-import Data.List( foldl' )-import qualified Data.List as List-import Data.Maybe( fromJust )--import Data.Permute--import Driver-import Test.QuickCheck-    -import Test.Permute()-import qualified Test.Permute as Test---prop_size_permute (Nat n) =-    size (permute n) == n-prop_elems_permute (Nat n) =-    elems (permute n) == [0..(n-1)]--prop_size_listPermute (ListPermute n is) =-    size (listPermute n is) == n-prop_elems_listPermute (ListPermute n is) =-    elems (listPermute n is) == is--prop_size_swapsPermute (SwapsPermute n ss) =-    size (swapsPermute n ss) == n-prop_elems_swapsPermute (SwapsPermute n ss) =-    elems (swapsPermute n ss) == map at [0..(n-1)]-  where-    at i = foldl' doSwap i $ reverse ss-    doSwap k (i,j) | k == i    = j-                   | k == j    = i-                   | otherwise = k--prop_apply       = prop_apply_help apply-prop_unsafeApply = prop_apply_help unsafeApply-prop_apply_help a =-    forAll arbitrary $ \(Index n i) ->-    forAll (Test.permute n) $ \p ->-        a p i == (elems p) !! i--prop_size_inverse (p :: Permute) =-    size (inverse p) == size p-prop_elems_inverse (p :: Permute) =-    all (\i -> is' !! (apply p i) == i) [0..(n-1)]-  where-    n   = size p-    is' = elems (inverse p)--prop_swaps (Nat n) =-    forAll (Test.permute n) $ \p ->-    forAll (vector n) $ \xs ->-        let xs' = applySwaps (swaps p) xs-        in all (\i -> xs' !! i == xs !! (apply p i)) [0..(n-1)]--prop_invSwaps (Nat n) =-    forAll (Test.permute n) $ \p ->-    forAll (vector n) $ \xs ->-        let xs' = applySwaps (invSwaps p) xs-        in all (\i -> xs' !! (apply p i) == xs !! i) [0..(n-1)]--prop_swaps_inverse (Nat n) =-    forAll (Test.permute n) $ \p ->-    forAll (vector n) $ \xs ->-        applySwaps (swaps $ inverse p) xs == (applySwaps (invSwaps p) xs)-    -prop_invSwaps_inverse (Nat n) =-    forAll (Test.permute n) $ \p ->-    forAll (vector n) $ \xs ->-        applySwaps (invSwaps $ inverse p) xs == (applySwaps (swaps p) xs)--prop_prev_permute (Nat n) =-    prev (permute n) == Nothing-prop_next_last (Nat n) =-    next (listPermute n $ reverse [0..(n-1)]) == Nothing--prop_next_prev (p :: Permute) =-    case prev p of-        Just p' -> p == (fromJust $ next p')-        Nothing -> p == permute n-  where-    n = size p-    -prop_prev_next (p :: Permute) =-    case next p of-        Just p' -> p == (fromJust $ prev p')-        Nothing -> p == (listPermute n $ reverse [0..(n-1)])-  where-    n = size p--prop_fst_sort (Sort n xs) = let-    ys = take n xs-    in (fst . sort n) xs == (List.sort ys)-prop_snd_sort (Sort n xs) = let-    ys = take n xs-    in applySwaps (swaps $ snd $ sort n xs) ys == (List.sort ys)--prop_fst_sortBy (SortBy cmp n xs) = let -    ys = take n xs-    in (fst . sortBy cmp n) xs == (List.sortBy cmp ys)-prop_snd_sortBy (SortBy cmp n xs) = let -    ys = take n xs-    in applySwaps (swaps $ snd $ sortBy cmp n xs) ys == (List.sortBy cmp ys)--prop_order (Sort n xs) = let -    ys = take n xs-    in applySwaps (swaps $ order n xs) ys == (List.sort ys)--prop_orderBy (SortBy cmp n xs) = let -    ys = take n xs-    in applySwaps (swaps $ orderBy cmp n xs) ys == (List.sortBy cmp ys)--prop_rank (Sort n xs) = let-    ys = take n xs-    in applySwaps (invSwaps $ rank n xs) ys == (List.sort ys)--prop_rankBy (SortBy cmp n xs) = let-    ys = take n xs-    in applySwaps (invSwaps $ rankBy cmp n xs) ys == (List.sortBy cmp ys)--prop_swapsPermute_swaps (p :: Permute) =-    swapsPermute (size p) (swaps p) == p---tests_Permute = -    [ ("size . permute"          , mytest prop_size_permute)-    , ("elems . permute"         , mytest prop_elems_permute)-    , ("size . listPermute"      , mytest prop_size_listPermute)-    , ("elems . listPermute"     , mytest prop_elems_listPermute)-    , ("size . swapsPermute"     , mytest prop_size_swapsPermute)-    , ("elems . swapsPermute"    , mytest prop_elems_swapsPermute)-    , ("apply"                   , mytest prop_apply)-    , ("unsafeApply"             , mytest prop_unsafeApply)-    , ("size . inverse"          , mytest prop_size_inverse)-    , ("elems . inverse"         , mytest prop_elems_inverse)-    , ("swaps"                   , mytest prop_swaps)-    , ("invSwaps"                , mytest prop_invSwaps)-    , ("swaps . inverse"         , mytest prop_swaps_inverse)-    , ("invSwaps . inverse"      , mytest prop_invSwaps_inverse)-    , ("prev . permute"          , mytest prop_prev_permute)-    , ("next (last permutation)" , mytest prop_next_last)-    , ("next . prev"             , mytest prop_next_prev)-    , ("prev . next"             , mytest prop_prev_next)-    , ("fst . sort"              , mytest prop_fst_sort)-    , ("snd . sort"              , mytest prop_snd_sort)-    , ("fst . sortBy"            , mytest prop_fst_sortBy)-    , ("snd . sortBy"            , mytest prop_snd_sortBy)-    , ("order"                   , mytest prop_order)-    , ("orderBy"                 , mytest prop_orderBy)-    , ("rank"                    , mytest prop_rank)-    , ("rankBy"                  , mytest prop_rankBy)-    , ("swapsPermute . swaps"    , mytest prop_swapsPermute_swaps)-    ]---applySwaps :: [(Int,Int)] -> [Int] -> [Int]-applySwaps ss xs = runST $ do-    arr <- newListArray (0,length xs - 1) xs :: ST s (STUArray s Int Int) -    mapM_ (swap arr) ss-    getElems arr-  where-    swap arr (i,j) = do-        i' <- readArray arr i-        j' <- readArray arr j-        writeArray arr j i'-        writeArray arr i j'-

@@ -1,231 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module ST (-    tests_STPermute,-    smoke_STPermute-    ) where-    -import Control.Monad-import Control.Monad.ST--import Data.Permute-import Data.Permute.ST---import Driver-import Debug.Trace-import Test.QuickCheck-import Text.Printf-    -import Test.Permute()-import qualified Test.Permute as Test--newPermute_S n = permute n-prop_NewPermute (Nat n) = -    newPermute n `equivalent` newPermute_S n--newListPermute_S n is = listPermute n is-prop_NewListPermute (ListPermute n is) =-    newListPermute n is `equivalent` newListPermute_S n is--newSwapsPermute_S n ss = swapsPermute n ss-prop_NewSwapsPermute (SwapsPermute n ss) =-    newSwapsPermute n ss `equivalent` newSwapsPermute_S n ss-prop_UnsafeNewSwapsPermute (SwapsPermute n ss) =-    unsafeNewSwapsPermute n ss `equivalent` newSwapsPermute_S n ss----newCopyPermute_S p = (p, p)-prop_NewCopyPermute =-    implements-        (\p -> newCopyPermute p >>= unsafeFreeze)-        (\p -> newCopyPermute_S p)--copyPermute_S p q = ((), q, q)-prop_CopyPermute =-    copyPermute `implements2` copyPermute_S--setIdentity_S p = ((), permute (size p))-prop_SetIdentity =-    setIdentity `implements` setIdentity_S --getElem_S p i = ((elems p) !! i, p)-prop_GetElem (Index n i) =-    implementsFor n-        (\p -> getElem   p i)-        (\p -> getElem_S p i)--prop_UnsafeGetElem (Index n i) =-    implementsFor n-        (\p -> unsafeGetElem p i)-        (\p -> getElem_S p i)--swapElems_S p i j = ((), p')-  where-    (n,is) = (size p, elems p)-      -    at k | k == i    = is !! j-         | k == j    = is !! i-         | otherwise = is !! k-    p'   = listPermute n $ map at [0..(n-1)]--prop_SwapElems (Swap n i j) =-    implementsFor n-        (\p -> swapElems p i j) -        (\p -> swapElems_S p i j)--prop_UnsafeSwapElems (Swap n i j) =-    implementsFor n-        (\p -> unsafeSwapElems p i j) -        (\p -> swapElems_S p i j)---getSize_S p = (length (elems p), p)-prop_GetSize = getSize `implements` getSize_S-      -getElems_S p = (elems p, p)-prop_GetElems = getElems `implements` getElems_S--prop_IsValid_Strict = runST $ do-    p <- newPermute 10-    setElem p 0 1-    valid <- isValid p-    setElem p 0 0-    return $ valid == False--prop_GetSwaps_Lazy1 = runST $ do-    p <- newPermute 10-    ss <- getSwaps p-    swapElems p 0 1-    return $ length ss == 1--prop_GetSwaps_Lazy2 = runST $ do-    p <- newPermute 10-    ss <- getSwaps p-    swapElems p 0 1-    swapElems p 3 4-    head ss `seq` swapElems p 3 4-    return $ length ss == 1--tests_STPermute = -    [ ("newPermute"               , mytest prop_NewPermute)-    , ("newListPermute"           , mytest prop_NewListPermute)-    , ("newSwapsPermute"          , mytest prop_NewSwapsPermute)-    , ("unsafeNewSwapsPermute"    , mytest prop_UnsafeNewSwapsPermute)-    , ("newCopyPermute"           , mytest prop_NewCopyPermute)-    , ("copyPermute"              , mytest prop_CopyPermute)-    , ("setIdentity"              , mytest prop_SetIdentity)-    , ("getElem"                  , mytest prop_GetElem)-    , ("unsafeGetElem"            , mytest prop_UnsafeGetElem)-    , ("swapElems"                , mytest prop_SwapElems)-    , ("unsafeSwapElems"          , mytest prop_UnsafeSwapElems)-    , ("getSize"                  , mytest prop_GetSize)-    , ("getElems"                 , mytest prop_GetElems)-    ]--smoke_STPermute =-    [ ("isValid is strict"             , mytest prop_IsValid_Strict)-    , ("getSwaps is lazy (test 1)"     , mytest prop_GetSwaps_Lazy1)-    , ("getSwaps is lazy (test 2)"     , mytest prop_GetSwaps_Lazy2)-    ]----------------------------------------------------------------------------- --- The specification language----    -abstract :: STPermute s -> ST s Permute-abstract = freeze--commutes :: (Eq a, Show a) =>-    STPermute s -> (STPermute s -> ST s a) ->-        (Permute -> (a,Permute)) -> ST s Bool-commutes p a f = do-    old <- abstract p-    r   <- a p-    new <- abstract p-    let s      = f old-        s'     = (r,new)-        passed = s == s'-        -    when (not passed) $-        trace (printf ("expected `%s' but got `%s'") (show s) (show s'))-              return ()-              -    return passed--equivalent :: (forall s . ST s (STPermute s)) -> Permute -> Bool-equivalent p s = runST $ do-    p' <- (p >>= abstract)-    when (not $ p' == s) $-        trace (printf ("expected `%s' but got `%s'") (show s) (show p'))-            return ()-    return (p' == s)-    -implements :: (Eq a, Show a) =>-    (forall s . STPermute s -> ST s a) ->-    (Permute -> (a,Permute)) -> -        Property-a `implements` f =-    forAll arbitrary $ \(Nat n) ->-        implementsFor n a f--implementsFor :: (Eq a, Show a) =>-    Int ->-    (forall s . STPermute s -> ST s a) ->-    (Permute -> (a,Permute)) -> -        Property-implementsFor n a f =-    forAll (Test.permute n) $ \p ->-        runST $ do-            p' <- unsafeThaw p-            commutes p' a f--implementsIf :: (Eq a, Show a) =>-    (forall s . STPermute s -> ST s Bool) ->-    (forall s . STPermute s -> ST s a) ->-    (Permute -> (a, Permute)) -> -        Property-implementsIf pre a f =-    forAll arbitrary $ \p ->-        runST ( do-            p' <- thaw p-            pre p') ==>-        runST ( do-            p' <- unsafeThaw p-            commutes p' a f )---commutes2 :: (Eq a, Show a) =>-    STPermute s -> STPermute s -> (STPermute s -> STPermute s -> ST s a) ->-        (Permute -> Permute -> (a,Permute,Permute)) -> ST s Bool-commutes2 p q a f = do-    oldp <- abstract p-    oldq <- abstract q-    r   <- a p q-    newp <- abstract p-    newq <- abstract q-    let s      = f oldp oldq-        s'     = (r,newp,newq)-        passed = s == s'-        -    when (not passed) $-        trace (printf ("expected `%s' but got `%s'") (show s) (show s'))-              return ()-              -    return passed---implements2 :: (Eq a, Show a) =>-    (forall s . STPermute s -> STPermute s -> ST s a) ->-    (Permute -> Permute -> (a,Permute,Permute)) -> -        Property-implements2 a f =-    forAll arbitrary $ \(Nat n) ->-    forAll (Test.permute n) $ \p ->-    forAll (Test.permute n) $ \q ->-        runST $ do-            p' <- unsafeThaw p-            q' <- unsafeThaw q-            commutes2 p' q' a f-

@@ -0,0 +1,189 @@+{-# LANGUAGE Rank2Types #-}+module STChoose (+    tests_STChoose,+    smoke_STChoose+    ) where+    +import Control.Monad+import Control.Monad.ST++import Data.Choose+import Data.Choose.ST+++import Driver+import Debug.Trace+import Test.QuickCheck hiding ( choose )+import qualified Test.QuickCheck as QC+import Text.Printf+    +import Test.Choose()+import qualified Test.Choose as Test++newChoose_S n k = choose n k+prop_NewChoose (Index n k) = let n' = n-1 in+    newChoose n' k `equivalent` newChoose_S n' k++newListChoose_S n k is = listChoose n k is+prop_NewListChoose (ListChoose n k is) =+    newListChoose n k is `equivalent` newListChoose_S n k is++newCopyChoose_S c = (c, c)+prop_NewCopyChoose =+    implements+        (\c -> newCopyChoose c >>= unsafeFreeze)+        (\c -> newCopyChoose_S c)++copyChoose_S dst src = ((), src, src)+prop_CopyChoose =+    copyChoose `implements2` copyChoose_S++setFirst_S c = ((), choose (possible c) (size c))+prop_SetFirst =+    setFirst `implements` setFirst_S ++getElem_S c i = (c `at` i, c)+prop_GetElem (Index k i) =+    forAll arbitrary $ \(Nat n) ->+    implementsFor (n+k) k+        (\c -> getElem   c i)+        (\c -> getElem_S c i)++prop_UnsafeGetElem (Index k i) =+    forAll arbitrary $ \(Nat n) ->    +    implementsFor (n+k) k+        (\c -> unsafeGetElem c i)+        (\c -> getElem_S c i)++getPossible_S c = (possible c, c)+prop_GetPossible = getPossible `implements` getPossible_S++getSize_S c = (length (elems c), c)+prop_GetSize = getSize `implements` getSize_S+      +getElems_S c = (elems c, c)+prop_GetElems = getElems `implements` getElems_S++prop_IsValid_Strict = runST $ do+    c <- newChoose 10 3+    setElem c 0 1+    valid <- isValid c+    setElem c 0 0+    return $ valid == False++tests_STChoose = +    [ ("newChoose"               , mytest prop_NewChoose)+    , ("newListChoose"           , mytest prop_NewListChoose)+    , ("newCopyChoose"           , mytest prop_NewCopyChoose)+    , ("setFirst"                , mytest prop_SetFirst)+    , ("getElem"                 , mytest prop_GetElem)+    , ("unsafeGetElem"           , mytest prop_UnsafeGetElem)+    , ("getPossible"             , mytest prop_GetPossible)+    , ("getSize"                 , mytest prop_GetSize)+    , ("getElems"                , mytest prop_GetElems)+    ]++smoke_STChoose =+    [ ("isValid is strict"             , mytest prop_IsValid_Strict)+    ]++------------------------------------------------------------------------+-- +-- The specification language+--+    +abstract :: STChoose s -> ST s Choose+abstract = freeze++commutes :: (Eq a, Show a) =>+    STChoose s -> (STChoose s -> ST s a) ->+        (Choose -> (a,Choose)) -> ST s Bool+commutes c a f = do+    old <- abstract c+    r   <- a c+    new <- abstract c+    let s      = f old+        s'     = (r,new)+        passed = s == s'+        +    when (not passed) $+        trace (printf ("expected `%s' but got `%s'") (show s) (show s'))+              return ()+              +    return passed++equivalent :: (forall s . ST s (STChoose s)) -> Choose -> Bool+equivalent c s = runST $ do+    c' <- (c >>= abstract)+    when (not $ c' == s) $+        trace (printf ("expected `%s' but got `%s'") (show s) (show c'))+            return ()+    return (c' == s)+    +implements :: (Eq a, Show a) =>+    (forall s . STChoose s -> ST s a) ->+    (Choose -> (a,Choose)) -> +        Property+a `implements` f =+    forAll arbitrary $ \(Nat n) ->+    forAll (QC.choose (0,n)) $ \k ->+        implementsFor n k a f++implementsFor :: (Eq a, Show a) =>+    Int -> Int ->+    (forall s . STChoose s -> ST s a) ->+    (Choose -> (a,Choose)) -> +        Property+implementsFor n k a f =+    forAll (Test.choose n k) $ \c ->+        runST $ do+            c' <- unsafeThaw c+            commutes c' a f++implementsIf :: (Eq a, Show a) =>+    (forall s . STChoose s -> ST s Bool) ->+    (forall s . STChoose s -> ST s a) ->+    (Choose -> (a, Choose)) -> +        Property+implementsIf pre a f =+    forAll arbitrary $ \c ->+        runST ( do+            c' <- thaw c+            pre c') ==>+        runST ( do+            c' <- unsafeThaw c+            commutes c' a f )++commutes2 :: (Eq a, Show a) =>+    STChoose s -> STChoose s -> (STChoose s -> STChoose s -> ST s a) ->+        (Choose -> Choose -> (a,Choose,Choose)) -> ST s Bool+commutes2 c1 c2 a f = do+    oldc1 <- abstract c1+    oldc2 <- abstract c2+    r   <- a c1 c2+    newc1 <- abstract c1+    newc2 <- abstract c2+    let s      = f oldc1 oldc2+        s'     = (r,newc1,newc2)+        passed = s == s'+        +    when (not passed) $+        trace (printf ("expected `%s' but got `%s'") (show s) (show s'))+              return ()+              +    return passed++implements2 :: (Eq a, Show a) =>+    (forall s . STChoose s -> STChoose s -> ST s a) ->+    (Choose -> Choose -> (a,Choose,Choose)) -> +        Property+implements2 a f =+    forAll arbitrary $ \(Nat n) ->+    forAll (QC.choose (0,n)) $ \k ->+    forAll (Test.choose n k) $ \c1 ->+    forAll (Test.choose n k) $ \c2 ->+        runST $ do+            c1' <- unsafeThaw c1+            c2' <- unsafeThaw c2+            commutes2 c1' c2' a f+

@@ -0,0 +1,231 @@+{-# LANGUAGE Rank2Types #-}+module STPermute (+    tests_STPermute,+    smoke_STPermute+    ) where+    +import Control.Monad+import Control.Monad.ST++import Data.Permute+import Data.Permute.ST+++import Driver+import Debug.Trace+import Test.QuickCheck+import Text.Printf+    +import Test.Permute()+import qualified Test.Permute as Test++newPermute_S n = permute n+prop_NewPermute (Nat n) = +    newPermute n `equivalent` newPermute_S n++newListPermute_S n is = listPermute n is+prop_NewListPermute (ListPermute n is) =+    newListPermute n is `equivalent` newListPermute_S n is++newSwapsPermute_S n ss = swapsPermute n ss+prop_NewSwapsPermute (SwapsPermute n ss) =+    newSwapsPermute n ss `equivalent` newSwapsPermute_S n ss+prop_UnsafeNewSwapsPermute (SwapsPermute n ss) =+    unsafeNewSwapsPermute n ss `equivalent` newSwapsPermute_S n ss++++newCopyPermute_S p = (p, p)+prop_NewCopyPermute =+    implements+        (\p -> newCopyPermute p >>= unsafeFreeze)+        (\p -> newCopyPermute_S p)++copyPermute_S p q = ((), q, q)+prop_CopyPermute =+    copyPermute `implements2` copyPermute_S++setIdentity_S p = ((), permute (size p))+prop_SetIdentity =+    setIdentity `implements` setIdentity_S ++getElem_S p i = ((elems p) !! i, p)+prop_GetElem (Index n i) =+    implementsFor n+        (\p -> getElem   p i)+        (\p -> getElem_S p i)++prop_UnsafeGetElem (Index n i) =+    implementsFor n+        (\p -> unsafeGetElem p i)+        (\p -> getElem_S p i)++swapElems_S p i j = ((), p')+  where+    (n,is) = (size p, elems p)+      +    at k | k == i    = is !! j+         | k == j    = is !! i+         | otherwise = is !! k+    p'   = listPermute n $ map at [0..(n-1)]++prop_SwapElems (Swap n i j) =+    implementsFor n+        (\p -> swapElems p i j) +        (\p -> swapElems_S p i j)++prop_UnsafeSwapElems (Swap n i j) =+    implementsFor n+        (\p -> unsafeSwapElems p i j) +        (\p -> swapElems_S p i j)+++getSize_S p = (length (elems p), p)+prop_GetSize = getSize `implements` getSize_S+      +getElems_S p = (elems p, p)+prop_GetElems = getElems `implements` getElems_S++prop_IsValid_Strict = runST $ do+    p <- newPermute 10+    setElem p 0 1+    valid <- isValid p+    setElem p 0 0+    return $ valid == False++prop_GetSwaps_Lazy1 = runST $ do+    p <- newPermute 10+    ss <- getSwaps p+    swapElems p 0 1+    return $ length ss == 1++prop_GetSwaps_Lazy2 = runST $ do+    p <- newPermute 10+    ss <- getSwaps p+    swapElems p 0 1+    swapElems p 3 4+    head ss `seq` swapElems p 3 4+    return $ length ss == 1++tests_STPermute = +    [ ("newPermute"               , mytest prop_NewPermute)+    , ("newListPermute"           , mytest prop_NewListPermute)+    , ("newSwapsPermute"          , mytest prop_NewSwapsPermute)+    , ("unsafeNewSwapsPermute"    , mytest prop_UnsafeNewSwapsPermute)+    , ("newCopyPermute"           , mytest prop_NewCopyPermute)+    , ("copyPermute"              , mytest prop_CopyPermute)+    , ("setIdentity"              , mytest prop_SetIdentity)+    , ("getElem"                  , mytest prop_GetElem)+    , ("unsafeGetElem"            , mytest prop_UnsafeGetElem)+    , ("swapElems"                , mytest prop_SwapElems)+    , ("unsafeSwapElems"          , mytest prop_UnsafeSwapElems)+    , ("getSize"                  , mytest prop_GetSize)+    , ("getElems"                 , mytest prop_GetElems)+    ]++smoke_STPermute =+    [ ("isValid is strict"             , mytest prop_IsValid_Strict)+    , ("getSwaps is lazy (test 1)"     , mytest prop_GetSwaps_Lazy1)+    , ("getSwaps is lazy (test 2)"     , mytest prop_GetSwaps_Lazy2)+    ]++------------------------------------------------------------------------+-- +-- The specification language+--+    +abstract :: STPermute s -> ST s Permute+abstract = freeze++commutes :: (Eq a, Show a) =>+    STPermute s -> (STPermute s -> ST s a) ->+        (Permute -> (a,Permute)) -> ST s Bool+commutes p a f = do+    old <- abstract p+    r   <- a p+    new <- abstract p+    let s      = f old+        s'     = (r,new)+        passed = s == s'+        +    when (not passed) $+        trace (printf ("expected `%s' but got `%s'") (show s) (show s'))+              return ()+              +    return passed++equivalent :: (forall s . ST s (STPermute s)) -> Permute -> Bool+equivalent p s = runST $ do+    p' <- (p >>= abstract)+    when (not $ p' == s) $+        trace (printf ("expected `%s' but got `%s'") (show s) (show p'))+            return ()+    return (p' == s)+    +implements :: (Eq a, Show a) =>+    (forall s . STPermute s -> ST s a) ->+    (Permute -> (a,Permute)) -> +        Property+a `implements` f =+    forAll arbitrary $ \(Nat n) ->+        implementsFor n a f++implementsFor :: (Eq a, Show a) =>+    Int ->+    (forall s . STPermute s -> ST s a) ->+    (Permute -> (a,Permute)) -> +        Property+implementsFor n a f =+    forAll (Test.permute n) $ \p ->+        runST $ do+            p' <- unsafeThaw p+            commutes p' a f++implementsIf :: (Eq a, Show a) =>+    (forall s . STPermute s -> ST s Bool) ->+    (forall s . STPermute s -> ST s a) ->+    (Permute -> (a, Permute)) -> +        Property+implementsIf pre a f =+    forAll arbitrary $ \p ->+        runST ( do+            p' <- thaw p+            pre p') ==>+        runST ( do+            p' <- unsafeThaw p+            commutes p' a f )+++commutes2 :: (Eq a, Show a) =>+    STPermute s -> STPermute s -> (STPermute s -> STPermute s -> ST s a) ->+        (Permute -> Permute -> (a,Permute,Permute)) -> ST s Bool+commutes2 p q a f = do+    oldp <- abstract p+    oldq <- abstract q+    r   <- a p q+    newp <- abstract p+    newq <- abstract q+    let s      = f oldp oldq+        s'     = (r,newp,newq)+        passed = s == s'+        +    when (not passed) $+        trace (printf ("expected `%s' but got `%s'") (show s) (show s'))+              return ()+              +    return passed+++implements2 :: (Eq a, Show a) =>+    (forall s . STPermute s -> STPermute s -> ST s a) ->+    (Permute -> Permute -> (a,Permute,Permute)) -> +        Property+implements2 a f =+    forAll arbitrary $ \(Nat n) ->+    forAll (Test.permute n) $ \p ->+    forAll (Test.permute n) $ \q ->+        runST $ do+            p' <- unsafeThaw p+            q' <- unsafeThaw q+            commutes2 p' q' a f+

@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Test.Choose+-- Copyright  : Copyright (c) , Patrick Perry <patperry@stanford.edu>+-- License    : BSD3+-- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Stability  : experimental+--++module Test.Choose (+    choose+    ) where++import Control.Monad( liftM )+import Data.Ord( comparing )+import Data.List( sort, sortBy )+import Test.QuickCheck hiding ( choose )+import qualified Test.QuickCheck as QC+import Data.Choose( Choose )+import qualified Data.Choose as C++-- | @choose n k@ generates a random combination of @k@ outcomes+-- from @n@ possibilities.+choose :: Int -> Int -> Gen Choose+choose n k = do+    xs <- vector n :: Gen [Int]+    let is = (snd . unzip) $ sortBy (comparing fst) $ zip xs [0..]+    return $ C.listChoose n k $ sort $ take k is++instance Arbitrary Choose where+    arbitrary = do+        n <- liftM abs arbitrary+        k <- QC.choose (0,n)+        c <- choose n k+        return c+        +    coarbitrary c =+        coarbitrary $ (C.possible c, C.size c, C.elems c)