HaskellForMaths 0.1.3 → 0.1.4

raw patch · 6 files changed

+153/−54 lines, 6 files

Files

• HaskellForMaths.cabal +1/−1
• Math/Algebra/Group/PermutationGroup.hs +121/−41
• Math/Combinatorics/Graph.hs +24/−7
• Math/Combinatorics/GraphAuts.hs +5/−3
• Math/Combinatorics/StronglyRegularGraph.hs +1/−1
• Math/Projects/RootSystem.hs +1/−1

@@ -1,5 +1,5 @@    Name:                HaskellForMaths
-   Version:             0.1.3
+   Version:             0.1.4
    Category:            Math
    Description:         Math library - combinatorics, group theory, commutative algebra, non-commutative algebra
    License:             BSD3

@@ -6,13 +6,14 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 
-import Math.Common.ListSet (toListSet, union) -- a version of union which assumes the arguments are ascending sets (no repeated elements)
+import Math.Common.ListSet (toListSet, union, (\\) ) -- a version of union which assumes the arguments are ascending sets (no repeated elements)
 
 rotateL (x:xs) = xs ++ [x]
 
 
 -- PERMUTATIONS
 
+-- |Type for permutations, considered as group elements.
 newtype Permutation a = P (M.Map a a) deriving (Eq,Ord)
 
 fromPairs xys | isValid   = fromPairs' xys
@@ -33,7 +34,8 @@ supp (P g) = M.keys g
 -- (This is guaranteed not to contain fixed points provided the permutations have been constructed using the supplied constructors)
 
--- image of x under action of g
+-- |x .^ g returns the image of a vertex or point x under the action of the permutation g
+(.^) :: (Ord k) => k -> Permutation k -> k
 x .^ P g = case M.lookup x g of
            Just y  -> y
            Nothing -> x -- if x `notElem` supp (P g), then x is not moved
@@ -42,7 +44,8 @@ fromCycles cs = fromPairs $ concatMap fromCycle cs
     where fromCycle xs = zip xs (rotateL xs)
 
--- as we will use fromCycles a lot, we provide a shorthand for it
+-- |Construct a permutation from a list of cycles
+p :: (Ord a) => [[a]] -> Permutation a
 p cs = fromCycles cs
 -- can't specify in pointfree style because of monomorphism restriction
 
@@ -72,13 +75,15 @@ 
 inverse (P g) = P $ M.fromList $ map (\(x,y)->(y,x)) $ M.toList g
 
+-- |A trick: g^-1 returns the inverse of g
+(^-) :: (Ord k, Show k) => Permutation k -> Int -> Permutation k
 g ^- n = inverse g ^ n
 
 instance (Ord a, Show a) => Fractional (Permutation a) where
     recip = inverse
 
 -- conjugation
-h ~^ g = g^-1 * h * g
+g ~^ h = h^-1 * g * h
 
 -- commutator
 comm g h = g^-1 * h^-1 * g * h
@@ -86,36 +91,46 @@ 
 -- ORBITS
 
--- action on blocks
+-- |b -^ g returns the image of an edge or block b under the action of g
+(-^) :: (Ord t) => [t] -> Permutation t -> [t]
 xs -^ g = L.sort [x .^ g | x <- xs]
 
--- the orbit of a point or block under the action of a set of permutations
-orbit action x gs = S.toList $ orbitS action x gs
 
-orbitS action x gs = orbit' S.empty (S.singleton x) where
-    orbit' interior boundary
+closureS xs fs = closure' S.empty (S.fromList xs) where
+    closure' interior boundary
         | S.null boundary = interior
         | otherwise =
             let interior' = S.union interior boundary
-                boundary' = S.fromList [p `action` g | g <- gs, p <- S.toList boundary] S.\\ interior'
-            in orbit' interior' boundary'
+                boundary' = S.fromList [f x | x <- S.toList boundary, f <- fs] S.\\ interior'
+            in closure' interior' boundary'
 
--- orbit of a point
+closure xs fs = S.toList $ closureS xs fs
+
+orbit action x gs = closure [x] [ `action` g | g <- gs]
+
 x .^^ gs = orbit (.^) x gs
 orbitP gs x = orbit (.^) x gs
+orbitV gs x = orbit (.^) x gs
 
 -- orbit of a block
 b -^^ gs = orbit (-^) b gs
 orbitB gs b = orbit (-^) b gs
