diff --git a/Math/Sym/D8.hs b/Math/Sym/D8.hs --- a/Math/Sym/D8.hs +++ b/Math/Sym/D8.hs @@ -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 diff --git a/Math/Sym/Internal.hs b/Math/Sym/Internal.hs --- a/Math/Sym/Internal.hs +++ b/Math/Sym/Internal.hs @@ -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' diff --git a/sym.cabal b/sym.cabal --- a/sym.cabal +++ b/sym.cabal @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -3,8 +3,10 @@ -- License : BSD-style -- Maintainer : Anders Claesson +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) ] ---------------------------------------------------------------------------------