sym 0.6.1 → 0.8
raw patch · 8 files changed
+518/−275 lines, 8 filesdep +containers
Dependencies added: containers
Files
- Math/Sym.hs +186/−71
- Math/Sym/Bijection.hs +24/−0
- Math/Sym/Class.hs +39/−8
- Math/Sym/D8.hs +4/−4
- Math/Sym/Internal.hs +86/−48
- Math/Sym/Stat.hs +30/−30
- sym.cabal +5/−2
- tests/Properties.hs +144/−112
Math/Sym.hs view
@@ -21,22 +21,27 @@ -- * The permutation typeclass , Perm (..)+ , CharPerm (..)+ , IntPerm (..) + -- * IntMaps as permutations+ , Perm2 (..)+ -- * Convenience functions , empty , one , toVector , fromVector , bijection- , generalize- , generalize2+ , lift+ , lift2 , normalize , cast -- * Constructions- , (\+\)+ , (/+/) , dsum- , (/-/)+ , (\-\) , ssum , inflate @@ -50,9 +55,8 @@ , bubbleSort -- * Permutation patterns- , copiesOf- , avoids- , avoiders+ , Pattern (..)+ , stat , av , permClass @@ -64,6 +68,7 @@ , coshadow , minima , maxima+ , coeff -- * Left-to-right maxima and similar functions , lMaxima@@ -86,14 +91,20 @@ import Control.Monad (liftM) import Data.Ord (comparing) import Data.Char (ord)+import Data.String (IsString(..)) import Data.Monoid (Monoid(..),(<>)) import Data.Bits (Bits, bitSize, testBit, popCount, shiftL) import Data.List (sort, sortBy, group) import Data.Vector.Storable (Vector)+import Data.IntMap (IntMap, (!))+import qualified Data.IntMap as M+ ( empty, size, elems, fromDistinctAscList, insert+ ) import qualified Data.Vector.Storable as SV ( (!), toList, fromList, fromListN, empty, singleton , length, map, concat, splitAt )+import Math.Sym.Internal (Perm0) import qualified Math.Sym.Internal as I import Foreign.C.Types (CUInt(..)) @@ -103,7 +114,7 @@ -- | By a /standard permutation/ we shall mean a permutations of -- @[0..k-1]@.-newtype StPerm = StPerm { perm0 :: I.Perm0 } deriving Eq+newtype StPerm = StPerm { perm0 :: Perm0 } deriving Eq instance Ord StPerm where compare u v = case comparing size u v of@@ -138,11 +149,10 @@ -- The permutation typeclass -- ------------------------- --- | The class of permutations. Minimal complete definition: 'st'--- 'act' and 'idperm'. The default implementations of 'size' and--- 'neutralize' can be somewhat slow, so you may want to implement--- them as well.-class Perm a where+-- | The class of permutations. Minimal complete definition: 'st',+-- 'act' and 'idperm'. The default implementation of 'size' can be+-- somewhat slow, so you may want to implement it as well.+class Ord a => Perm a where -- | The standardization map. If there is an underlying linear -- order on @a@ then @st@ is determined by the unique order@@ -157,8 +167,9 @@ -- | A (left) /group action/ of 'StPerm' on @a@. As for any group -- action it should hold that -- - -- > (u `act` v) `act` w == u `act` (v `act` w) && neutralize u `act` v == v+ -- > (u `act` v) `act` w == u `act` (v `act` w) && idperm n `act` v == v -- + -- where @v,w::a@ and @u::StPerm@ are of size @n@. act :: StPerm -> a -> a -- | The size of a permutation. The default implementation derived from@@ -243,21 +254,80 @@ | 'A' <= c && c <= 'Z' = ord c - ord 'A' + 9 | otherwise = ord c - ord 'a' + 35 +idpermString :: Int -> String+idpermString n = take n $ ['1'..'9'] ++ ['A'..'Z'] ++ ['a'..]++-- | A String viewed as a permutation of its characters. The alphabet+-- is ordered as+-- +-- > ['1'..'9'] ++ ['A'..'Z'] ++ ['a'..]+-- +newtype CharPerm = CharPerm { chars :: String } deriving Eq++instance Show CharPerm where+ show w = "CharPerm " ++ show (chars w)++instance Ord CharPerm where+ compare u v = compare (st u) (st v)++instance IsString CharPerm where+ fromString = CharPerm++instance Perm CharPerm where+ st = stString . chars+ act v = CharPerm . actL v . chars+ inverse v = CharPerm $ act' (chars v) (idpermString (size v))+ size = length . chars+ idperm = CharPerm . idpermString++-- For ghci convenience we also define a String instance of Perm instance Perm String where- st = stString- act = actL- inverse v = act' v (idperm (size v))- size = length- idperm n = take n $ ['1'..'9'] ++ ['A'..'Z'] ++ ['a'..]+ st = st . CharPerm+ act v = chars . act v . CharPerm+ idperm = chars . idperm -instance Perm [Int] where- st = fromList . map (+(-1))- act = actL- inverse v = act' v (idperm (size v))- size = length- idperm n = [1..n]+-- | A list of integers viewed as a permutation.+newtype IntPerm = IntPerm { ints :: [Int] } deriving Eq +instance Show IntPerm where+ show w = "IntPerm " ++ show (ints w) +instance Ord IntPerm where+ compare u v = compare (st u) (st v)++instance Perm IntPerm where+ st = fromList . map (+(-1)) . ints+ act v = IntPerm . actL v . ints+ inverse v = IntPerm $ act' (ints v) [1 .. size v]+ size = length . ints+ idperm n = IntPerm [1..n]+++-- IntMaps as permutations+-- -----------------------++-- | Type alias for @IntMap Int@. This can be thought of as a+-- permutations in two line notation.+newtype Perm2 = Perm2 { intmap :: IntMap Int } deriving Eq++instance Show Perm2 where+ show w = "Perm2 (" ++ show (intmap w) ++ ")"++instance Ord Perm2 where+ compare u v = compare (st u) (st v)++instance Perm Perm2 where+ st = st . IntPerm . M.elems . intmap+ size = M.size . intmap+ idperm n = Perm2 $ M.fromDistinctAscList [ (i,i) | i <- [1..n] ]++ u `act` v = Perm2 $ foldr (\i -> M.insert (1 + (SV.!) u' i) (v'!(i+1))) M.empty [0..n-1]+ where+ u' = toVector u+ v' = intmap v+ n = SV.length u'++ -- Convenience functions -- --------------------- @@ -283,27 +353,27 @@ bijection :: Perm a => a -> Int -> Int bijection w = (SV.!) v where v = toVector w +-- | Lift a function on 'Vector Int' to a function on any permutations:+-- +-- > lift f = fromVector . f . toVector+-- lift :: (Perm a, Perm b) => (Vector Int -> Vector Int) -> a -> b lift f = fromVector . f . toVector +-- | Like 'lift' but for functions of two variables lift2 :: (Perm a, Perm b, Perm c) => (Vector Int -> Vector Int -> Vector Int) -> a -> b -> c lift2 f u v = fromVector $ f (toVector u) (toVector v) --- | Generalize a function on 'StPerm' to a function on any permutations:--- --- > generalize f = unst . f . st--- generalize :: (Perm a, Perm b) => (StPerm -> StPerm) -> a -> b generalize f = unst . f . st --- | Like 'generalize' but for functions of two variables generalize2 :: (Perm a, Perm b, Perm c) => (StPerm -> StPerm -> StPerm) -> a -> b -> c generalize2 f u v = unst $ f (st u) (st v) -- | Sort a list of permutations with respect to the standardization -- and remove duplicates-normalize :: (Ord a, Perm a) => [a] -> [a]+normalize :: Perm a => [a] -> [a] normalize = map (unst . head) . group . sort . map st -- | Cast a permutation of one type to another@@ -314,24 +384,24 @@ -- Constructions -- ------------- -infixl 6 \+\-infixl 6 /-/+infixl 6 /+/+infixl 6 \-\ -- | The /direct sum/ of two permutations.-(\+\) :: Perm a => a -> a -> a-(\+\) = generalize2 (<>)+(/+/) :: Perm a => a -> a -> a+(/+/) = generalize2 (<>) -- | The direct sum of a list of permutations. dsum :: Perm a => [a] -> a-dsum = foldr (\+\) empty+dsum = foldr (/+/) empty -- | The /skew sum/ of two permutations.-(/-/) :: Perm a => a -> a -> a-(/-/) = lift2 $ \u v -> SV.concat [SV.map ( + SV.length v) u, v]+(\-\) :: Perm a => a -> a -> a+(\-\) = lift2 $ \u v -> SV.concat [SV.map ( + SV.length v) u, v] -- | The skew sum of a list of permutations. ssum :: Perm a => [a] -> a-ssum = foldr (/-/) empty+ssum = foldr (\-\) empty -- | @inflate w vs@ is the /inflation/ of @w@ by @vs@. It is the -- permutation of length @sum (map size vs)@ obtained by replacing@@ -339,8 +409,8 @@ -- in such a way that the intervals are order isomorphic to @w@. In -- particular, -- --- > u \+\ v == inflate "12" [u,v]--- > u /-/ v == inflate "21" [u,v]+-- > u /+/ v == inflate "12" [u,v]+-- > u \-\ v == inflate "21" [u,v] -- inflate :: (Perm a, Perm b) => b -> [a] -> a inflate w vs = lift (\v -> I.inflate v (map toVector vs)) w@@ -384,37 +454,66 @@ -- Permutation patterns -- -------------------- --- | @copiesOf p w@ is the list of (indices of) copies of the pattern--- @p@ in the permutation @w@. E.g.,--- --- > copiesOf "21" "2431" == [fromList [1,2],fromList [0,3],fromList [1,3],fromList [2,3]]--- -copiesOf :: (Perm a, Perm b) => b -> a -> [Set]-copiesOf p w = I.copies subsets (toVector p) (toVector w)+-- | All methods of the Pattern typeclass have default+-- implementations. This is because any permutation can also be seen+-- as a pattern. If you want to override the default implementation+-- you should at least define 'copiesOf'.+class Perm a => Pattern a where+ -- | @copiesOf p w@ is the list of indices of copies of the pattern+ -- @p@ in the permutation @w@. E.g.,+ -- + -- > copiesOf "21" "2431" == [fromList [1,2],fromList [0,3],fromList [1,3],fromList [2,3]]+ -- + copiesOf :: Perm b => a -> b -> [Set]+ copiesOf p w = I.copies subsets (toVector p) (toVector w) --- | @avoids w ps@ is a predicate determining if @w@ avoids the patterns @ps@.-avoids :: (Perm a, Perm b) => a -> [b] -> Bool-w `avoids` ps = all null [ copiesOf p w | p <- ps ]+ -- | @w `contains` p@ is a predicate determining if @w@ contains the pattern @p@.+ contains :: Perm b => b -> a -> Bool+ w `contains` p = not $ w `avoids` p --- | @avoiders ps vs@ is the list of permutations in @vs@ avoiding the--- patterns @ps@. This is equivalent to the definition+ -- | @w `avoids` p@ is a predicate determining if @w@ avoids the pattern @p@.+ avoids :: Perm b => b -> a -> Bool+ w `avoids` p = null $ copiesOf p w++ -- | @w `avoidsAll` ps@ is a predicate determining if @w@ avoids the patterns @ps@.+ avoidsAll :: Perm b => b -> [a] -> Bool+ w `avoidsAll` ps = all (w `avoids`) ps++ -- | @avoiders ps vs@ is the list of permutations in @vs@ avoiding the+ -- patterns @ps@. The default definition is+ -- + -- > avoiders ps = filter (`avoidsAll` ps)+ -- + avoiders :: Perm b => [a] -> [b] -> [b]+ avoiders ps = filter (`avoidsAll` ps)++instance Pattern StPerm where+ avoiders ps = I.avoiders subsets toVector (map toVector ps)++instance Pattern String+instance Pattern CharPerm+instance Pattern IntPerm+instance Pattern Perm2+++-- | @stat p@ is the pattern @p@ when regarded as a statistic/function+-- counting copies of itself: -- --- > avoiders ps = filter (`avoids` ps)+-- > stat p = length . copiesOf p -- --- but is usually much faster.-avoiders :: (Perm a, Perm b) => [b] -> [a] -> [a]-avoiders ps = I.avoiders subsets toVector (map toVector ps)+stat :: (Pattern a, Perm b) => a -> b -> Int+stat p = length . copiesOf p -- | @av ps n@ is the list of permutations of @[0..n-1]@ avoiding the -- patterns @ps@. E.g., -- -- > map (length . av ["132","321"]) [1..8] == [1,2,4,7,11,16,22,29] -- -av :: Perm a => [a] -> Int -> [StPerm]+av :: Pattern a => [a] -> Int -> [StPerm] av ps = avoiders ps . sym -- | Like 'av' but the return type is any set of permutations.-permClass :: (Perm a, Perm b) => [a] -> Int -> [b]+permClass :: (Pattern a, Perm b) => [a] -> Int -> [b] permClass ps = avoiders ps . perms @@ -426,41 +525,57 @@ del i = lift $ I.del i -- | The list of all single point deletions-shadow :: (Ord a, Perm a) => [a] -> [a]+shadow :: Perm a => [a] -> [a] shadow ws = normalize [ del i w | w <- ws, i <- [0 .. size w - 1] ] -- | The list of permutations that are contained in at least one of -- the given permutaions-downset :: (Ord a, Perm a) => [a] -> [a]+downset :: Perm a => [a] -> [a] downset = normalize . concat . downset' where downset' [] = [] downset' ws = ws : downset' (shadow ws) --- | Extend a permutation by inserting a new largest element at the--- given position-ext :: Perm a => Int -> a -> a-ext i = lift $ \w ->+-- | @ext i j w@ extends @w@ by inserting a new element of+-- (relative) size @j@ at position @i@. It should hold that+-- @0 <= i,j <= size w@.+ext :: Perm a => Int -> Int -> a -> a+ext i j = lift $ \w -> let (u,v) = SV.splitAt i w- in SV.concat [u, SV.singleton (SV.length w), v]+ f x = if x < j then x else x+1+ in SV.concat [SV.map f u, SV.singleton j, SV.map f v] -- | The list of all single point extensions-coshadow :: (Ord a, Perm a) => [a] -> [a]-coshadow ws = normalize [ ext i w | w <- ws, i <- [0 .. size w] ]+coshadow :: Perm a => [a] -> [a]+coshadow ws = normalize [ ext i j w | w <- ws, let n = size w, i <- [0..n], j <- [0..n] ] -- | The set of minimal elements with respect to containment.-minima :: (Ord a, Perm a) => [a] -> [a]+minima :: Pattern a => [a] -> [a] minima [] = [] minima ws = v : minima (avoiders [v] vs) where (v:vs) = normalize ws -- | The set of maximal elements with respect to containment.-maxima :: (Ord a, Perm a) => [a] -> [a]+maxima :: Pattern a => [a] -> [a] maxima [] = []-maxima ws = v : maxima [ u | u <- vs, v `avoids` [u] ]+maxima ws = v : maxima [ u | u <- vs, v `avoids` u ] where (v:vs) = reverse $ normalize ws++-- | @coeff f v@ is the coefficient of @v@ when expanding the+-- permutation statistic @f@ as a sum of permutations/patterns. See+-- Petter Brändén and Anders Claesson: Mesh patterns and the expansion+-- of permutation statistics as sums of permutation patterns, The+-- Electronic Journal of Combinatorics 18(2) (2011),+-- <http://www.combinatorics.org/ojs/index.php/eljc/article/view/v18i2p5>.+coeff :: Pattern a => (a -> Int) -> a -> Int+coeff f v = f v + sum [ (-1)^(k - j) * c * f u |+ j <- [0 .. k-1]+ , u <- perms j+ , let c = length $ copiesOf u v+ , c > 0+ ] where k = size v -- Left-to-right maxima and similar functions
+ Math/Sym/Bijection.hs view
@@ -0,0 +1,24 @@+-- |+-- Module : Math.Sym.Bijection+-- Copyright : (c) Anders Claesson 2013+-- License : BSD-style+-- Maintainer : Anders Claesson <anders.claesson@gmail.com>+-- +-- Bijections++module Math.Sym.Bijection+ (+ simionSchmidt, simionSchmidt'+ ) where++import qualified Math.Sym.Internal as I (simionSchmidt, simionSchmidt')+import Math.Sym (Perm, lift)++-- | The Simion-Schmidt bijection from Av(123) onto Av(132).+simionSchmidt :: Perm a => a -> a+simionSchmidt = lift I.simionSchmidt++-- | The inverse of the Simion-Schmidt bijection. It is a function+-- from Av(132) to Av(123).+simionSchmidt' :: Perm a => a -> a+simionSchmidt' = lift I.simionSchmidt'
Math/Sym/Class.hs view
@@ -10,12 +10,35 @@ module Math.Sym.Class (- av231, vee, caret, gt, lt, wedges, separables+ inc, dec+ , av123, av132, av213, av231, av312, av321+ , vee, caret, gt, lt, wedges, separables ) where -import Math.Sym (Perm, empty, one, (\+\), (/-/), ssum, normalize)-import Math.Sym.D8 as D8+import Math.Sym (Perm, empty, one, idperm, (/+/), (\-\), ssum, normalize)+import Math.Sym.Bijection (simionSchmidt')+import qualified Math.Sym.D8 as D8 +-- | The class of increasing permutations.+inc :: Perm a => Int -> [a]+inc n = [idperm n]++-- | The class of decreasing permutations.+dec :: Perm a => Int -> [a]+dec n = [D8.complement (idperm n)]++-- | Av(123).+av123 :: Perm a => Int -> [a]+av123 = map simionSchmidt' . av132++-- | Av(132).+av132 :: Perm a => Int -> [a]+av132 = map D8.reverse . av231++-- | Av(213).+av213 :: Perm a => Int -> [a]+av213 = map D8.complement . av231+ -- | Av(231); also know as the stack sortable permutations. av231 :: Perm a => Int -> [a] av231 0 = [empty]@@ -23,11 +46,19 @@ k <- [0..n-1] s <- streamAv231 !! k t <- streamAv231 !! (n-k-1)- return $ s \+\ (one /-/ t)+ return $ s /+/ (one \-\ t) streamAv231 :: Perm a => [[a]] streamAv231 = map av231 [0..] +-- | Av(312).+av312 :: Perm a => Int -> [a]+av312 = map D8.reverse . av213++-- | Av(321).+av321 :: Perm a => Int -> [a]+av321 = map D8.complement . av123+ -- | The V-class is Av(132, 231). It is so named because the diagram -- of a typical permutation in this class is shaped like a V. vee :: Perm a => Int -> [a]@@ -36,8 +67,8 @@ streamVee :: Perm a => [[a]] streamVee = [empty] : [one] : zipWith (++) vee_n n_vee where- n_vee = (map.map) (one /-/) ws- vee_n = (map.map) (\+\ one) ws+ n_vee = (map.map) (one \-\) ws+ vee_n = (map.map) (/+/ one) ws ws = tail streamVee -- | The ∧-class is Av(213, 312). It is so named because the diagram@@ -55,11 +86,11 @@ lt :: Perm a => Int -> [a] lt = map D8.reverse . gt -union :: (Ord a, Perm a) => [Int -> [a]] -> Int -> [a]+union :: Perm a => [Int -> [a]] -> Int -> [a] union cs n = normalize $ concat [ c n | c <- cs ] -- | The union of 'vee', 'caret', 'gt' and 'lt'.-wedges :: (Ord a, Perm a) => Int -> [a]+wedges :: Perm a => Int -> [a] wedges = union [vee, caret, gt, lt] compositions :: Int -> Int -> [[Int]]
Math/Sym/D8.hs view
@@ -99,12 +99,12 @@ -- -- > orbit klein4 "2314" == ["1423","2314","3241","4132"] -- -orbit :: (Ord a, Perm a) => [a -> a] -> a -> [a]+orbit :: Perm a => [a -> a] -> a -> [a] orbit fs x = normalize [ f x | f <- fs ] -- | @symmetryClasses fs xs@ is the list of equivalence classes under -- the action of the /group/ of functions @fs@.-symmetryClasses :: (Ord a, Perm a) => [a -> a] -> [a] -> [[a]]+symmetryClasses :: Perm a => [a -> a] -> [a] -> [[a]] symmetryClasses _ [] = [] symmetryClasses fs xs@(x:xt) = insert orb $ symmetryClasses fs ys where@@ -112,11 +112,11 @@ ys = [ y | y <- xt, y `notElem` orb ] -- | Symmetry classes with respect to D8.-d8Classes :: (Ord a, Perm a) => [a] -> [[a]]+d8Classes :: Perm a => [a] -> [[a]] d8Classes = symmetryClasses d8 -- | Symmetry classes with respect to Klein4-klein4Classes :: (Ord a, Perm a) => [a] -> [[a]]+klein4Classes :: Perm a => [a] -> [[a]] klein4Classes = symmetryClasses klein4
Math/Sym/Internal.hs view
@@ -98,6 +98,10 @@ -- * Single point deletions , del + -- * Bijections+ , simionSchmidt+ , simionSchmidt'+ -- * Bitmasks , onesCUInt , nextCUInt@@ -108,12 +112,16 @@ import Prelude hiding (reverse, head, last) import qualified Prelude (head) import System.Random (getStdRandom, randomR)-import Control.Monad (forM_, liftM)+import Control.Monad (forM_, foldM, foldM_, liftM) import Control.Monad.ST (runST) import Data.List (group, sort) import Data.Bits (Bits, shiftR, (.|.), (.&.), popCount)+import qualified Data.IntSet as Set+ ( empty, insert, delete, notMember, findMax, fromDistinctAscList+ )+import Data.Vector.Storable ((!)) import qualified Data.Vector.Storable as SV- ( Vector, toList, fromList, length, (!), thaw, concat+ ( Vector, toList, fromList, length, thaw, concat , unsafeFreeze, unsafeWith, enumFromN, enumFromStepN , head, last, filter, maximum, minimum, null, reverse, map )@@ -141,15 +149,14 @@ unrankLehmercode :: Int -> Integer -> Lehmercode unrankLehmercode n rank = runST $ do v <- MV.unsafeNew n- iter v n rank (toInteger n)+ foldM_ iter (v, rank, toInteger n) [0..n-1] SV.unsafeFreeze v where {-# INLINE iter #-}- iter _ 0 _ _ = return ()- iter v i r m = do+ iter (v,r,m) i = do let (r',j) = quotRem r m- MV.unsafeWrite v (n-i) (fromIntegral j)- iter v (i-1) r' (m-1)+ MV.unsafeWrite v i $ fromIntegral j+ return (v,r',m-1) -- | Build a permutation from its Lehmercode. fromLehmercode :: Lehmercode -> Perm0@@ -157,7 +164,7 @@ let n = SV.length code v <- MV.unsafeNew n forM_ [0..n-1] $ \i -> MV.unsafeWrite v i i- forM_ [0..n-1] $ \i -> MV.swap v i (i + (SV.!) code i)+ forM_ [0..n-1] $ \i -> MV.swap v i (i + code ! i) SV.unsafeFreeze v -- | A random Lehmercode of the given length.@@ -184,12 +191,12 @@ fromList :: [Int] -> Perm0 fromList = SV.fromList --- | @act u v@ is the permutation /w/ defined by /w(u(i)) = v(i)/.+-- | @u `act` v@ is the permutation /w/ defined by /w(u(i)) = v(i)/. act :: Perm0 -> Perm0 -> Perm0 act u v = runST $ do- let n = SV.length u+ let n = size u w <- MV.unsafeNew n- forM_ [0..n-1] $ \i -> MV.unsafeWrite w i ((SV.!) v ((SV.!) u i))+ forM_ [0..n-1] $ \i -> MV.unsafeWrite w i (v ! (u ! i)) SV.unsafeFreeze w -- | @inflate w vs@ is the /inflation/ of @w@ by @vs@.@@ -230,9 +237,9 @@ sti w = runST $ do let a = if SV.null w then 0 else SV.minimum w let b = if SV.null w then 0 else SV.maximum w- let n = SV.length w+ let n = size w v <- MV.replicate (1 + b - a) (-1)- forM_ [0..n-1] $ \i -> MV.unsafeWrite v ((SV.!) w i - a) i+ forM_ [0..n-1] $ \i -> MV.unsafeWrite v (w ! i - a) i SV.filter (>=0) `liftM` SV.unsafeFreeze v -- | The standardization map.@@ -246,7 +253,7 @@ -- @m@ is order isomorphic to @u@. ordiso :: Perm0 -> Perm0 -> SV.Vector Int -> Bool ordiso u v m =- let k = fromIntegral (SV.length u)+ let k = fromIntegral (size u) in unsafePerformIO $ SV.unsafeWith u $ \u' -> SV.unsafeWith v $ \v' ->@@ -259,7 +266,7 @@ -- | @simple w@ determines whether @w@ is simple simple :: Perm0 -> Bool simple w =- let n = fromIntegral (SV.length w)+ let n = fromIntegral (size w) in unsafePerformIO $ SV.unsafeWith w $ \w' -> return . toBool $ c_simple (castPtr w') n@@ -268,8 +275,8 @@ copies :: (Int -> Int -> [SV.Vector Int]) -> Perm0 -> Perm0 -> [SV.Vector Int] copies subsets p w = filter (ordiso p w) $ subsets n k where- n = SV.length w- k = SV.length p+ n = size w+ k = size p avoiders1 :: (Int -> Int -> [SV.Vector Int]) -> (a -> Perm0) -> Perm0 -> [a] -> [a] avoiders1 subsets f p ws =@@ -277,7 +284,7 @@ ws2 = zip ws0 ws in case group (map SV.length ws0) of [] -> []- [_] -> let k = SV.length p+ [_] -> let k = size p n = SV.length (Prelude.head ws0) in [ v | (v0,v) <- ws2, not $ any (ordiso p v0) (subsets n k) ] _ -> [ v | (v0,v) <- ws2, null $ copies subsets p v0 ] @@ -300,24 +307,24 @@ -- | @complement \<a_1,...,a_n\> == \<b_1,,...,b_n\>@, where @b_i = n - a_i - 1@. -- E.g., @complement \<3,4,0,1,2\> == \<1,0,4,3,2\>@. complement :: Perm0 -> Perm0-complement w = SV.map (\x -> SV.length w - x - 1) w+complement w = SV.map (\x -> size w - x - 1) w -- | @inverse w@ is the group theoretical inverse of @w@. E.g., -- @inverse \<1,2,0\> == \<2,0,1\>@. inverse :: Perm0 -> Perm0 inverse w = runST $ do- let n = SV.length w+ let n = size w v <- MV.unsafeNew n- forM_ [0..n-1] $ \i -> MV.unsafeWrite v ((SV.!) w i) i+ forM_ [0..n-1] $ \i -> MV.unsafeWrite v (w ! i) i SV.unsafeFreeze v -- | The clockwise rotatation through 90 degrees. E.g., -- @rotate \<1,0,2\> == \<1,2,0\>@. rotate :: Perm0 -> Perm0 rotate w = runST $ do- let n = SV.length w+ let n = size w v <- MV.unsafeNew n- forM_ [0..n-1] $ \i -> MV.unsafeWrite v ((SV.!) w (n-1-i)) i+ forM_ [0..n-1] $ \i -> MV.unsafeWrite v (w ! (n-1-i)) i SV.unsafeFreeze v @@ -513,24 +520,21 @@ lMaxima :: Perm0 -> SV.Vector Int lMaxima w = runST $ do v <- MV.unsafeNew n- k <- iter v n 0 (-1)+ (_,_,k) <- foldM iter (v,-1,0) [0..n-1] SV.unsafeFreeze $ MV.unsafeSlice 0 k v where n = size w- {-# INLINE iter #-}- iter _ 0 j _ = return j- iter v i j m = do- let m' = (SV.!) w (n-i)+ iter (v, m, j) i = do+ let m' = w ! i if m' > m then do- MV.unsafeWrite v j (n-i)- iter v (i-1) (j+1) m'+ MV.unsafeWrite v j i+ return (v, m', j+1) else- iter v (i-1) j m-+ return (v, m, j) -- | The set of indices of right-to-left maxima. rMaxima :: Perm0 -> SV.Vector Int-rMaxima w = SV.reverse . SV.map (\x -> SV.length w - x - 1) . lMaxima $ reverse w+rMaxima w = SV.reverse . SV.map (\x -> size w - x - 1) . lMaxima $ reverse w -- Components@@ -540,20 +544,19 @@ components :: Perm0 -> SV.Vector Int components w = runST $ do v <- MV.unsafeNew n- k <- iter v n 0 (-1)+ (_,_,k) <- foldM iter (v,-1,0) [0..n-1] SV.unsafeFreeze $ MV.unsafeSlice 0 k v where n = size w- {-# INLINE iter #-}- iter _ 0 j _ = return j- iter v i j m = do- let m' = max m $ (SV.!) w (n-i)- if m' == n-i then do- MV.unsafeWrite v j (n-i)- iter v (i-1) (j+1) m'+ iter (v, m, j) i = do+ let m' = max m $ w ! i+ if m' == i then do+ MV.unsafeWrite v j i+ return (v, m', j+1) else- iter v (i-1) j m'+ return (v, m', j) + -- Sorting operators -- ----------------- @@ -563,12 +566,12 @@ foreign import ccall unsafe "sortop.h bubblesort" c_bubblesort :: Ptr CLong -> CLong -> IO () --- Marshal a sorting operator defined in C to on in Haskell.+-- Marshal a sorting operator defined in C to one in Haskell. sortop :: (Ptr CLong -> CLong -> IO ()) -> Perm0 -> Perm0 sortop f w = unsafePerformIO $ do v <- SV.thaw w MV.unsafeWith v $ \ptr -> do- f (castPtr ptr) (fromIntegral (SV.length w))+ f (castPtr ptr) (fromIntegral (size w)) SV.unsafeFreeze v -- | One pass of stack-sort.@@ -586,16 +589,51 @@ -- | Delete the element at a given position del :: Int -> Perm0 -> Perm0 del i u = runST $ do- let n = SV.length u- let j = (SV.!) u i+ let n = size u+ let j = u ! i v <- MV.unsafeNew (n-1) forM_ [0..i-1] $ \k -> do- let m = (SV.!) u k+ let m = u ! k MV.unsafeWrite v k (if m < j then m else m-1) forM_ [i+1..n-1] $ \k -> do- let m = (SV.!) u k+ let m = u ! k MV.unsafeWrite v (k-1) (if m < j then m else m-1) SV.unsafeFreeze v+++-- Bijections+-- ----------++-- | The Simion-Schmidt bijection from Av(123) onto Av(132).+simionSchmidt :: Perm0 -> Perm0+simionSchmidt w = runST $ do+ v <- MV.unsafeNew n+ foldM_ iter (v, n, Set.empty) [0..n-1]+ SV.unsafeFreeze v+ where+ n = size w+ iter (v, m, s) i = do+ let c = w ! i+ let y = Prelude.head [ x | x <- [m+1 .. ], x `Set.notMember` s ]+ let (d, k) = if c < m then (c, c) else (y, m)+ MV.unsafeWrite v i d+ return (v, k, Set.insert d s)++-- | The inverse of the Simion-Schmidt bijection. It is a function+-- from Av(132) to Av(123).+simionSchmidt' :: Perm0 -> Perm0+simionSchmidt' w = runST $ do+ v <- MV.unsafeNew n+ let is = [0..n-1]+ foldM_ iter (v, n, Set.fromDistinctAscList is) is+ SV.unsafeFreeze v+ where+ n = size w+ iter (v, m, s) i = do+ let c = w ! i+ let (d, k) = if c < m then (c, c) else (Set.findMax s, m)+ MV.unsafeWrite v i d+ return (v, k, Set.delete d s) -- Bitmasks
Math/Sym/Stat.hs view
@@ -59,112 +59,112 @@ , head, last, lir, ldr, rir, rdr, comp, scomp, ep, dim, asc0, des0 ) -generalize :: Perm a => (Perm0 -> b) -> a -> b-generalize f = f . toVector . st+liftStat :: Perm a => (Perm0 -> b) -> a -> b+liftStat f = f . toVector -- | The number of ascents. An /ascent/ in @w@ is an index @i@ such -- that @w[i] \< w[i+1]@. asc :: Perm a => a -> Int-asc = generalize I.asc+asc = liftStat I.asc -- | The number of descents. A /descent/ in @w@ is an index @i@ such -- that @w[i] > w[i+1]@. des :: Perm a => a -> Int-des = generalize I.des+des = liftStat I.des -- | The number of /excedances/: positions @i@ such that @w[i] > i@. exc :: Perm a => a -> Int-exc = generalize I.exc+exc = liftStat I.exc -- | The number of /fixed points/: positions @i@ such that @w[i] == i@. fp :: Perm a => a -> Int-fp = generalize I.fp+fp = liftStat I.fp -- | The number of /cycles/: orbits of the permutation when viewed as a function. cyc :: Perm a => a -> Int-cyc = generalize I.cyc+cyc = liftStat I.cyc -- | The number of /inversions/: pairs @\(i,j\)@ such that @i \< j@ and @w[i] > w[j]@. inv :: Perm a => a -> Int-inv = generalize I.inv+inv = liftStat I.inv -- | /The major index/ is the sum of descents. maj :: Perm a => a -> Int-maj = generalize I.maj+maj = liftStat I.maj -- | /The co-major index/ is the sum of descents. comaj :: Perm a => a -> Int-comaj = generalize I.comaj+comaj = liftStat I.comaj -- | The number of /peaks/: positions @i@ such that @w[i-1] \< w[i]@ and @w[i] \> w[i+1]@. peak :: Perm a => a -> Int-peak = generalize I.peak+peak = liftStat I.peak -- | The number of /valleys/: positions @i@ such that @w[i-1] \> w[i]@ and @w[i] \< w[i+1]@. vall :: Perm a => a -> Int-vall = generalize I.vall+vall = liftStat I.vall -- | The number of /double ascents/: positions @i@ such that @w[i-1] \< w[i] \< w[i+1]@. dasc :: Perm a => a -> Int-dasc = generalize I.dasc+dasc = liftStat I.dasc -- | The number of /double descents/: positions @i@ such that @w[i-1] \> w[i] \> w[i+1]@. ddes :: Perm a => a -> Int-ddes = generalize I.ddes+ddes = liftStat I.ddes -- | The number of /left-to-right minima/: positions @i@ such that @w[i] \< w[j]@ for all @j \< i@. lmin :: Perm a => a -> Int-lmin = generalize I.lmin+lmin = liftStat I.lmin -- | The number of /left-to-right maxima/: positions @i@ such that @w[i] \> w[j]@ for all @j \< i@. lmax :: Perm a => a -> Int-lmax = generalize I.lmax+lmax = liftStat I.lmax -- | The number of /right-to-left minima/: positions @i@ such that @w[i] \< w[j]@ for all @j \> i@. rmin :: Perm a => a -> Int-rmin = generalize I.rmin+rmin = liftStat I.rmin -- | The number of /right-to-left maxima/: positions @i@ such that @w[i] \> w[j]@ for all @j \> i@. rmax :: Perm a => a -> Int-rmax = generalize I.rmax+rmax = liftStat I.rmax -- | The first (left-most) element in the standardization. E.g., @head \"231\" = head (fromList [1,2,0]) = 1@. head :: Perm a => a -> Int-head = generalize I.head+head = liftStat I.head -- | The last (right-most) element in the standardization. E.g., @last \"231\" = last (fromList [1,2,0]) = 0@. last :: Perm a => a -> Int-last = generalize I.last+last = liftStat I.last -- | Length of the left-most increasing run: largest @i@ such that -- @w[0] \< w[1] \< ... \< w[i-1]@. lir :: Perm a => a -> Int-lir = generalize I.lir+lir = liftStat I.lir -- | Length of the left-most decreasing run: largest @i@ such that -- @w[0] \> w[1] \> ... \> w[i-1]@. ldr :: Perm a => a -> Int-ldr = generalize I.ldr+ldr = liftStat I.ldr -- | Length of the right-most increasing run: largest @i@ such that -- @w[n-i] \< ... \< w[n-2] \< w[n-1]@. rir :: Perm a => a -> Int-rir = generalize I.rir+rir = liftStat I.rir -- | Length of the right-most decreasing run: largest @i@ such that -- @w[n-i] \> ... \> w[n-2] \> w[n-1]@. rdr :: Perm a => a -> Int-rdr = generalize I.rdr+rdr = liftStat I.rdr -- | The number of components. E.g., @[2,0,3,1,4,6,7,5]@ has three -- components: @[2,0,3,1]@, @[4]@ and @[6,7,5]@. comp :: Perm a => a -> Int-comp = generalize I.comp+comp = liftStat I.comp -- | The number of skew components. E.g., @[5,7,4,6,3,1,0,2]@ has three -- skew components: @[5,7,4,6]@, @[3]@ and @[1,0,2]@. scomp :: Perm a => a -> Int-scomp = generalize I.scomp+scomp = liftStat I.scomp -- | The rank as defined by Elizalde and Pak [Bijections for -- refined restricted permutations, /J. Comb. Theory, Ser. A/, 2004]:@@ -172,22 +172,22 @@ -- > maximum [ k | k <- [0..n-1], w[i] >= k for all i < k ] -- ep :: Perm a => a -> Int-ep = generalize I.ep+ep = liftStat I.ep -- | The dimension of a permutation is defined as the largest -- non-fixed-point, or zero if all points are fixed. dim :: Perm a => a -> Int-dim = generalize I.dim+dim = liftStat I.dim -- | The number of small ascents. A /small ascent/ in @w@ is an index -- @i@ such that @w[i] + 1 == w[i+1]@. asc0 :: Perm a => a -> Int-asc0 = generalize I.asc0+asc0 = liftStat I.asc0 -- | The number of small descents. A /small descent/ in @w@ is an -- index @i@ such that @w[i] == w[i+1] + 1@. des0 :: Perm a => a -> Int-des0 = generalize I.des0+des0 = liftStat I.des0 -- | The size of the shadow of @w@. That is, the number of different -- one point deletions of @w@.
sym.cabal view
@@ -1,5 +1,5 @@ Name: sym-Version: 0.6.1+Version: 0.8 Synopsis: Permutations, patterns, and statistics Description: Definitions for permutations with an emphasis on permutation@@ -16,6 +16,8 @@ @inv@, @exc@, @maj@, @fp@, @comp@, @lmin@, @lmax@, ... . ["Math.Sym.Class"] Common permutation classes.+ .+ ["Math.Sym.Bijection"] Bijections between sets of permutations. Homepage: http://github.com/akc/sym @@ -39,9 +41,10 @@ Math.Sym.D8 Math.Sym.Stat Math.Sym.Class+ Math.Sym.Bijection Math.Sym.Internal - Build-depends: base >= 3 && < 5, random, vector+ Build-depends: base >= 3 && < 5, random, vector, containers ghc-prof-options: -auto-all ghc-options: -Wall -O2
tests/Properties.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | -- Copyright : (c) Anders Claesson 2012, 2013 -- License : BSD-style@@ -8,10 +10,12 @@ import Data.Monoid import Data.Function import Control.Monad+import Math.Sym (StPerm, IntPerm(..), CharPerm(..)) import qualified Math.Sym as Sym import qualified Math.Sym.D8 as D8 import qualified Math.Sym.Stat as S import qualified Math.Sym.Class as C+import qualified Math.Sym.Bijection as B import qualified Math.Sym.Internal as I import qualified Data.Vector.Storable as SV import Test.QuickCheck@@ -45,42 +49,45 @@ return (n, r1, r2, r3) -- The sub-permutation determined by a set of indices.-subperm :: Sym.Set -> Sym.StPerm -> Sym.StPerm+subperm :: Sym.Set -> StPerm -> StPerm subperm m w = Sym.fromVector . I.st $ SV.map ((SV.!) (Sym.toVector w)) m -subperms :: Int -> Sym.StPerm -> [Sym.StPerm]+subperms :: Int -> StPerm -> [StPerm] subperms k w = [ subperm m w | m <- Sym.subsets (Sym.size w) k ] -instance Arbitrary Sym.StPerm where+instance Arbitrary StPerm where arbitrary = uncurry Sym.unrankPerm `liftM` lenRank shrink w = nub $ [0 .. Sym.size w - 1] >>= \k -> subperms k w -perm :: Gen [Int]-perm = liftM (\w -> w `Sym.act` [1..Sym.size w]) arbitrary+instance Arbitrary CharPerm where+ arbitrary = Sym.cast `liftM` (arbitrary :: Gen StPerm) -perm2 :: Gen (Sym.StPerm, [Int])+instance Arbitrary IntPerm where+ arbitrary = Sym.cast `liftM` (arbitrary :: Gen StPerm)++perm2 :: Gen (StPerm, IntPerm) perm2 = do (n,r1,r2) <- lenRank2 let u = Sym.unrankPerm n r1 let v = Sym.unrankPerm n r2- return (u, v `Sym.act` [1..n])+ return (u, v) -perm3 :: Gen (Sym.StPerm, Sym.StPerm, [Int])+perm3 :: Gen (StPerm, StPerm, IntPerm) perm3 = do (n,r1,r2,r3) <- lenRank3 let u = Sym.unrankPerm n r1 let v = Sym.unrankPerm n r2 let w = Sym.unrankPerm n r3- return (u, v, w `Sym.act` [1..n])+ return (u, v, w) -stPermsOfEqualLength :: Gen [Sym.StPerm]+stPermsOfEqualLength :: Gen [StPerm] stPermsOfEqualLength = sized $ \m -> do n <- choose (0,m) k <- choose (0,m^2) rs <- replicateM k $ rank n return $ nub $ map (Sym.unrankPerm n) rs -newtype Symmetry = Symmetry (Sym.StPerm -> Sym.StPerm, String)+newtype Symmetry = Symmetry (StPerm -> StPerm, String) d8Symmetries :: [Symmetry] d8Symmetries = [ Symmetry (D8.r0, "r0")@@ -104,27 +111,27 @@ -- Properties for Math.Sym --------------------------------------------------------------------------------- -prop_monoid_mempty1 w = mempty <> w == (w :: Sym.StPerm)-prop_monoid_mempty2 w = w <> mempty == (w :: Sym.StPerm)-prop_monoid_associative u v w = u <> (v <> w) == (u <> v) <> (w :: Sym.StPerm)+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 :: Sym.StPerm} deriving (Eq, Show)+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) -instance Monoid S where- mempty = S $ Sym.fromVector SV.empty- mappend u v = S $ (Sym./-/) (unS u) (unS v)- neutralize :: Sym.Perm a => a -> a neutralize = Sym.idperm . Sym.size -forAllPermEq f g = forAll perm $ \w -> f w == g w+forAllPermEq f g w = f w == g (w :: IntPerm) prop_unrankPerm_distinct = forAll lenRank $ \(n, r) ->@@ -132,20 +139,20 @@ prop_unrankPerm_injective = forAll lenRank2 $ \(n, r1, r2) ->- (Sym.unrankPerm n r1 :: Sym.StPerm) /= Sym.unrankPerm n r2 || r1 == r2+ (Sym.unrankPerm n r1 :: StPerm) /= Sym.unrankPerm n r2 || r1 == r2 prop_sym = and [ sort (Sym.sym n) == sort (sym' n) | n<-[0..6] ] where sym' n = map Sym.fromList $ Data.List.permutations [0..fromIntegral n - 1] prop_perm =- and [ sort (Sym.perms n) == sort (permutations [1..n]) | n<-[0..6::Int] ]+ and [ map ints (sort (Sym.perms n)) == sort (permutations [1..n]) | n<-[0..6::Int] ] prop_st = forAll perm2 $ \(u,v) -> Sym.st (u `Sym.act` v) == u `Sym.act` Sym.st v prop_act_def =- forAll perm2 $ \(u,v) -> u `Sym.act` v == map (v!!) (Sym.toList u)+ forAll perm2 $ \(u,v) -> u `Sym.act` v == IntPerm (map (ints v !!) (Sym.toList u)) prop_act_id = forAll perm2 $ \(u,v) -> neutralize u `Sym.act` v == v@@ -157,8 +164,7 @@ prop_neutralize = neutralize `forAllPermEq` (\u -> Sym.inverse (Sym.st u) `Sym.act` u) -prop_inverse =- forAllPermEq Sym.inverse $ \v -> Sym.inverse (Sym.st v) `Sym.act` neutralize v+prop_inverse = forAllPermEq Sym.inverse $ \v -> Sym.inverse (Sym.st v) `Sym.act` neutralize v prop_ordiso1 = forAll perm2 $ \(u,v) -> u `Sym.ordiso` v == (u == Sym.st v)@@ -176,41 +182,47 @@ ptDeletions [] = [] ptDeletions xs@(x:xt) = xt : map (x:) (ptDeletions xt) -prop_shadow = forAll (resize 30 perm) $ \w -> Sym.shadow [w] == shadow w+prop_shadow = forAll (resize 30 arbitrary) $ \w -> Sym.shadow [w] == map IntPerm (shadow (ints w)) prop_downset_shadow =- forAll (resize 10 perm) $ \w ->- [ v | v <- Sym.downset [w], 1 + length v == length w ] == Sym.shadow [w]+ forAll (resize 10 arbitrary) $ \w ->+ [ v | v <- Sym.downset [w], 1 + Sym.size v == Sym.size w ] == Sym.shadow [w :: CharPerm] prop_downset_orderideal =- forAll (resize 9 perm) $ \w -> null [ v | v <- Sym.downset [w]- , w `Sym.avoids` [Sym.st v]- ]+ forAll (resize 9 arbitrary) $ \w -> null [ v | v <- Sym.downset [w :: CharPerm]+ , w `Sym.avoids` v+ ] -coshadow :: (Enum a, Ord a) => [a] -> [[a]]-coshadow w = sort $ ptExtensions (succ $ maximum (toEnum 0 : w)) w+coshadow :: Integral a => [a] -> [[Int]]+coshadow w = nub . sort . map (map (+1) . st) $ [0..length w] >>= \i ->+ ptExtensions (fromIntegral i + 0.5) (map fromIntegral w) where ptExtensions n [] = [[n]] ptExtensions n xs@(x:xt) = (n:xs) : map (x:) (ptExtensions n xt) -prop_coshadow = forAll (resize 50 perm) $ \w -> Sym.coshadow [w] == coshadow w+prop_coshadow = forAll (resize 12 arbitrary) $ \w -> Sym.coshadow [w] == map IntPerm (coshadow (ints w)) +prop_coeff =+ forAll (resize 5 arbitrary) $ \u ->+ forAll (resize 6 arbitrary) $ \v ->+ Sym.coeff (Sym.stat u) (v :: CharPerm) == fromEnum (u==v)+ prop_minima_antichain = forAll (resize 14 arbitrary) $ \ws ->- let vs = Sym.minima ws in and [ (v::Sym.StPerm) `Sym.avoids` (vs \\ [v]) | v <- vs ]+ let vs = Sym.minima ws in and [ (v::StPerm) `Sym.avoidsAll` (vs \\ [v]) | v <- vs ] prop_minima_smallest = forAll (resize 14 arbitrary) $ \ws ->- let vs = Sym.minima ws in and [ not ((w::Sym.StPerm) `Sym.avoids` vs) | w <- ws ]+ let vs = Sym.minima ws in and [ not ((w::StPerm) `Sym.avoidsAll` vs) | w <- ws ] prop_maxima_antichain = forAll (resize 12 arbitrary) $ \ws ->- let vs = Sym.maxima ws in and [ (v::Sym.StPerm) `Sym.avoids` (vs \\ [v]) | v <- vs ]+ let vs = Sym.maxima ws in and [ (v::StPerm) `Sym.avoidsAll` (vs \\ [v]) | v <- vs ] -recordIndicesAgree f g =- forAll perm $ \w -> SV.fromList (recordIndices w) == f w- where- recordIndices w = [ head $ elemIndices x w | x <- g w ]+recordIndicesAgree f g w = SV.fromList (recordIndices w) == f w+ where+ w' = ints w+ recordIndices w = [ head $ elemIndices x w' | x <- g w' ] prop_lMaxima = recordIndicesAgree Sym.lMaxima lMaxima prop_lMinima = recordIndicesAgree Sym.lMinima lMinima@@ -228,15 +240,13 @@ -- The list of indices of skew components in a permutation skewComponents w = components $ map (\x -> length w - x - 1) w -prop_components = (components . st) `forAllPermEq` (SV.toList . Sym.components)+prop_components = (components . st . ints) `forAllPermEq` (SV.toList . Sym.components) -prop_skewComponents = (skewComponents . st) `forAllPermEq` (SV.toList . Sym.skewComponents)+prop_skewComponents = (skewComponents . st . ints) `forAllPermEq` (SV.toList . Sym.skewComponents) -prop_dsum = forAll perm $ \u ->- forAll perm $ \v -> (Sym.\+\) u v == Sym.inflate "12" [u,v]+prop_dsum u v = (Sym./+/) u v == Sym.inflate ("12" :: CharPerm) [u, v :: CharPerm] -prop_ssum = forAll perm $ \u ->- forAll perm $ \v -> (Sym./-/) u v == Sym.inflate "21" [u,v]+prop_ssum u v = (Sym.\-\) u v == Sym.inflate ("21" :: CharPerm) [u, v :: CharPerm] inflate :: [Int] -> [[Int]] -> [Int] inflate w vs = sort [ (i, map (+c) u) | (i, c, u) <- zip3 w' cs us ] >>= snd@@ -244,13 +254,9 @@ (_, w',us) = unzip3 . sort $ zip3 w [0..] vs cs = scanl (\i u -> i + length u) 0 us -prop_inflate =- forAll perm $ \u0 ->- forAll perm $ \u1 ->- forAll perm $ \u2 ->- forAll perm $ \u3 ->- let us = [u0, u1, u2, u3]- in and [ inflate w us == Sym.inflate w us | w <- permutations [1..4] ]+prop_inflate u0 u1 u2 u3 =+ let us = [u0, u1, u2, u3]+ in and [ IntPerm (inflate w (map ints us)) == Sym.inflate (IntPerm w) us | w <- permutations [1..4] ] segments :: [a] -> [[a]] segments [] = [[]]@@ -271,47 +277,46 @@ simple :: Ord a => [a] -> Bool simple = null . properIntervals -prop_simple = forAll (resize 40 perm) $ \w -> Sym.simple w == simple w+prop_simple = forAll (resize 40 arbitrary) $ \w -> Sym.simple w == simple (ints w) -prop_stackSort = Sym.stackSort `forAllPermEq` stack+prop_stackSort = Sym.stackSort `forAllPermEq` (IntPerm . stack . ints) prop_stackSort_231 =- (\v -> Sym.stackSort v == neutralize v) `forAllPermEq` (`Sym.avoids` [Sym.st "231"])+ (\v -> Sym.stackSort v == neutralize v) `forAllPermEq` (`Sym.avoids` ("231" :: CharPerm)) -prop_bubbleSort = Sym.bubbleSort `forAllPermEq` bubble+prop_bubbleSort = Sym.bubbleSort `forAllPermEq` (IntPerm . bubble . ints) -prop_bubbleSort_231_321 = forAllPermEq f g+prop_bubbleSort_231_321 = f `forAllPermEq` g where f v = Sym.bubbleSort v == neutralize v- g v = v `Sym.avoids` [Sym.st "231", Sym.st "321"]+ g v = v `Sym.avoidsAll` ["231", "321" :: CharPerm] prop_subperm_copies p =- forAll (resize 21 perm) $ \w ->- and [ subperm m (Sym.st w) == p | m <- Sym.copiesOf p w ]+ forAll (resize 21 arbitrary) $ \w ->+ and [ subperm m (Sym.st w) == p | m <- Sym.copiesOf p (w :: CharPerm) ] prop_copies = forAll (resize 6 arbitrary) $ \p ->- forAll (resize 12 perm) $ \w ->- sort (Sym.copiesOf p w) == sort (map I.fromList $ copies (Sym.toList p) w)+ forAll (resize 12 arbitrary) $ \w ->+ sort (Sym.copiesOf p w) == sort (map I.fromList $ copies (Sym.toList p) (ints w)) -prop_copies_self =- forAll perm $ \v -> Sym.copiesOf (Sym.st v) v == [SV.fromList [0 .. length v - 1]]+prop_copies_self v = Sym.copiesOf v (v :: CharPerm) == [SV.fromList [0 .. Sym.size v - 1]] prop_copies_d8 (Symmetry (f,_)) = forAll (resize 6 arbitrary) $ \p ->- forAll (resize 20 perm) $ \w ->+ forAll (resize 20 arbitrary) $ \w -> let p' = f p- w' = Sym.generalize f w :: [Int]- in length (Sym.copiesOf p w) == length (Sym.copiesOf p' w')+ w' = (Sym.unst . f . Sym.st) (w :: CharPerm)+ in Sym.stat p w == Sym.stat p' (w' :: CharPerm) prop_avoiders_avoid = forAll (resize 20 arbitrary) $ \ws -> forAll (resize 6 arbitrary) $ \ps ->- all (`Sym.avoids` ps) $ Sym.avoiders (ps :: [Sym.StPerm]) (ws :: [Sym.StPerm])+ all (`Sym.avoidsAll` ps) $ Sym.avoiders (ps :: [StPerm]) (ws :: [StPerm]) prop_avoiders_idempotent = forAll (resize 18 arbitrary) $ \vs -> forAll (resize 5 arbitrary) $ \ps ->- let ws = Sym.avoiders (ps :: [Sym.StPerm]) (vs :: [Sym.StPerm])+ let ws = Sym.avoiders (ps :: [StPerm]) (vs :: [StPerm]) in ws == Sym.avoiders ps ws prop_avoiders_d8 (Symmetry (f,_)) =@@ -329,11 +334,11 @@ prop_avoiders_d8'' (Symmetry (f,_)) = forAll (resize 18 arbitrary) $ \ws -> forAll (resize 5 arbitrary) $ \ps ->- sort (map f $ Sym.avoiders ps ws) == sort (Sym.avoiders (map f ps) (map f ws :: [Sym.StPerm]))+ sort (map f $ Sym.avoiders ps ws) == sort (Sym.avoiders (map f ps) (map f ws :: [StPerm])) prop_av_cardinality = forAll (resize 3 arbitrary) $ \p ->- let spec = [ length $ Sym.av [p :: Sym.StPerm] n | n<-[0..6] ]+ let spec = [ length $ Sym.av [p :: StPerm] n | n<-[0..6] ] in case Sym.size p of 0 -> spec == [0,0,0,0,0,0,0] 1 -> spec == [1,0,0,0,0,0,0]@@ -407,6 +412,7 @@ , ("ordiso/2", check prop_ordiso2) , ("shadow", check prop_shadow) , ("coshadow", check prop_coshadow)+ , ("coeff", check prop_coeff) , ("downset/shadow", check prop_downset_shadow) , ("downset/orderideal", check prop_downset_orderideal) , ("minima/smallest", check prop_minima_smallest)@@ -455,7 +461,7 @@ prop_D8_orbit fs w = all (`elem` orbD8) $ D8.orbit (map fn fs) w where- orbD8 = D8.orbit D8.d8 (w :: Sym.StPerm)+ orbD8 = D8.orbit D8.d8 (w :: StPerm) symmetriesAgrees f g = (f . Sym.toVector) `forAllPermEq` (Sym.toVector . g) @@ -638,37 +644,36 @@ ddes = length . doubleDescents shad = length . shadow -prop_asc = forAllPermEq asc S.asc-prop_des = forAllPermEq des S.des-prop_exc = forAllPermEq exc S.exc-prop_fp = forAllPermEq fp S.fp-prop_cyc = forAllPermEq cyc S.cyc-prop_inv = forAllPermEq inv S.inv-prop_maj = forAllPermEq maj S.maj-prop_comaj = forAllPermEq comaj S.comaj-prop_lmin = forAllPermEq lmin S.lmin-prop_lmax = forAllPermEq lmax S.lmax-prop_rmin = forAllPermEq rmin S.rmin-prop_rmax = forAllPermEq rmax S.rmax-prop_head = forAll perm $ \w -> not (null w) ==> head w == 1 + S.head w-prop_last = forAll perm $ \w -> not (null w) ==> last w == 1 + S.last w-prop_peak = forAllPermEq peak S.peak-prop_vall = forAllPermEq vall S.vall-prop_dasc = forAllPermEq dasc S.dasc-prop_ddes = forAllPermEq ddes S.ddes-prop_ep = forAllPermEq ep S.ep-prop_lir = forAllPermEq lir S.lir-prop_ldr = forAllPermEq ldr S.ldr-prop_rir = forAllPermEq rir S.rir-prop_rdr = forAllPermEq rdr S.rdr-prop_comp = forAllPermEq comp S.comp-prop_scomp = forAllPermEq scomp S.scomp-prop_dim = forAllPermEq dim S.dim-prop_asc0 = forAllPermEq asc0 S.asc0-prop_des0 = forAllPermEq des0 S.des0-prop_shad = forAllPermEq shad S.shad-prop_inv_21 = forAll (resize 30 perm) $ \w ->- S.inv w == (length . Sym.copiesOf (Sym.st "21")) w+prop_asc = forAllPermEq (asc . ints) S.asc+prop_des = forAllPermEq (des . ints) S.des+prop_exc = forAllPermEq (exc . ints) S.exc+prop_fp = forAllPermEq (fp . ints) S.fp+prop_cyc = forAllPermEq (cyc . ints) S.cyc+prop_inv = forAllPermEq (inv . ints) S.inv+prop_maj = forAllPermEq (maj . ints) S.maj+prop_comaj = forAllPermEq (comaj . ints) S.comaj+prop_lmin = forAllPermEq (lmin . ints) S.lmin+prop_lmax = forAllPermEq (lmax . ints) S.lmax+prop_rmin = forAllPermEq (rmin . ints) S.rmin+prop_rmax = forAllPermEq (rmax . ints) S.rmax+prop_head w = (w /= Sym.empty) ==> head (ints w) == 1 + S.head w+prop_last w = (w /= Sym.empty) ==> last (ints w) == 1 + S.last w+prop_peak = forAllPermEq (peak . ints) S.peak+prop_vall = forAllPermEq (vall . ints) S.vall+prop_dasc = forAllPermEq (dasc . ints) S.dasc+prop_ddes = forAllPermEq (ddes . ints) S.ddes+prop_ep = forAllPermEq (ep . ints) S.ep+prop_lir = forAllPermEq (lir . ints) S.lir+prop_ldr = forAllPermEq (ldr . ints) S.ldr+prop_rir = forAllPermEq (rir . ints) S.rir+prop_rdr = forAllPermEq (rdr . ints) S.rdr+prop_comp = forAllPermEq (comp . ints) S.comp+prop_scomp = forAllPermEq (scomp . ints) S.scomp+prop_dim = forAllPermEq (dim . ints) S.dim+prop_asc0 = forAllPermEq (asc0 . ints) S.asc0+prop_des0 = forAllPermEq (des0 . ints) S.des0+prop_shad = forAllPermEq (shad . ints) S.shad+prop_inv_21 = forAll (resize 30 arbitrary) $ \w -> S.inv (w :: IntPerm) == Sym.stat ("21" :: CharPerm) w testsStat = [ ("asc", check prop_asc)@@ -710,12 +715,12 @@ agreesWithBasis bs cls m = and [ sort (Sym.av (map Sym.st bs) n) == sort (cls n) | n<-[0..m] ] -prop_av231 = agreesWithBasis ["231"] C.av231 7-prop_vee = agreesWithBasis ["132", "231"] C.vee 7-prop_caret = agreesWithBasis ["213", "312"] C.caret 7-prop_gt = agreesWithBasis ["132", "312"] C.gt 7-prop_lt = agreesWithBasis ["213", "231"] C.lt 7-prop_separables = agreesWithBasis ["2413", "3142"] C.separables 7+prop_av231 = agreesWithBasis ["231" :: CharPerm] C.av231 7+prop_vee = agreesWithBasis ["132", "231" :: CharPerm] C.vee 7+prop_caret = agreesWithBasis ["213", "312" :: CharPerm] C.caret 7+prop_gt = agreesWithBasis ["132", "312" :: CharPerm] C.gt 7+prop_lt = agreesWithBasis ["213", "231" :: CharPerm] C.lt 7+prop_separables = agreesWithBasis ["2413", "3142" :: CharPerm] C.separables 7 testsClass = [ ("av231", check prop_av231)@@ -727,10 +732,37 @@ ] ---------------------------------------------------------------------------------+-- Properties for Math.Sym.Bijection+---------------------------------------------------------------------------------++prop_simionSchmidt_avoid =+ forAll (resize 15 arbitrary) $ \w ->+ (w :: CharPerm) `Sym.avoids` ("123" :: CharPerm) ==> B.simionSchmidt w `Sym.avoids` ("132" :: CharPerm)++prop_simionSchmidt_avoid' =+ forAll (resize 15 arbitrary) $ \w ->+ (w :: CharPerm) `Sym.avoids` ("132" :: CharPerm) ==> B.simionSchmidt' w `Sym.avoids` ("123" :: CharPerm)++prop_simionSchmidt_id =+ forAll (resize 15 arbitrary) $ \w ->+ (w :: CharPerm) `Sym.avoids` ("123" :: CharPerm) ==> B.simionSchmidt' (B.simionSchmidt w) == w++prop_simionSchmidt_id' =+ forAll (resize 15 arbitrary) $ \w ->+ (w :: CharPerm) `Sym.avoids` ("132" :: CharPerm) ==> B.simionSchmidt (B.simionSchmidt' w) == w++testsBijection =+ [ ("simionSchmidt/avoid", check prop_simionSchmidt_avoid)+ , ("simionSchmidt'/avoid", check prop_simionSchmidt_avoid')+ , ("simionSchmidt/id", check prop_simionSchmidt_id)+ , ("simionSchmidt'/id", check prop_simionSchmidt_id')+ ]++--------------------------------------------------------------------------------- -- Main --------------------------------------------------------------------------------- -tests = testsPerm ++ testsD8 ++ testsStat ++ testsClass+tests = testsPerm ++ testsD8 ++ testsStat ++ testsClass ++ testsBijection runTests = mapM_ (\(name, t) -> putStr (name ++ ":\t") >> t)