+orbitE gs b = orbit (-^) b gs
+{-
+-- orbit of a vertex / point
+x .^^ gs = closure [x] [ .^g | g <- gs]
+orbitV gs x = closure [x] [ .^g | g <- gs]
+orbitP gs x = closure [x] [ .^g | g <- gs]
 
--- the induced action of g on a set of blocks
--- Note: the set of blocks must be closed under the action of g, otherwise we will get an error in fromPairs
--- To ensure that it is closed, generate the blocks as the orbit of a starting block
-inducedAction bs g = fromPairs [(b, b -^ g) | b <- bs]
+-- orbit of an edge / block
+b -^^ gs = closure [b] [ -^g | g <- gs]
+orbitE gs b = closure [b] [ -^g | g <- gs]
+orbitB gs b = closure [b] [ -^g | g <- gs]
+-}
 
-induced action bs g = fromPairs [(b, b `action` g) | b <- bs]
+action xs f = fromPairs [(x, f x) | x <- xs]
+-- probably supercedes the three following functions
 
-inducedB bs g = induced (-^) bs g
 
 -- find all the orbits of a group
 -- (as we typically work with transitive groups, this is more useful for studying induced actions)
@@ -128,7 +143,7 @@ -- GROUPS
 -- Some standard sequences of groups, and constructions of new groups from old
 
--- Cn, cyclic group of order n
+-- |Generators for Cn, the cyclic group of order n
 _C n | n >= 2 = [p [[1..n]]]
 
 -- D2n, dihedral group of order 2n, symmetry group of n-gon
@@ -137,25 +152,29 @@ 
 _D2 n | n >= 3 = [a,b] where
     a = p [[1..n]]                            -- rotation
-    b = fromPairs $ [(i,n+1-i) | i <- [1..n]] -- reflection
+    b = p [[i,n+1-i] | i <- [1..n `div` 2]]   -- reflection
+    -- b = fromPairs $ [(i,n+1-i) | i <- [1..n]] -- reflection
 
--- Sn, symmetric group on [1..n]
-_S n | n >= 3 = [s,t] where
-    s = p [[1..n]]
-    t = p [[1,2]]
+-- |Generators for Sn, the symmetric group on [1..n]
+_S n | n >= 3 = [s,t]
+     | n == 2 = [t]
+     | n == 1 = []
+    where s = p [[1..n]]
+          t = p [[1,2]]
 
--- An, alternating group on [1..n]
-_A n | n == 3 = [t]
-     | n > 3 = [s,t] where
-    s | odd n  = p [[3..n]]
-      | even n = p [[1,2], [3..n]]
-    t = p [[1,2,3]]
+-- |Generators for An, the alternating group on [1..n]
+_A n | n > 3 = [s,t]
+     | n == 3 = [t]
+     | n == 2 = []
+    where s | odd n  = p [[3..n]]
+            | even n = p [[1,2], [3..n]]
+          t = p [[1,2,3]]
 
 
--- Cartesian product of groups
+-- Direct product of groups
 -- Given generators for H and K, acting on sets X and Y respectively,
 -- return generators for H*K, acting on the disjoint union X+Y (== Either X Y)
-cp hs ks =
+dp hs ks =
     [P $ M.fromList $ map (\(x,x') -> (Left x,Left x')) $ M.toList h' | P h' <- hs] ++
     [P $ M.fromList $ map (\(y,y') -> (Right y,Right y')) $ M.toList k' | P k' <- ks]
 
@@ -187,17 +206,34 @@ -- Most of these functions will only be efficient for small groups (say |G| < 10000)
 -- For larger groups we will need to use Schreier-Sims and associated algorithms
 
--- Given generators, list all elements of a group
--- Note, result is guaranteed to be in order, which we use on occasion
-elts gs = orbit (*) 1 gs
+-- |Given generators for a group, return a (sorted) list of all elements of the group
+elts :: (Num a, Ord a) => [a] -> [a]
+elts gs = closure [1] [ *g | g <- gs]
 
-eltsS gs = orbitS (*) 1 gs
+eltsS gs = closureS [1] [ *g | g <- gs]
 
 order gs = S.size $ eltsS gs -- length $ elts gs
 
 isMember gs h = h `S.member` eltsS gs -- h `elem` elts gs
 
 
+-- TRANSVERSAL GENERATING SETS
+-- The functions graphAuts2 and graphAuts3 return generating sets consisting of successive transversals
+-- In this case, we don't need to run Schreier-Sims to list elements or calculate order
+
+-- calculate the order of the group, given a "transversal generating set"
+orderTGS tgs =
+    let transversals = map (1:) $ L.groupBy (\g h -> (head . supp) g == (head .supp) h) tgs
+    in product $ map L.genericLength transversals
+
+-- list the elts of the group, given a "transversal generating set"
+eltsTGS tgs =
+    let transversals = map (1:) $ L.groupBy (\g h -> (head . supp) g == (head .supp) h) tgs
+    in map product $ sequence transversals
+
+
+-- MORE INVESTIGATIONS
+
 -- given the elts of a group, find generators
 gens hs = gens' [] (S.singleton 1) hs where
     gens' gs eltsG (h:hs) = if h `S.member` eltsG then gens' gs eltsG hs else gens' (h:gs) (eltsS $ h:gs) hs
