sym 0.4.1 → 0.4.2
raw patch · 4 files changed
+107/−45 lines, 4 files
Files
- Math/Sym/D8.hs +39/−19
- Math/Sym/Internal.hs +5/−4
- sym.cabal +1/−1
- tests/Properties.hs +62/−21
Math/Sym/D8.hs view
@@ -15,30 +15,33 @@ module Math.Sym.D8 ( -- * The group elements- r0 -- :: Perm a => a -> a- , r1 -- :: Perm a => a -> a- , r2 -- :: Perm a => a -> a- , r3 -- :: Perm a => a -> a- , s0 -- :: Perm a => a -> a- , s1 -- :: Perm a => a -> a- , s2 -- :: Perm a => a -> a- , s3 -- :: Perm a => a -> a+ r0 -- :: Perm a => a -> a+ , r1 -- :: Perm a => a -> a+ , r2 -- :: Perm a => a -> a+ , r3 -- :: Perm a => a -> a+ , s0 -- :: Perm a => a -> a+ , s1 -- :: Perm a => a -> a+ , s2 -- :: Perm a => a -> a+ , s3 -- :: Perm a => a -> a -- * D8, the klein four-group, and orbits- , d8 -- :: Perm a => [a -> a]- , klein4 -- :: Perm a => [a -> a]- , orbit -- :: Ord a => Perm a => [a -> a] -> a -> [a]+ , d8 -- :: Perm a => [a -> a]+ , klein4 -- :: Perm a => [a -> a]+ , orbit -- :: (Ord a, Perm a) => [a -> a] -> a -> [a]+ , symmetryClasses -- :: (Ord a, Perm a) => [a -> a] -> [a] -> [[a]]+ , d8Classes -- :: (Ord a, Perm a) => [a] -> [[a]]+ , klein4Classes -- :: (Ord a, Perm a) => [a] -> [[a]] -- * Aliases- , id -- :: Perm a => a -> a- , rotate -- :: Perm a => a -> a- , complement -- :: Perm a => a -> a- , reverse -- :: Perm a => a -> a- , inverse -- :: Perm a => a -> a+ , id -- :: Perm a => a -> a+ , rotate -- :: Perm a => a -> a+ , complement -- :: Perm a => a -> a+ , reverse -- :: Perm a => a -> a+ , inverse -- :: Perm a => a -> a ) where import Prelude hiding (reverse, id)-import Data.List (group, sort)+import Data.List (group, sort, insert) import Math.Sym (Perm (size), fromVector, act) import qualified Math.Sym (inverse) import Math.Sym.Internal (revIdperm)@@ -98,12 +101,29 @@ klein4 :: Perm a => [a -> a] klein4 = [r0, r2, s0, s1] --- | @orbit fs x@ is the orbit of @x@ under the functions in @fs@. E.g.,+-- | @orbit fs x@ is the orbit of @x@ under the /group/ of function @fs@. E.g., -- -- > orbit klein4 "2314" == ["1423","2314","3241","4132"] -- -orbit :: Ord a => Perm a => [a -> a] -> a -> [a]+orbit :: (Ord a, Perm a) => [a -> a] -> a -> [a] orbit fs x = map head . group $ sort [ 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 _ [] = []+symmetryClasses fs xs@(x:xt) = insert orb $ symmetryClasses fs ys+ where+ orb = [ w | w <- orbit fs x, w `elem` xs ]+ ys = [ y | y <- xt, y `notElem` orb ]++-- | Symmetry classes with respect to D8.+d8Classes :: (Ord a, Perm a) => [a] -> [[a]]+d8Classes = symmetryClasses d8++-- | Symmetry classes with respect to Klein4+klein4Classes :: (Ord a, Perm a) => [a] -> [[a]]+klein4Classes = symmetryClasses klein4 -- Aliases
Math/Sym/Internal.hs view
@@ -508,15 +508,16 @@ where n = size w {-# INLINE iter #-}- iter _ 0 _ _ = return 0+ iter _ 0 j _ = return j iter v i j m = do let m' = (SV.!) w (n-i) if m' > m then do MV.unsafeWrite v j (n-i)- (+1) `liftM` iter v (i-1) (j+1) m'+ iter v (i-1) (j+1) m' else iter v (i-1) j m + -- | 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@@ -534,12 +535,12 @@ where n = size w {-# INLINE iter #-}- iter _ 0 _ _ = return 0+ 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)- (+1) `liftM` iter v (i-1) (j+1) m'+ iter v (i-1) (j+1) m' else iter v (i-1) j m'
sym.cabal view
@@ -1,5 +1,5 @@ Name: sym-Version: 0.4.1+Version: 0.4.2 Synopsis: Permutations, patterns, and statistics Description: Definitions for permutations with an emphasis on permutation
tests/Properties.hs view
@@ -3,8 +3,10 @@ -- License : BSD-style -- Maintainer : Anders Claesson <anders.claesson@gmail.com> +import Data.Ord import Data.List import Data.Monoid+import Data.Function import Control.Monad import qualified Math.Sym as Sym import qualified Math.Sym.D8 as D8@@ -30,14 +32,16 @@ return (n, r) lenRank2 :: Gen (Int, Integer, Integer)-lenRank2 = do (n, r1) <- lenRank- r2 <- rank n- return (n, r1, r2)+lenRank2 = do+ (n, r1) <- lenRank+ r2 <- rank n+ return (n, r1, r2) lenRank3 :: Gen (Int, Integer, Integer, Integer)-lenRank3 = do (n, r1, r2) <- lenRank2- r3 <- rank n- return (n, r1, r2, r3)+lenRank3 = do+ (n, r1, r2) <- lenRank2+ r3 <- rank n+ return (n, r1, r2, r3) -- The sub-permutation determined by a set of indices. subperm :: Sym.Set -> Sym.StPerm -> Sym.StPerm@@ -54,18 +58,27 @@ perm = liftM (\w -> w `Sym.act` [1..Sym.size w]) arbitrary perm2 :: Gen (Sym.StPerm, [Int])-perm2 = do (n,r1,r2) <- lenRank2- let u = Sym.unrankStPerm n r1- let v = Sym.unrankStPerm n r2- return (u, v `Sym.act` [1..n])+perm2 = do+ (n,r1,r2) <- lenRank2+ let u = Sym.unrankStPerm n r1+ let v = Sym.unrankStPerm n r2+ return (u, v `Sym.act` [1..n]) perm3 :: Gen (Sym.StPerm, Sym.StPerm, [Int])-perm3 = do (n,r1,r2,r3) <- lenRank3- let u = Sym.unrankStPerm n r1- let v = Sym.unrankStPerm n r2- let w = Sym.unrankStPerm n r3- return (u, v, w `Sym.act` [1..n])+perm3 = do+ (n,r1,r2,r3) <- lenRank3+ let u = Sym.unrankStPerm n r1+ let v = Sym.unrankStPerm n r2+ let w = Sym.unrankStPerm n r3+ return (u, v, w `Sym.act` [1..n]) +stPermsOfEqualLength :: Gen [Sym.StPerm]+stPermsOfEqualLength = sized $ \m -> do+ n <- choose (0,m)+ k <- choose (0,m^2)+ rs <- replicateM k $ rank n+ return $ nub $ map (Sym.unrankStPerm n) rs+ newtype Symmetry = Symmetry (Sym.StPerm -> Sym.StPerm, String) d8Symmetries :: [Symmetry]@@ -399,22 +412,50 @@ -- Properties for Math.Sym.D8 --------------------------------------------------------------------------------- +fn (Symmetry (f,_)) = f+ prop_D8_orbit fs w = all (`elem` orbD8) $ D8.orbit (map fn fs) w where orbD8 = D8.orbit D8.d8 w- fn (Symmetry (f,_)) = f prop_D8_reverse w = I.reverse (Sym.toVector w) == Sym.toVector (D8.reverse w) prop_D8_complement w = I.complement (Sym.toVector w) == Sym.toVector (D8.complement w) prop_D8_inverse w = I.inverse (Sym.toVector w) == Sym.toVector (D8.inverse w) prop_D8_rotate w = I.rotate (Sym.toVector w) == Sym.toVector (D8.rotate w) +-- Auxilary function that partitions a list xs with respect to the+-- equivalence induced by a function f; i.e. x ~ y iff f x == f y.+-- The time complexity is the same as for sorting, O(n log n).+eqClasses :: Ord a => (b -> a) -> [b] -> [[b]]+eqClasses f xs = (map . map) snd . group' $ sort' [ (f x, x) | x <- xs ]+ where+ group' = groupBy ((==) `on` fst)+ sort' = sortBy $ comparing fst++symmetryClasses :: (Ord a, Sym.Perm a) => [a -> a] -> [a] -> [[a]]+symmetryClasses fs xs = sort . map sort $ eqClasses (D8.orbit fs) xs++prop_symmetryClasses fs =+ forAll (resize 10 stPermsOfEqualLength) $ \ws ->+ symmetryClasses fs ws == D8.symmetryClasses fs ws++prop_symmetryClasses_d8 = prop_symmetryClasses D8.d8+prop_symmetryClasses_klein4 = prop_symmetryClasses D8.klein4+prop_symmetryClasses_ei = prop_symmetryClasses [D8.id, D8.inverse]+prop_symmetryClasses_er = prop_symmetryClasses [D8.id, D8.reverse]+prop_symmetryClasses_ec = prop_symmetryClasses [D8.id, D8.complement]+ testsD8 =- [ ("D8/orbit", check prop_D8_orbit)- , ("D8/reverse", check prop_D8_reverse)- , ("D8/complement", check prop_D8_complement)- , ("D8/inverse", check prop_D8_inverse)- , ("D8/rotate", check prop_D8_rotate)+ [ ("D8/orbit", check prop_D8_orbit)+ , ("D8/reverse", check prop_D8_reverse)+ , ("D8/complement", check prop_D8_complement)+ , ("D8/inverse", check prop_D8_inverse)+ , ("D8/rotate", check prop_D8_rotate)+ , ("D8/symmetryClasses/ei", check prop_symmetryClasses_ei)+ , ("D8/symmetryClasses/er", check prop_symmetryClasses_er)+ , ("D8/symmetryClasses/ec", check prop_symmetryClasses_ec)+ , ("D8/symmetryClasses/d8", check prop_symmetryClasses_d8)+ , ("D8/symmetryClasses/klein4", check prop_symmetryClasses_klein4) ] ---------------------------------------------------------------------------------