sym 0.11.1 → 0.12.0
raw patch · 16 files changed
+573/−118 lines, 16 filesdep +symdep +vectordep ~base
Dependencies added: sym, vector
Dependency ranges changed: base
Files
- Sym/Internal/CLongArray.hs +25/−84
- Sym/Internal/SubSeq.hs +1/−1
- Sym/Perm.hs +5/−5
- Sym/Perm/Bijection.hs +1/−1
- Sym/Perm/Component.hs +7/−7
- Sym/Perm/Constructions.hs +1/−1
- Sym/Perm/D8.hs +1/−1
- Sym/Perm/Group.hs +1/−1
- Sym/Perm/MeshPattern.hs +3/−1
- Sym/Perm/Pattern.hs +1/−1
- Sym/Perm/SSYT.hs +3/−3
- Sym/Perm/Simple.hs +1/−1
- Sym/Perm/Sort.hs +1/−1
- Sym/Perm/Stat.hs +4/−4
- sym.cabal +14/−6
- tests/Properties.hs +504/−0
Sym/Internal/CLongArray.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}- -- |--- Copyright : Anders Claesson 2013+-- Copyright : Anders Claesson 2013-2016 -- Maintainer : Anders Claesson <anders.claesson@gmail.com> -- -- Convenience functions for dealing with arrays of 'CLong's.@@ -14,8 +12,7 @@ -- * Conversions , fromList , toList- , slice- , unsafeSlice+ , slices -- * Accessors , size@@ -33,31 +30,20 @@ ) where import Data.Ord+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as MV import Sym.Internal.Size import Foreign import Foreign.C.Types-import GHC.Base infixl 9 `at` infixl 9 `unsafeAt` -inlinePerformIO :: IO a -> a-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-{-# INLINE inlinePerformIO #-}-- -- Data type -- --------- -- | An array of 'CLong's-data CLongArray = CArr {-# UNPACK #-} !(ForeignPtr CLong) -- elements- {-# UNPACK #-} !Int -- size--instance Show CLongArray where- show w = "fromList " ++ show (toList w)--instance Eq CLongArray where- u == v = toList u == toList v+newtype CLongArray = CArr (V.Vector CLong) deriving (Show, Eq) instance Ord CLongArray where compare u v =@@ -66,7 +52,7 @@ x -> x instance Size CLongArray where- size (CArr _ n) = n+ size (CArr w) = V.length w {-# INLINE size #-} @@ -75,34 +61,18 @@ -- | Construct an array from a list of elements. fromList :: [Int] -> CLongArray-fromList xs = CArr p (length xs)- where- p = inlinePerformIO $ newForeignPtr finalizerFree =<< newArray (map fromIntegral xs)-{-# INLINE fromList #-}+fromList = CArr . V.fromList . map fromIntegral -- | The list of elements. toList :: CLongArray -> [Int]-toList w = map fromIntegral . inlinePerformIO . unsafeWith w $ peekArray (size w)-{-# INLINE toList #-}+toList (CArr w) = map fromIntegral $ V.toList w -- | Slice a 'CLongArray' into contiguous segments of the given -- sizes. Each segment size must be positive and they must sum to the -- size of the array.-slice :: [Int] -> CLongArray -> [CLongArray]-slice ks w- | any (<=0) ks = error "Sym.Internal.CLongArray.slice: zero or negative parts"- | sum ks /= size w = error "Sym.Internal.CLongArray.slice: parts doesn't sum to size of array"- | otherwise = unsafeSlice ks w---- | Like 'slice' but without range checking.-unsafeSlice :: [Int] -> CLongArray -> [CLongArray]-unsafeSlice parts w = inlinePerformIO . unsafeWith w $ go parts- where- go [] _ = return []- go (k:ks) p = do- vs <- go ks (advancePtr p k)- v <- unsafeNew k $ \q -> copyArray q p k- return (v:vs)+slices :: [Int] -> CLongArray -> [CLongArray]+slices [] _ = []+slices (k:ks) (CArr w) = let (u,v) = V.splitAt k w in CArr u : slices ks (CArr v) -- Accessors@@ -110,29 +80,19 @@ -- | @w \`at\` i@ is the value of @w@ at @i@, where @i@ is in @[0..size w-1]@. at :: CLongArray -> Int -> Int-at w i =- let n = size w- in if i < 0 || i >= n- then error $ "Sym.Internal.CLongArray.at: " ++ show i ++ " not in [0.." ++ show (n-1) ++ "]"- else unsafeAt w i-{-# INLINE at #-}+at (CArr w) i =+ case (V.!?) w i of+ Nothing -> error "Sym.Internal.CLongArray.at: out of range"+ Just j -> fromIntegral j -- | Like 'at' but without range checking. unsafeAt :: CLongArray -> Int -> Int-unsafeAt w = fromIntegral . inlinePerformIO . unsafeWith w . flip peekElemOff-{-# INLINE unsafeAt #-}+unsafeAt (CArr w) = fromIntegral . (V.!) w -- | The indices of all elements equal to the query element, in -- ascending order.-elemIndices :: CLong -> CLongArray -> [Int]-elemIndices x w = inlinePerformIO $ unsafeWith w (go 0)- where- n = size w- go i p- | i >= n = return []- | otherwise = do- y <- peek p- ([ i | y == x ] ++) `fmap` go (i+1) (advancePtr p 1)+elemIndices :: CLong -> CLongArray -> V.Vector Int+elemIndices x (CArr w) = V.elemIndices x w -- Map and Zip@@ -140,29 +100,11 @@ -- | Apply a function to every element of an array and its index. imap :: (Int -> CLong -> CLong) -> CLongArray -> CLongArray-imap f w = inlinePerformIO . unsafeWith w $ \p -> unsafeNew n (go 0 p)- where- n = size w- go i p q- | i >= n = return ()- | otherwise = do- x <- peek p- poke q (f i x)- go (i+1) (advancePtr p 1) (advancePtr q 1)+imap f (CArr w) = CArr (V.imap f w) -- | Apply a function to corresponding pairs of elements and their (shared) index. izipWith :: (Int -> CLong -> CLong -> CLong) -> CLongArray -> CLongArray -> CLongArray-izipWith f u v =- inlinePerformIO . unsafeWith u $ \p -> unsafeWith v $ \q -> unsafeNew n (go 0 p q)- where- n = min (size u) (size v)- go i p q r- | i >= n = return ()- | otherwise = do- x <- peek p- y <- peek q- poke r (f i x y)- go (i+1) (advancePtr p 1) (advancePtr q 1) (advancePtr r 1)+izipWith f (CArr u) (CArr v) = CArr (V.izipWith f u v) -- Low level functions -- -------------------@@ -171,13 +113,12 @@ -- an IO action. unsafeNew :: Int -> (Ptr CLong -> IO ()) -> IO CLongArray unsafeNew n act = do- q <- newForeignPtr finalizerFree =<< mallocArray n- withForeignPtr q act- return $ CArr q n-{-# INLINE unsafeNew #-}+ v <- V.unsafeFreeze =<< MV.unsafeNew n+ let (ptr, _) = V.unsafeToForeignPtr0 v+ withForeignPtr ptr act+ return $ CArr (V.unsafeFromForeignPtr0 ptr n) -- | Pass a pointer to the array to an IO action; the array may not be -- modified through the pointer. unsafeWith :: CLongArray -> (Ptr CLong -> IO a) -> IO a-unsafeWith (CArr p _) = withForeignPtr p-{-# INLINE unsafeWith #-}+unsafeWith (CArr w) = V.unsafeWith w
Sym/Internal/SubSeq.hs view
@@ -70,7 +70,7 @@ -- | @onesCLong m@ gives the indices whose bits are set in @m@. onesCLong :: CLong -> CLongArray-onesCLong m = unsafeDupablePerformIO . unsafeNew (popCount m) $ flip c_ones m+onesCLong m = unsafePerformIO . unsafeNew (popCount m) $ flip c_ones m -- | Lexicographically, the next integral number with the same Hamming weight. nextIntegral :: (Integral a, Bits a) => a -> a
Sym/Perm.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances #-} -- |--- Copyright : Anders Claesson 2013+-- Copyright : Anders Claesson 2013-2016 -- Maintainer : Anders Claesson <anders.claesson@gmail.com> -- -- Generating permutations: rank and unrank@@ -40,7 +40,7 @@ -- | The identity permutation. idperm :: Int -> Perm-idperm n = fromList [0..n-1]+idperm n = fromList [0 .. n-1] -- | The reverse of the identity permutation. ebb :: Int -> Perm@@ -52,7 +52,7 @@ -- E.g., @mkPerm \"baxa\" == fromList [2,0,3,1]@. mkPerm :: Ord a => [a] -> Perm mkPerm xs =- let sti ys = map snd . sort $ zip ys [ 0::Int .. ]+ let sti ys = map snd . sort $ zip ys [0::Int ..] in fromList $ (sti . sti) xs foreign import ccall unsafe "rank.h rank" c_rank@@ -64,7 +64,7 @@ rank :: Perm -> Integer rank w = let n = fromIntegral (size w)- in truncate . unsafeDupablePerformIO . unsafeWith w $ flip c_rank n+ in truncate . unsafePerformIO . unsafeWith w $ flip c_rank n {-# INLINE rank #-} foreign import ccall unsafe "rank.h unrank" c_unrank@@ -76,7 +76,7 @@ -- (2001) 281-284]. unrank :: Int -> Integer -> Perm unrank n r =- unsafeDupablePerformIO . unsafeNew n $ \ptr ->+ unsafePerformIO . unsafeNew n $ \ptr -> c_unrank ptr (fromIntegral n) (fromIntegral r) {-# INLINE unrank #-}
Sym/Perm/Bijection.hs view
@@ -24,7 +24,7 @@ marshal :: (Ptr CLong -> Ptr CLong -> CLong -> IO ()) -> Perm -> Perm marshal bij w =- unsafeDupablePerformIO . unsafeWith w $ \p -> do+ unsafePerformIO . unsafeWith w $ \p -> do let n = size w unsafeNew n $ \q -> bij q p (fromIntegral n) {-# INLINE marshal #-}
Sym/Perm/Component.hs view
@@ -1,5 +1,5 @@ -- |--- Copyright : Anders Claesson 2013+-- Copyright : Anders Claesson 2013-2016 -- Maintainer : Anders Claesson <anders.claesson@gmail.com> -- -- Components of permutations.@@ -23,7 +23,7 @@ -- Positions /i/ such that /max{ w[j] : j <= i } = i/. These positions -- mark the boundaries of components. comps :: Perm -> [Int]-comps w = unsafeDupablePerformIO . unsafeWith w $ go [] 0 0+comps w = unsafePerformIO . unsafeWith w $ go [] 0 0 where n = size w go ks m i p@@ -41,7 +41,7 @@ components w = let ds = 0 : map (+1) (comps w) ks = zipWith (-) (tail ds) ds- ws = unsafeSlice ks w+ ws = slices ks w in zipWith (\d v -> imap (\_ x -> x - fromIntegral d) v) ds ws -- | The list of skew components, also called minus components.@@ -58,19 +58,19 @@ -- | For each position, left-to-right, records the largest value seen -- thus far. leftMaxima :: Perm -> [Int]-leftMaxima w = reverse $ records (<) (toList w)+leftMaxima w = map fromIntegral . reverse $ records (<) (toList w) -- | For each position, left-to-right, records the smallest value seen -- thus far. leftMinima :: Perm -> [Int]-leftMinima w = reverse $ records (>) (toList w)+leftMinima w = map fromIntegral . reverse $ records (>) (toList w) -- | For each position, /right-to-left/, records the largest value seen -- thus far. rightMaxima :: Perm -> [Int]-rightMaxima w = records (<) (reverse (toList w))+rightMaxima w = map fromIntegral $ records (<) (reverse (toList w)) -- | For each position, /right-to-left/, records the smallest value seen -- thus far. rightMinima :: Perm -> [Int]-rightMinima w = records (>) (reverse (toList w))+rightMinima w = map fromIntegral $ records (>) (reverse (toList w))
Sym/Perm/Constructions.hs view
@@ -30,7 +30,7 @@ let k = size u l = size v v' = imap (\_ x -> x + fromIntegral k) v- in unsafeDupablePerformIO . unsafeNew (k+l) $ \p ->+ in unsafePerformIO . unsafeNew (k+l) $ \p -> let q = advancePtr p k in unsafeWith u $ \uPtr -> unsafeWith v' $ \vPtr -> do
Sym/Perm/D8.hs view
@@ -119,7 +119,7 @@ marshal :: (Ptr CLong -> Ptr CLong -> CLong -> IO ()) -> Perm -> Perm marshal op w =- unsafeDupablePerformIO . unsafeWith w $ \p -> do+ unsafePerformIO . unsafeWith w $ \p -> do let n = size w unsafeNew n $ \q -> op q p (fromIntegral n) {-# INLINE marshal #-}
Sym/Perm/Group.hs view
@@ -19,7 +19,7 @@ marshal :: (Ptr CLong -> Ptr CLong -> CLong -> Ptr CLong -> CLong -> IO ()) -> Perm -> Perm -> Perm marshal op u v =- unsafeDupablePerformIO $+ unsafePerformIO $ unsafeWith u $ \u' -> unsafeWith v $ \v' -> do let k = size u
Sym/Perm/MeshPattern.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE DeriveGeneric #-}+ -- |--- Copyright : Anders Claesson 2014+-- Copyright : Anders Claesson 2014-2016 -- Maintainer : Anders Claesson <anders.claesson@gmail.com> --
Sym/Perm/Pattern.hs view
@@ -39,7 +39,7 @@ ordiso :: Pattern -> Perm -> SubSeq -> Bool ordiso u v m = let k = fromIntegral (size u)- in unsafeDupablePerformIO $+ in unsafePerformIO $ unsafeWith u $ \u' -> unsafeWith v $ \v' -> unsafeWith m $ \m' ->
Sym/Perm/SSYT.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- |--- Copyright : Anders Claesson 2013+-- Copyright : Anders Claesson 2013-2016 -- Maintainer : Anders Claesson <anders.claesson@gmail.com> -- -- Data types for Semistandard Young Tableaux (SSYT) and functions for@@ -142,7 +142,7 @@ -- | The Robinson-Schensted algorithm. fromPerm :: Perm -> SSYTPair-fromPerm = fromGeneralizedPerm . zip [0..] . toList+fromPerm = fromGeneralizedPerm . zip [0..] . map fromIntegral . toList -- | The inverse of the Robinson-Schensted-Knuth algorithm. toGeneralizedPerm :: SSYTPair -> GeneralizedPerm@@ -153,4 +153,4 @@ -- | The inverse of the Robinson-Schensted algorithm. toPerm :: SSYTPair -> Perm-toPerm = fromList . map snd . toGeneralizedPerm+toPerm = fromList . map (fromIntegral . snd) . toGeneralizedPerm
Sym/Perm/Simple.hs view
@@ -20,6 +20,6 @@ -- | Is the permutation simple? simple :: Perm -> Bool-simple w = toBool . unsafeDupablePerformIO $+simple w = toBool . unsafePerformIO $ let n = fromIntegral (size w) in unsafeWith w $ \ptr -> return $ c_simple ptr n
Sym/Perm/Sort.hs view
@@ -24,7 +24,7 @@ marshal :: (Ptr CLong -> Ptr CLong -> CLong -> IO ()) -> Perm -> Perm marshal op w =- unsafeDupablePerformIO . unsafeWith w $ \p -> do+ unsafePerformIO . unsafeWith w $ \p -> do let n = size w unsafeNew n $ \q -> op q p (fromIntegral n) {-# INLINE marshal #-}
Sym/Perm/Stat.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- |--- Copyright : Anders Claesson 2013+-- Copyright : Anders Claesson 2013-2016 -- Maintainer : Anders Claesson <anders.claesson@gmail.com> -- -- Common permutation statistics. To avoid name clashes this module is@@ -56,7 +56,7 @@ marshal :: (Ptr CLong -> CLong -> CLong) -> Perm -> Int marshal f w =- fromIntegral . unsafeDupablePerformIO . unsafeWith w $ \p ->+ fromIntegral . unsafePerformIO . unsafeWith w $ \p -> return $ f p (fromIntegral (size w)) {-# INLINE marshal #-} @@ -210,13 +210,13 @@ -- | The first (left-most) element in the standardization. E.g., -- @head \"231\" = head (fromList [1,2,0]) = 1@. head :: Perm -> Int-head w | size w > 0 = w `unsafeAt` 0+head w | size w > 0 = fromIntegral (w `unsafeAt` 0) | otherwise = 0 -- | The last (right-most) element in the standardization. E.g., -- @last \"231\" = last (fromList [1,2,0]) = 0@. last :: Perm -> Int-last w | size w > 0 = w `unsafeAt` (size w - 1)+last w | size w > 0 = fromIntegral (w `unsafeAt` (size w - 1)) | otherwise = 0 -- | Length of the left-most increasing run: largest @i@ such that
sym.cabal view
@@ -1,5 +1,5 @@ name: sym-version: 0.11.1+version: 0.12.0 synopsis: Permutations, patterns, and statistics description: Definitions for permutations with an emphasis on permutation@@ -40,14 +40,13 @@ Sym.Internal.Size Sym.Internal.Util - build-depends: base >= 3 && <= 5,+ build-depends: base >=4.7 && <= 5,+ vector >=0.11, array >=0.4, hashable >=1.1,- containers,- QuickCheck >=2.5+ containers - ghc-prof-options: -auto-all- ghc-options: -Wall+ ghc-options: -Wall -O2 cc-options: -Wall c-sources: cbits/rank.c@@ -59,3 +58,12 @@ cbits/bit.c cbits/simple.c cbits/sortop.c++Test-Suite Props+ type: exitcode-stdio-1.0+ Main-is: Properties.hs+ hs-source-dirs: tests+ Build-depends: base >=4.7 && <= 5,+ sym,+ hashable >=1.1,+ QuickCheck >=2.5
+ tests/Properties.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Copyright : Anders Claesson 2013-2016+-- Maintainer : Anders Claesson <anders.claesson@gmail.com>+--++import qualified ListStat as LS+import Sym.Perm.Meta hiding (choose)+import qualified Sym.Perm.SSYT as Y+import qualified Sym.Perm.Pattern as P+import qualified Sym.Perm.Stat as S+import qualified Sym.Perm.D8 as D8+import Sym.Permgram (Permgram)+import qualified Sym.Permgram as PG+import Data.List+import Data.Hashable+import Control.Monad+import Test.QuickCheck++checkN :: Testable prop => Int -> prop -> IO Result+checkN n = quickCheckWithResult stdArgs {maxSuccess = n}++check :: Testable prop => prop -> IO ()+check p = checkN 1000 p >> return ()++--------------------------------------------------------------------------------+-- Generators+--------------------------------------------------------------------------------++lenRank :: Gen (Int, Integer)+lenRank = sized $ \m -> do+ n <- choose (0, m) -- length+ r <- choose (0, product [1..fromIntegral n] - 1) -- rank+ return (n, r)++instance Arbitrary Perm where+ arbitrary = uncurry unrank `liftM` lenRank++instance Arbitrary a => Arbitrary (Permgram a) where+ arbitrary = do+ (n, r) <- lenRank+ xs <- vector n+ return $ PG.permgram (unrank n r) xs++newtype GPerm = GPerm [(Int, Int)] deriving (Eq, Show)++instance Arbitrary GPerm where+ arbitrary = sized $ \m -> do+ n <- choose (0, m)+ xs <- vector n+ ys <- vector n+ return . GPerm . sort $ zip (map abs xs) (map abs ys)++newtype PFun = PFun (Int -> Permgram Int)++instance Show PFun where+ show (PFun f) = "[" ++ images ++ ", ..]"+ where+ images = intercalate ", " $ map (show . f) [0..2]++instance Arbitrary PFun where+ arbitrary = sized $ \m -> do+ salt <- arbitrary+ ws <- listOf1 arbitrary+ return . PFun $ \x -> cycle ws !! (hashWithSalt salt x `mod` (m+1))++--------------------------------------------------------------------------------+-- Properties for Data.Perm+--------------------------------------------------------------------------------++prop_length xs = size (fromList xs) == length (xs :: [Int])++prop_unrankRankId =+ forAll (resize 18 arbitrary) $ \w ->+ unrank (size w) (rank w) == w++prop_rankUnrankId =+ forAll (resize 18 lenRank) $ \(n,r) ->+ rank (unrank n r) == r++st :: Ord a => [a] -> [Int]+st = sti . sti where sti w = map snd . sort $ zip w [0::Int ..]++prop_mkPermToListSt xs = toList (mkPerm xs) == st (xs :: [Int])++prop_unsafeAt w = map (w `unsafeAt`) [0 .. size w - 1] == toList w++prop_perms = and [ sort (permutations [0..n-1]) == sort (map toList (perms n))+ | n <- [0..7]+ ]++prop_coeff_des =+ forAll (resize 7 arbitrary) $ \w ->+ let n = size w+ in n > 0 ==> fromEnum (w `at` 0 > w `at` (n-1))*(-1)^n == P.coeff S.des w++prop_coeff_lmax =+ forAll (resize 7 arbitrary) $ \w ->+ let n = size w+ in n > 0 ==> fromEnum (w `at` (n-1) == 0) * (-1)^(n-1) == P.coeff S.lmax w++-- prop_monoid_mempty1 w = mempty <> w == (w :: StPerm)+-- prop_monoid_mempty2 w = w <> mempty == (w :: StPerm)+-- prop_monoid_associative u v w = u <> (v <> w) == (u <> v) <> (w :: StPerm)++-- newtype S = S {unS :: StPerm} deriving (Eq, Show)++-- instance Arbitrary S where+-- arbitrary = liftM S arbitrary++-- instance Monoid S where+-- mempty = S $ Sym.fromVector SV.empty+-- mappend u v = S $ (Sym.\-\) (unS u) (unS v)++-- prop_monoid_mempty1_S w = mempty <> w == (w :: S)+-- prop_monoid_mempty2_S w = w <> mempty == (w :: S)+-- prop_monoid_associative_S u v w = u <> (v <> w) == (u <> v) <> (w :: S)++testsDataPerm =+ [ ("Data.Perm/length", check prop_length)+ , ("Data.Perm/unrankRankId", check prop_unrankRankId)+ , ("Data.Perm/rankUnrankId", check prop_rankUnrankId)+ , ("Data.Perm/mkPermToListSt", check prop_mkPermToListSt)+ , ("Data.Perm/unsafeAt", check prop_unsafeAt)+ , ("Data.Perm/perms", check prop_perms)+ , ("Data.Perm/coeff/des", check prop_coeff_des)+ , ("Data.Perm/coeff/lmax", check prop_coeff_lmax)+ ]++--------------------------------------------------------------------------------+-- Properties for Data.Permgram+--------------------------------------------------------------------------------++prop_monadLeftId (PFun f) x = (return x >>= f) == f x++prop_monadRightId w = (w >>= return) == (w :: Permgram Int)++prop_monadAssociativity =+ forAll (resize 7 arbitrary) $ \(PFun f) ->+ forAll (resize 7 arbitrary) $ \(PFun g) ->+ forAll (resize 9 arbitrary) $ \w ->+ ((w >>= f) >>= g) == (w >>= (\x -> f x >>= g))++testsDataPermgram =+ [ ("Data.Permgram/Monad/LeftId", check prop_monadLeftId)+ , ("Data.Permgram/Monad/RightId", check prop_monadRightId)+ , ("Data.Permgram/Monad/Associativity", check prop_monadAssociativity)+ ]++--------------------------------------------------------------------------------+-- Properties for Data.SSYT+--------------------------------------------------------------------------------++swap (x,y) = (y,x)++inverseGeneralizedPerm = sort . map swap++prop_RSK (GPerm w) = w == Y.toGeneralizedPerm (Y.fromGeneralizedPerm w)++prop_RSKInverse (GPerm w) = (p, q) == (s, r)+ where+ Y.SSYTPair p q = Y.fromGeneralizedPerm w+ Y.SSYTPair r s = Y.fromGeneralizedPerm $ inverseGeneralizedPerm w++prop_RS w = w == Y.toPerm (Y.fromPerm w)++prop_RSInverse w = (p, q) == (s, r)+ where+ Y.SSYTPair p q = Y.fromPerm w+ Y.SSYTPair r s = Y.fromPerm $ D8.inverse w++prop_RSfp w = S.fp v == length (filter odd (Y.shape (transpose q)))+ where+ Y.SSYTPair p _ = Y.fromPerm w+ v = Y.toPerm $ Y.SSYTPair p p -- Kludge to get an involution+ Y.SSYTPair _ q = Y.fromPerm v++testsDataSSYT =+ [ ("Data.SSYT/RSK/Bijection", check prop_RSK)+ , ("Data.SSYT/RSK/Inverse", check prop_RSKInverse)+ , ("Data.SSYT/RS/Bijection", check prop_RS)+ , ("Data.SSYT/RS/Inverse", check prop_RSInverse)+ , ("Data.SSYT/RS/fp", check prop_RSfp)+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm+--------------------------------------------------------------------------------++segments :: [a] -> [[a]]+segments [] = [[]]+segments (x:xs) = segments xs ++ map (x:) (inits xs)++nonEmptySegments :: [a] -> [[a]]+nonEmptySegments = drop 1 . segments++properSegments :: [a] -> [[a]]+properSegments xs = [ ys | ys@(_:_:_) <- init $ segments xs ]++properIntervals :: Ord a => [a] -> [[a]]+properIntervals xs = [ ys | ys <- yss, sort ys `elem` zss ]+ where+ yss = properSegments xs+ zss = properSegments $ sort xs++isSimple :: Ord a => [a] -> Bool+isSimple = null . properIntervals++prop_simple =+ forAll (resize 20 arbitrary) $ \w ->+ simple w == isSimple (toList w)++testsMathPerm =+ [ ("Math.Perm/simple", check prop_simple)+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm.Pattern+--------------------------------------------------------------------------------++prop_copiesSelf v = P.copiesOf v v == [fromList [0 .. size v - 1]]++prop_avoidersAvoid =+ forAll (resize 20 arbitrary) $ \ws ->+ forAll (resize 6 arbitrary) $ \ps ->+ all (`P.avoidsAll` ps) $ P.avoiders ps ws++prop_avoidersIdempotent =+ forAll (resize 18 arbitrary) $ \vs ->+ forAll (resize 5 arbitrary) $ \ps ->+ let ws = P.avoiders ps vs in ws == P.avoiders ps ws++prop_avoidersSpectrum =+ forAll (resize 3 arbitrary) $ \p ->+ let spec = [ length $ P.avoiders [p] (perms n) | n<-[0..6] ]+ in case size p of+ 0 -> spec == [0,0,0,0,0,0,0]+ 1 -> spec == [1,0,0,0,0,0,0]+ 2 -> spec == [1,1,1,1,1,1,1]+ 3 -> spec == [1,1,2,5,14,42,132]+ _ -> False++prop_minimaSmallest =+ forAll (resize 14 arbitrary) $ \ws ->+ let vs = P.minima ws+ in and [ not (w `P.avoidsAll` vs) | w <- ws ]++prop_minimaAntichain =+ forAll (resize 14 arbitrary) $ \ws ->+ let vs = P.minima ws in and [ v `P.avoidsAll` (vs \\ [v]) | v <- vs ]++prop_maximaAntichain =+ forAll (resize 12 arbitrary) $ \ws ->+ let vs = P.maxima ws+ in and [ v `P.avoidsAll` (vs \\ [v]) | v <- vs ]++testsMathPermPattern =+ [ ("Math.Perm.Pattern/copies/self", check prop_copiesSelf)+ , ("Math.Perm.Pattern/avoiders/avoid", check prop_avoidersAvoid)+ , ("Math.Perm.Pattern/avoiders/idempotent", check prop_avoidersIdempotent)+ , ("Math.Perm.Pattern/avoiders/spectrum", check prop_avoidersSpectrum)+ , ("Math.Perm.Pattern/minima/smallest", check prop_minimaSmallest)+ , ("Math.Perm.Pattern/minima/antichain", check prop_minimaAntichain)+ , ("Math.Perm.Pattern/maxima/antichain", check prop_maximaAntichain)+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm.D8+--------------------------------------------------------------------------------++prop_reverseDef u =+ let v = D8.reverse u+ n = size u+ in n > 0 ==> forAll (choose (0,n-1)) $ \i -> v `at` i == u `at` (n-1-i)++prop_reverseInvolutive w = D8.reverse (D8.reverse w) == w++prop_complementDef u =+ let v = D8.complement u+ n = size u+ in n > 0 ==> forAll (choose (0,n-1)) $ \i -> v `at` i == n - 1 - u `at` i++prop_complementInvolutive w = D8.complement (D8.complement w) == w++prop_inverseDef u =+ let v = D8.inverse u+ n = size u+ in n > 0 ==> forAll (choose (0,n-1)) $ \i -> v `at` (u `at` i) == i++prop_inverseInvolutive w = D8.inverse (D8.inverse w) == w++testsMathPermD8 =+ [ ("Math.Perm.D8/reverse/def", check prop_reverseDef)+ , ("Math.Perm.D8/reverse/involutive", check prop_reverseInvolutive)+ , ("Math.Perm.D8/complement/def", check prop_complementDef)+ , ("Math.Perm.D8/complement/involutive", check prop_complementInvolutive)+ , ("Math.Perm.D8/inverse/def", check prop_inverseDef)+ , ("Math.Perm.D8/inverse/involutive", check prop_inverseInvolutive)+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm.Group+--------------------------------------------------------------------------------++prop_act_id v =+ idperm (size v) `act` v == v++prop_act_associative u v w =+ (u `compose` v) `act` w == u `act` (v `act` w)++prop_compose_id_left v =+ idperm (size v) `compose` v == v++prop_compose_id_right v =+ v `compose` idperm (size v) == v++prop_compose_associative u v w =+ (u `compose` v) `compose` w == u `compose` (v `compose` w)++testsMathPermGroup =+ [ ("Math.Perm.Group/act/id", check prop_act_id)+ , ("Math.Perm.Group/act/associative", check prop_act_associative)+ , ("Math.Perm.Group/compose/id/left", check prop_compose_id_left)+ , ("Math.Perm.Group/compose/id/right", check prop_compose_id_right)+ , ("Math.Perm.Group/compose/associative", check prop_compose_associative)+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm.Bijection+--------------------------------------------------------------------------------++p123 = fromList [0,1,2]+p132 = fromList [0,2,1]++prop_simionSchmidt_avoid =+ forAll (resize 12 arbitrary) $ \w ->+ w `P.avoids` p123 ==> simionSchmidt w `P.avoids` p132++prop_simionSchmidt_avoid' =+ forAll (resize 12 arbitrary) $ \w ->+ w `P.avoids` p132 ==> simionSchmidt' w `P.avoids` p123++prop_simionSchmidt_id =+ forAll (resize 12 arbitrary) $ \w ->+ w `P.avoids` p123 ==> simionSchmidt' (simionSchmidt w) == w++prop_simionSchmidt_id' =+ forAll (resize 12 arbitrary) $ \w ->+ w `P.avoids` p132 ==> simionSchmidt (simionSchmidt' w) == w++testsMathPermBijection =+ [ ("Math.Perm.Bijection/simionSchmidt/avoid", check prop_simionSchmidt_avoid)+ , ("Math.Perm.Bijection/simionSchmidt'/avoid", check prop_simionSchmidt_avoid')+ , ("Math.Perm.Bijection/simionSchmidt/id", check prop_simionSchmidt_id)+ , ("Math.Perm.Bijection/simionSchmidt'/id", check prop_simionSchmidt_id')+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm.Sort+--------------------------------------------------------------------------------++-- The stack-sort operator+stack [] = []+stack xs = stack left ++ stack right ++ [n]+ where+ (left, n:right) = span ( < maximum xs) xs++-- The bubble-sort operator; i.e. one pass of the classical bubble+-- sort algorithm+bubble :: Ord a => [a] -> [a]+bubble = bub []+ where+ bub xs [] = reverse xs+ bub [] (y:ys) = bub [y] ys+ bub (x:xs) (y:ys)+ | x < y = bub (y:x:xs) ys+ | otherwise = bub (x:y:xs) ys++prop_stackDef w = stack (toList w) == toList (stackSort w)+prop_bubbleDef w = bubble (toList w) == toList (bubbleSort w)++prop_stackAv w =+ let basis = [fromList [1,2,0]]+ in (stackSort w == idperm (size w)) == w `P.avoidsAll` basis++prop_bubbleAv w =+ let basis = [fromList [1,2,0], fromList [2,1,0]]+ in (bubbleSort w == idperm (size w)) == w `P.avoidsAll` basis++testsMathPermSort =+ [ ("Math.Perm.Sort/stack/def", check prop_stackDef)+ , ("Math.Perm.Sort/bubble/def", check prop_bubbleDef)+ , ("Math.Perm.Sort/stack/Av", check prop_stackAv)+ , ("Math.Perm.Sort/bubble/Av", check prop_bubbleAv)+ ]++--------------------------------------------------------------------------------+-- Properties for Math.Perm.Stat+--------------------------------------------------------------------------------++statEq f g w = f w == g (toList w)++prop_asc = statEq S.asc LS.asc+prop_des = statEq S.des LS.des+prop_exc = statEq S.exc LS.exc+prop_fp = statEq S.fp LS.fp+prop_cyc = statEq S.cyc LS.cyc+prop_inv = statEq S.inv LS.inv+prop_maj = statEq S.maj LS.maj+prop_comaj = statEq S.comaj LS.comaj+prop_lmin = statEq S.lmin LS.lmin+prop_lmax = statEq S.lmax LS.lmax+prop_rmin = statEq S.rmin LS.rmin+prop_rmax = statEq S.rmax LS.rmax+prop_head w = size w > 0 ==> statEq S.head head w+prop_last w = size w > 0 ==> statEq S.last last w+prop_peak = statEq S.peak LS.peak+prop_vall = statEq S.vall LS.vall+prop_dasc = statEq S.dasc LS.dasc+prop_ddes = statEq S.ddes LS.ddes+prop_ep = statEq S.ep LS.ep+prop_lir = statEq S.lir LS.lir+prop_ldr = statEq S.ldr LS.ldr+prop_rir = statEq S.rir LS.rir+prop_rdr = statEq S.rdr LS.rdr+prop_comp = statEq S.comp LS.comp+prop_scomp = statEq S.scomp LS.scomp+prop_dim = statEq S.dim LS.dim+prop_asc0 = statEq S.asc0 LS.asc0+prop_des0 = statEq S.des0 LS.des0+prop_inv_21 = forAll (resize 17 arbitrary) $ \w ->+ let stat21 = length . P.copiesOf (fromList [1,0])+ in S.inv w == stat21 w+prop_lis_r w = S.lis w == S.lds (D8.reverse w)+prop_lis_c w = S.lis w == S.lds (D8.complement w)+prop_lis_i w = S.lis w == S.lis (D8.inverse w)+prop_lds_i w = S.lds w == S.lds (D8.inverse w)+prop_ErdosSzekeres w = n > 0 ==> S.lis w > m || S.lds w > m+ where+ n = size w+ m = floor . sqrt $ fromIntegral (n-1)++-- prop_shad = forAllPermEq (shad . ints) S.shad+++testsMathPermStat =+ [ ("Math.Perm.Stat/asc", check prop_asc)+ , ("Math.Perm.Stat/des", check prop_des)+ , ("Math.Perm.Stat/exc", check prop_exc)+ , ("Math.Perm.Stat/fp", check prop_fp)+ , ("Math.Perm.Stat/cyc", check prop_cyc)+ , ("Math.Perm.Stat/inv", check prop_inv)+ , ("Math.Perm.Stat/maj", check prop_maj)+ , ("Math.Perm.Stat/comaj", check prop_comaj)+ , ("Math.Perm.Stat/lmin", check prop_lmin)+ , ("Math.Perm.Stat/lmax", check prop_lmax)+ , ("Math.Perm.Stat/rmin", check prop_rmin)+ , ("Math.Perm.Stat/rmax", check prop_rmax)+ , ("Math.Perm.Stat/head", check prop_head)+ , ("Math.Perm.Stat/last", check prop_last)+ , ("Math.Perm.Stat/peak", check prop_peak)+ , ("Math.Perm.Stat/vall", check prop_vall)+ , ("Math.Perm.Stat/dasc", check prop_dasc)+ , ("Math.Perm.Stat/ddes", check prop_ddes)+ , ("Math.Perm.Stat/ep", check prop_ep)+ , ("Math.Perm.Stat/lir", check prop_lir)+ , ("Math.Perm.Stat/ldr", check prop_ldr)+ , ("Math.Perm.Stat/rir", check prop_rir)+ , ("Math.Perm.Stat/rdr", check prop_rdr)+ , ("Math.Perm.Stat/comp", check prop_comp)+ , ("Math.Perm.Stat/scomp", check prop_scomp)+ , ("Math.Perm.Stat/dim", check prop_dim)+ , ("Math.Perm.Stat/asc0", check prop_asc0)+ , ("Math.Perm.Stat/des0", check prop_des0)+ , ("Math.Perm.Stat/inv/21", check prop_inv_21)+ , ("Math.Perm.Stat/lis/r", check prop_lis_r)+ , ("Math.Perm.Stat/lis/c", check prop_lis_c)+ , ("Math.Perm.Stat/lis/i", check prop_lis_i)+ , ("Math.Perm.Stat/lds/i", check prop_lds_i)+ , ("Math.Perm.Stat/Erdös-Szekeres", check prop_ErdosSzekeres)+-- , ("shad", check prop_shad)+ ]++--------------------------------------------------------------------------------+-- Main+--------------------------------------------------------------------------------++tests = concat [+ testsDataPerm+ , testsDataPermgram+ , testsDataSSYT+ , testsMathPerm+ , testsMathPermPattern+ , testsMathPermD8+ , testsMathPermGroup+ , testsMathPermBijection+ , testsMathPermSort+ , testsMathPermStat+ ]++runTests = mapM_ (\(name, t) -> putStr (name ++ ":\t") >> t)++main = runTests tests