@@ -208,15 +244,23 @@ -- conjClass gs h = orbit (~^) gs h
 
 -- Conjugacy class - should only be used for small groups
-h ~^^ gs = orbit (~^) h gs
+h ~^^ gs = conjClass gs h
 
-conjClass gs h = h ~^^ gs
+conjClass gs h = closure [h] [ ~^ g | g <- gs]
+-- conjClass gs h = h ~^^ gs
 
+conjClassReps gs = conjClassReps' (elts gs) where
+    conjClassReps' (h:hs) =
+        let cc = conjClass gs h in (h, length cc) : conjClassReps' (hs \\ cc)
+    conjClassReps' [] = []
+-- using the ListSet implementation of \\, since we know both lists are sorted
+
+{-
 -- This is just the orbits under conjugation. Can we generalise "orbits" to help us here?
 conjClasses gs = conjClasses' (elts gs)
     where conjClasses' [] = []
           conjClasses' (h:hs) = let c = conjClass gs h in c : conjClasses' (hs L.\\ c)
-
+-}
 
 -- centralizer of a subgroup or a set of elts
 -- the centralizer of H in G is the set of elts of G which commute with all elts of H
@@ -276,6 +320,7 @@ 
 -- Cosets are disjoint, which leads to Lagrange's theorem
 
+-- cosets gs hs = closure [hs] [ **^ g | g <- gs]
 cosets gs hs = orbit (**^) hs gs
 -- the group acts transitively on cosets of a subgp, so this gives all cosets
 -- hs #^^ gs = orbit (#^) gs hs
@@ -283,7 +328,8 @@ cosetAction gs hs =
     let _H = elts hs
         cosets_H = cosets gs _H
-    in toSn $ map (induced (**^) cosets_H) gs
+    in toSn [action cosets_H (**^ g) | g <- gs]
+    -- in toSn $ map (induced (**^) cosets_H) gs
 
 -- if H normal in G, then each element within a given coset gives rise to the same action on other cosets,
 -- and we get a well defined multiplication Hx * Hy = Hxy (where it doesn't depend on which coset rep we chose)
@@ -300,14 +346,48 @@ hs ~~^ g = L.sort [h ~^ g | h <- hs]
 
 -- don't think that this is necessarily transitive on isomorphic subgps
+-- conjugateSubgps gs hs = closure [hs] [ ~~^ g | g <- gs]
 conjugateSubgps gs hs = orbit (~~^) hs gs
 -- hs ~~^^ gs = orbit (~~^) gs hs
 
 subgpAction gs hs =
     let _H = elts hs
         conjugates_H = conjugateSubgps gs _H
-    in toSn $ map (induced (~~^) conjugates_H) gs
+    in toSn [action conjugates_H (~~^ g) | g <- gs]
+    -- in toSn $ map (induced (~~^) conjugates_H) gs
 
 
 -- in cube gp, the subgps all appear to correspond to stabilisers of subsets, or of blocks
+
+
+
+{-
+OLDER VERSIONS
+
+
+-- the orbit of a point or block under the action of a set of permutations
+orbit action x gs = S.toList $ orbitS action x gs
+
+orbitS action x gs = orbit' S.empty (S.singleton x) where
+    orbit' interior boundary
+        | S.null boundary = interior
+        | otherwise =
+            let interior' = S.union interior boundary
+                boundary' = S.fromList [p `action` g | g <- gs, p <- S.toList boundary] S.\\ interior'
+            in orbit' interior' boundary'
+
+-- orbit of a point
+-}
+{-
+-- the induced action of g on a set of blocks
+-- Note: the set of blocks must be closed under the action of g, otherwise we will get an error in fromPairs
+-- To ensure that it is closed, generate the blocks as the orbit of a starting block
+inducedAction bs g = fromPairs [(b, b -^ g) | b <- bs]
+
+induced action bs g = fromPairs [(b, b `action` g) | b <- bs]
+
+inducedB bs g = induced (-^) bs g
+-}
+-- elts gs = orbit (*) 1 gs
+-- eltsS gs = orbitS (*) 1 gs
 

@@ -102,6 +102,20 @@ -- automorphism group is Sm*Sn (plus a flip if m==n)
 
 -- k-cube
+q' k = graph (vs,es) where
+    vs = sequence $ replicate k [0,1] -- ptsAn k f2
+    es = [ [u,v] | [u,v] <- combinationsOf 2 vs, hammingDistance u v == 1 ]
+    hammingDistance as bs = length $ filter id $ zipWith (/=) as bs
+-- can probably type-coerce this to be Graph [F2] if required
+
+-- note, this definition only in versions >0.1.3
+q k = gmap (\v -> v <.> pows2) (q' k) where
+    pows2 = reverse $ take k $ iterate (*2) 1
+    u <.> v = sum $ zipWith (*) u v
+    gmap f (G vs es) = G (map f vs) ((map . map) f es)
+
+{-
+-- definitions in versions <= 0.1.3
 q k = let vs = zip [0..] (powerset [1..k])
           es = [ [i,j] | (i,iset) <- vs, (j,jset) <- vs, i < j, length (iset `symDiff` jset) == 1 ]
       in graph (map fst vs,es)
@@ -110,6 +124,7 @@            vs = [0..2^k-1] -- == L.sort $ map sum us
            es = L.sort [ L.sort [sum u, sum v] | [u,v] <- combinationsOf 2 us, length (u `symDiff` v) == 1 ]
        in graph (vs, es)
+-}
 
 tetrahedron = k 4
 
@@ -144,6 +159,15 @@     es' = [map (mapping M.!) e | e <- es] -- the edges will already be sorted correctly by construction
 
 
+-- this definition only in versions >0.1.3
+petersen = graph (vs,es) where
+    vs = combinationsOf 2 [1..5]
+    es = [ [v1,v2] | v1 <- vs, v2 <- vs, v1 < v2, disjoint v1 v2]
+-- == j 5 2 0
+-- == complement $ lineGraph' $ k 5
+-- == complement $ t' 5
+
+
 -- NEW GRAPHS FROM OLD
 
 complement (G vs es) = graph (vs,es') where es' = combinationsOf 2 vs \\ es
@@ -153,9 +177,7 @@ 
 lineGraph' (G vs es) = graph (es, [ [ei,ej] | ei <- es, ej <- dropWhile (<= ei) es, ei `intersect` ej /= [] ])
 
-petersen = complement $ lineGraph $ k 5
 
-
 -- SIMPLE PROPERTIES OF GRAPHS
 
 order g = length (vertices g)
@@ -249,8 +271,3 @@ kneser v k | v >= 2*k = j v k 0
 
 johnson v k | v >= 2*k = j v k (k-1)
-
-petersen1 = to1n $ j 5 2 0
-
-
-

@@ -20,19 +20,20 @@ -- TRANSITIVITY PROPERTIES OF GRAPHS
 
 isVertexTransitive (G [] []) = True -- null graph is trivially vertex transitive
-isVertexTransitive g@(G (v:vs) es) = orbitP auts v == v:vs where
+isVertexTransitive g@(G (v:vs) es) = orbitV auts v == v:vs where
     auts = graphAuts g
 
 isEdgeTransitive (G _ []) = True
-isEdgeTransitive g@(G vs (e:es)) = orbitB auts e == e:es where
+isEdgeTransitive g@(G vs (e:es)) = orbitE auts e == e:es where
     auts = graphAuts g
 
 arc ->^ g = map (.^ g) arc
--- unlike blocks, arcs are directed, so the action on them does not sort
+-- unlike edges/blocks, arcs are directed, so the action on them does not sort
 
 -- Godsil & Royle 59-60
 isArcTransitive (G _ []) = True -- empty graphs are trivially arc transitive
 isArcTransitive g@(G vs es) = orbit (->^) a auts == a:as where
+-- isArcTransitive g@(G vs es) = closure [a] [ ->^ h | h <- auts] == a:as where
     a:as = L.sort $ es ++ map reverse es
     auts = graphAuts g
 
@@ -66,6 +67,7 @@ isnArcTransitive n g@(G (v:vs) es) =
     orbitP auts v == v:vs && -- isVertexTransitive g
     orbit (->^) a stab == a:as
+    -- closure [a] [ ->^ h | h <- stab] == a:as
     where auts = graphAuts g
           stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order
           a:as = findArcs g v n

@@ -53,7 +53,6 @@     es = [ [v,v'] | v <- vs, v' <- dropWhile (<= v) vs, not (disjoint v v')]
 -- This is just lineGraph (k m), by another name
 
-petersen = complement $ t 5
 
 -- Lattice graph - van Lint & Wilson p262
 -- http://mathworld.wolfram.com/LatticeGraph.html
@@ -112,6 +111,7 @@ plane +^ g = L.sort [line -^ g | line <- plane]
 
 plane +^^ gs = orbit (+^) plane gs
+-- plane +^^ gs = closure [plane] [ +^ g | g <- gs ]
 
 hoffmanSingleton = G.to1n hoffmanSingleton'
 

@@ -9,7 +9,7 @@ import qualified Data.Set as S
 
 import Math.Algebra.LinearAlgebra
-import Math.Algebra.Group.PermutationGroup hiding (elts, order)
+import Math.Algebra.Group.PermutationGroup hiding (elts, order, closure)
 import Math.Algebra.Group.SchreierSims as SS
 import Math.Algebra.Group.StringRewriting as SG