HaskellForMaths 0.2.1 → 0.2.2

raw patch · 13 files changed

+202/−41 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• HaskellForMaths.cabal +4/−3
• Math/Algebra/Group/CayleyGraph.hs +108/−0
• Math/Algebra/Group/PermutationGroup.hs +2/−2
• Math/Algebra/Group/StringRewriting.hs +38/−19
• Math/Projects/MiniquaternionGeometry.hs +0/−2
• Math/Projects/RootSystem.hs +3/−1
• Math/Test/TCommutativeAlgebra.hs +1/−1
• Math/Test/TGraph.hs +6/−7
• Math/Test/TNonCommutativeAlgebra.hs +1/−1
• Math/Test/TPermutationGroup.hs +12/−4
• Math/Test/TRootSystem.hs +19/−0
• Math/Test/TSubquotients.hs +6/−1
• Math/Test/TestAll.hs +2/−0

@@ -1,12 +1,12 @@    Name:                HaskellForMaths
-   Version:             0.2.1
+   Version:             0.2.2
    Category:            Math
    Description:         A library of maths code in the areas of combinatorics, group theory, commutative algebra, and non-commutative algebra. The library is mainly intended for educational purposes, but does have efficient implementations of several fundamental algorithms.
    Synopsis:            Combinatorics, group theory, commutative algebra, non-commutative algebra
    License:             BSD3
    License-file:        license.txt
    Author:              David Amos
-   Maintainer:          haskellformaths-at-googlemail-dot-com
+   Maintainer:          haskellformaths-at-gmail-dot-com
    Homepage:            http://www.polyomino.f2s.com/haskellformathsv2/HaskellForMathsv2.html
    Build-Type:          Simple
    Cabal-Version:       >=1.2
@@ -19,6 +19,7 @@         Math/Test/TGraph.hs,
         Math/Test/TNonCommutativeAlgebra.hs,
         Math/Test/TPermutationGroup.hs,
+        Math/Test/TRootSystem.hs,
         Math/Test/TSubquotients.hs,
         Math/Test/TestAll.hs
 
@@ -31,7 +32,7 @@         Math.Algebra.Field.Base, Math.Algebra.Field.Extension,
         Math.Algebra.Group.PermutationGroup, Math.Algebra.Group.SchreierSims,
         Math.Algebra.Group.RandomSchreierSims, Math.Algebra.Group.Subquotients,
-        Math.Algebra.Group.StringRewriting,
+        Math.Algebra.Group.StringRewriting, Math.Algebra.Group.CayleyGraph,
         Math.Algebra.NonCommutative.NCPoly, Math.Algebra.NonCommutative.GSBasis, Math.Algebra.NonCommutative.TensorAlgebra,
         Math.Combinatorics.Graph, Math.Combinatorics.GraphAuts, Math.Combinatorics.StronglyRegularGraph,
         Math.Combinatorics.Design, Math.Combinatorics.FiniteGeometry, Math.Combinatorics.Hypergraph,

@@ -0,0 +1,108 @@+-- Copyright (c) David Amos, 2010. All rights reserved.++{-# LANGUAGE NoMonomorphismRestriction #-}++module Math.Algebra.Group.CayleyGraph where++import Math.Algebra.Group.StringRewriting as SR+import Math.Combinatorics.Graph+-- import Math.Combinatorics.GraphAuts++import Math.Algebra.Group.PermutationGroup as P++import qualified Data.List as L+import qualified Data.Set as S++toSet = S.toList . S.fromList+++data Digraph a = DG [a] [(a,a)] deriving (Eq,Ord,Show)+++cayleyDigraphP gs = DG vs es where+    vs = P.elts gs+    es = [(v,v') | v <- vs, v' <- nbrs v ]+    nbrs v = L.sort [v * g | g <- gs]++-- |The Cayley graph (undirected) on the generators (and their inverses),+-- for a group given as permutations+cayleyGraphP :: (Ord a, Show a) => [Permutation a] -> Graph (Permutation a)+cayleyGraphP gs = graph (vs,es) where -- G vs es where+    vs = P.elts gs+    es = toSet [ L.sort [v,v'] | v <- vs, v' <- nbrs v ] -- toSet orders and removes duplicates+    nbrs v = [v * g | g <- gs]+++cayleyDigraphS (gs,rs) = DG vs es where+    rs' = knuthBendix rs+    vs = L.sort $ nfs (gs,rs') -- calling elts would mean we invoked knuthBendix twice+    es = [(v,v') | v <- vs, v' <- nbrs v ]+    nbrs v = L.sort [rewrite rs' (v ++ [g]) | g <- gs]++-- |The Cayley graph (undirected) on the generators (and their inverses),+-- for a group given as generators and relations+cayleyGraphS :: (Ord a) => ([a], [([a], [a])]) -> Graph [a]+cayleyGraphS (gs,rs) = graph (vs,es) where -- G vs es where+    rs' = knuthBendix rs+    vs = L.sort $ nfs (gs,rs') -- calling elts would mean we invoked knuthBendix twice+    es = toSet [ L.sort [v,v'] | v <- vs, v' <- nbrs v ] -- toSet orders and removes duplicates+    nbrs v = [rewrite rs' (v ++ [g]) | g <- gs]++-- it would be better if we could use shortlex ordering, but as it stands Graph will use lex ordering+++-- for example, can check+-- isIso (cayleyGraphP [p [[1,2]], p [[2,3]], p [[3,4]]]) (cayleyGraphS (SR._S 4))++++-- given sequence of transpositions, return group elt it represents+fromTranspositions ts = product $ map (\(S i) -> p [[i,i+1]]) ts++-- given sequence of transpositions, return the permutation of [1..n] that it causes+fromTrans ts = [i .^ (g^-1) | i <- [1..n] ] where+    g = fromTranspositions ts+    n = maximum $ supp g+++bubblesort [] = []+bubblesort xs = bubblesort' [] xs where+    bubblesort' ls (r1:r2:rs) = if r1 <= r2 then bubblesort' (r1:ls) (r2:rs) else bubblesort' (r2:ls) (r1:rs)+    bubblesort' ls [r] = bubblesort (reverse ls) ++ [r]++-- given a permutation of [1..n] (as a list), return the transpositions which led to it+toTrans [] = []+toTrans xs = toTrans' 1 [] [] xs where+    toTrans' i ts ls (r1:r2:rs) = +        if r1 <= r2+        then toTrans' (i+1) ts (r1:ls) (r2:rs)         -- no swap needed+        else toTrans' (i+1) (S i : ts) (r2:ls) (r1:rs) -- swap needed+    toTrans' i ts ls [r] = toTrans (reverse ls) ++ ts+-- note that the ts are returned in reverse to the order that they were used+-- this is because we used them to *undo* the permutation - so we performed the *inverse*+-- to get the permutation that led to xs, we have to take the inverse again, which we do by reversing+++-- given a permutation of [1..n] (as a group elt), factor it into transpositions+toTranspositions 1 = []+toTranspositions g = toTrans [i .^ (g^-1) | i <- [1..n] ] where+    n = maximum $ supp g+-- The reason we have g^-1 rather than g is that+-- i .^ g == j tells us that i ends up in the j position whereas+-- i .^ (g^-1) == j tells us that j is what ends up in the i position+-- Clearly it's the latter we want+-- For example, if g = s1 s2 = p [[1,3,2]], then the effect of applying g to [1,2,3] is [2,3,1]+++-- toTranspositions . fromList == toTrans+-- fromTranspositions . toTranspositions == id+-- toTransposition . fromTranspositions == id (for reduced expressions only)+++inversions g = [(i,j) | i <- [1..n], j <- [i+1..n], i .^ g > j .^ g]+    where n = maximum $ supp g++-- it's clear that the word length == number of inversions,+-- since both are equal to bubblesort distance+-- (well actually, need proof that expression returned by bubblesort is shortest, but it's fairly obvious+

@@ -193,11 +193,11 @@         _T = [P $ M.fromList [((x,y),(x,y')) | x <- _X, (y,y') <- M.toList k'] | P k' <- ks]
         -- top group T uses the action of K to permute the fibres
     in _B ++ _T -- semi-direct product of B and T
-
+-- !! Why using M.keysSet rather than supp?
 
 -- embed group elts into Sn - ie, convert so that the set acted on is [1..n]
 toSn gs = [toSn' g | g <- gs] where
-    _X = foldl union [] $ map supp gs   -- the set on which G acts
+    _X = L.sort $ foldl union [] $ map supp gs   -- the set on which G acts
     mapping = M.fromList $ zip _X [1..] -- the mapping from _X to [1..n]
     toSn' g = fromPairs' $ map (\(x,x') -> (mapping M.! x, mapping M.! x')) $ toPairs g
 

@@ -7,23 +7,27 @@ 
 -- REWRITING
 
+-- |Given a list of rewrite rules of the form (left,right), and a word,
+-- rewrite it by repeatedly replacing any left substring in the word by the corresponding right
+rewrite :: (Eq a) => [([a], [a])] -> [a] -> [a]
 rewrite rules word = rewrite' rules word where
     rewrite' (r:rs) xs =
-        case rewrite'' r xs of
+        case rewrite1 r xs of
         Nothing -> rewrite' rs xs
         Just ys -> rewrite' rules ys
     rewrite' [] xs = xs
-rewrite'' (l,r) xs =
+
+rewrite1 (l,r) xs =
     case xs `splitSubstring` l of
     Nothing -> Nothing
     Just (a,b) -> Just (a++r++b)
 
 -- given a string x and a substring b, find if possible (a,c) such that xs = abc
-splitSubstring xs b = splitSubstring' [] xs where
+splitSubstring xs ys = splitSubstring' [] xs where
     splitSubstring' ls [] = Nothing
     splitSubstring' ls (r:rs) =
-        if b `L.isPrefixOf` (r:rs)
-        then Just (reverse ls, drop (length b) (r:rs))
+        if ys `L.isPrefixOf` (r:rs)
+        then Just (reverse ls, drop (length ys) (r:rs))
         else splitSubstring' (r:ls) rs
 -- there might be a more efficient way to do this
 
@@ -61,7 +65,6 @@                     	-- a ++ b ++ c == a ++ l2 -> a ++ r2 (by rule 2)
     reduce rule@(l,r) rules = filter (\(l',r') -> not (L.isInfixOf l l')) rules
         -- [rule' | rule'@(l',r') <- rules, not (l `L.isInfixOf` l')]
--- !! Possible efficiency improvement is to somehow prune the pairs queue, as or after we prune the rules
 
 ordpair x y =
     case shortlex x y of
@@ -132,29 +135,34 @@     sizedPair (si,i,ri) (sj,j,rj) = (si+sj,(i,j),(ri,rj))
 
 
--- Version of knuthBendix that makes sure the initial rules are reduced with respect to each other
-knuthBendix rules = knuthBendix3 (reduce [] rules) where
+-- |Implementation of the Knuth-Bendix algorithm. Given a list of relations, return a confluent rewrite system.
+-- The algorithm is not guaranteed to terminate.
+knuthBendix :: (Ord a) => [([a], [a])] -> [([a], [a])]
+knuthBendix relations = knuthBendix3 (reduce [] rules) where
+    rules = catMaybes [ordpair x y | (x,y) <- relations]
     reduce ls (r:rs) = reduce (r: reduce' r ls) (reduce' r rs)
     reduce ls [] = ls
     reduce' r rules = catMaybes [ordpair (rewrite [r] lhs) (rewrite [r] rhs) | (lhs,rhs) <- rules]
 
 
--- given generators and rules/relations, list all normal forms
--- the rules are assumed to be a confluent rewrite system
+-- |Given generators and a confluent rewrite system, return (normal forms of) all elements
+nfs :: (Ord a) => ([a], [([a], [a])]) -> [[a]]
 nfs (gs,rs) = nfs' [[]] where
-    nfs' [] = [] -- we have run out of words - this is a finite semigroup
+    nfs' [] = [] -- we have run out of words - this monoid is finite
     nfs' ws = let ws' = [g:w | g <- gs, w <- ws, not (any (`L.isPrefixOf` (g:w)) (map fst rs))]
               in ws ++ nfs' ws'
 
+-- |Given generators and relations, return (normal forms of) all elements
+elts :: (Ord a) => ([a], [([a], [a])]) -> [[a]]
 elts (gs,rs) = nfs (gs, knuthBendix rs)
 
 
 -- PRESENTATIONS FOR SOME STANDARD GROUPS
 -- Would like to add a few more to this list
 
-newtype S = S Int deriving (Eq,Ord)
+newtype SGen = S Int deriving (Eq,Ord)
 
-instance Show S where
+instance Show SGen where
     show (S i) = "s" ++ show i
 
 s_ i = S i
@@ -171,18 +179,29 @@     s = [(concat $ replicate 3 [s_ i, s_ (i+1)],[]) | i <- [1..n-2]]
     t = [([s_ i, s_ j, s_ i, s_ j],[]) | i <- [1..n-1], j <- [i+2..n-1]]
 
+-- braid presentation for Sn
+_S' n = (gs, r ++ s ++ t) where
+    gs = map s_ [1..n-1]
+    r = [([s_ i, s_ i], []) | i <- [1..n-1]]
+    s = [([s_ (i+1), s_ i, s_ (i+1)], [s_ i, s_ (i+1), s_ i] ) | i <- [1..n-2]]
+    t = [([s_ i, s_ j, s_ i, s_ j], []) | i <- [1..n-1], j <- [i+2..n-1]]
+
 -- http://en.wikipedia.org/wiki/Triangle_group
--- triangle group
+-- triangle groups - Johnson p127ff
 tri l m n = ("abc", [("aa",""),("bb",""),("cc",""),("ab" ^ l,""),("bc" ^ n,""),("ca" ^ m,"" )])
     where xs ^ i = concat $ replicate i xs
 
--- von Dyck groups
--- The subgroup of index 2 of the triangle group of elts that preserve the orientation of the triangle
+-- von Dyck groups - Johnson p121ff
+-- The subgroup of index 2 in the triangle group consisting of elts that preserve the orientation of the triangle
 _D l m n = ("xy", [("x" ^ l,""), ("y" ^ m,""), ("xy" ^ n,"")])
     where xs ^ i = concat $ replicate i xs
 
--- So 2,3,3 -> tetrahedron; 2,3,4 -> cube/octahedron; 2,3,5 -> dodecahedron/icosahedron
--- 2,2,n, n>=2 -> n-gon bipyramid
--- Other values correspond to Euclidean or Hyperbolic groups, which are infinite
+-- Degenerate cases: n == 1 => cyclic group
+-- l,2,2, l>=2 -> n-gon bipyramid - dihedral group
+-- Spherical case: 1/l+1/m+1/n > 1
+-- 3,3,2 -> tetrahedron; 4,3,2 -> octahedron; 5,3,2 -> icosahedron
+-- Euclidean case: 1/l+1/m+1/n == 1
+-- 3,3,3  4,4,2  6,3,2 
+-- Hyperbolic case: 1/l+1/m+1/n < 1
 
 

@@ -148,12 +148,10 @@ instance Arbitrary F9 where     arbitrary = do x <- arbitrary :: Gen Int                    return (f9 !! (x `mod` 9))-    coarbitrary = undefined -- !! only required if we want to test functions over the type  instance Arbitrary J9 where     arbitrary = do x <- arbitrary :: Gen Int                    return (j9 !! (x `mod` 9))-    coarbitrary = undefined -- !! only required if we want to test functions over the type  prop_NearFieldF9 (a,b,c) = prop_NearField (a,b,c) where     types = (a,b,c) :: (F9,F9,F9)

@@ -245,9 +245,11 @@ factorial n = product [1..toInteger n]
 
 
-
+{-
+-- now moved to TRootSystem
 test1 = all (\(t,n) -> orderWeyl t n == L.genericLength (eltsCoxeter t n))
     [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(F,4),(G,2)]
 
 test2 = all (\(t,n) -> orderWeyl t n == SS.order (weylPerms t n))
     [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(E,6),(F,4),(G,2)]
+-}

@@ -43,7 +43,7 @@     -- arbitrary = do ais <- arbitrary :: Gen [(Integer,[Int])]
     arbitrary = do ais <- sized $ \n -> resize (n `div` 2) arbitrary :: Gen [(Integer,[Int])]
                    return (mpoly ais)
-    coarbitrary = undefined -- !! only required if we want to test functions over the type
+    -- coarbitrary = undefined -- !! only required if we want to test functions over the type
 
 prop_CommRingMPoly (f,g,h) = prop_CommRing (f,g,h) where
     types = (f,g,h) :: (MPoly Grevlex Q, MPoly Grevlex Q, MPoly Grevlex Q)

@@ -13,7 +13,8 @@ import Math.Algebra.Group.PermutationGroup as P -- not used
 import Math.Algebra.Group.SchreierSims as SS
 
-import Math.Algebra.Group.StringRewriting
+-- import Math.Algebra.Group.StringRewriting
+import Math.Algebra.Group.CayleyGraph
 
 
 -- Sources
@@ -61,12 +62,9 @@ -- It is actually rather hard to find graphs which are vertex- and edge-transitive but not arc-transitive, but here is one
 -- Doyle, "A 27-vertex graph that is vertex-transitive and edge-transitive but not 1-transitive"
 -- http://en.wikipedia.org/wiki/Holt_graph
-doyleGraph = G gs es where
-    relations = knuthBendix [("aaaaaaaaa",""), ("ccccccccc",""), ("aaaaaa","ccc"), ("cccccc","aaa"), ("ccccccccac","aaaa"), ("aaaaaaaaca","cccc")]
-    gs = L.sort $ nfs ("ac",relations) -- all elements of the group, reduced to normal form
-    hs = ["a","c","aaaaaaaa","cccccccc"] -- a, c, a^-1, c^-1
-    es = [ [v,v'] | v <- gs, v' <- L.sort [rewrite relations (v ++ h) | h <- hs], v < v']
-    -- so the edges join g to ga, gc, ga^-1, and gc^-1
+doyleGraph = cayleyGraphS (['a','c'],
+    [("aaaaaaaaa",""), ("ccccccccc",""), ("aaaaaa","ccc"), ("cccccc","aaa"), ("ccccccccac","aaaa"), ("aaaaaaaaca","cccc")])
+-- so the vertices are the elts g, and the edges join g to ga, gc, ga^-1, gc^-1
 
 
 srgParamTest = all (uncurry (==)) srgParamTests
@@ -81,6 +79,7 @@     ++ [(srgParams $ hoffmanSingleton, Just (50,7,0,1) ) ]
     ++ [(srgParams $ higmanSimsGraph, Just (100,22,0,6) ) ]
     ++ [(srgParams $ sp (2*r), Just (2^(2*r)-1,2^(2*r-1),2^(2*r-2),2^(2*r-2))) | r <- [2..3] ]
+
 
 graphAutTest = all (uncurry (==)) graphAutTests
 

@@ -32,7 +32,7 @@     -- arbitrary = do ais <- arbitrary :: Gen [(Integer,[Int])]
     arbitrary = do ais <- sized $ \n -> resize (n `div` 2) arbitrary :: Gen [(Integer,[Int])]
                    return (npoly ais)
-    coarbitrary = undefined -- !! only required if we want to test functions over the type
+    -- coarbitrary = undefined -- !! only required if we want to test functions over the type
 
 prop_NonCommRingNPoly (f,g,h) = prop_NonCommRing (f,g,h) where
     types = (f,g,h) :: (NPoly Q Basis, NPoly Q Basis, NPoly Q Basis)

@@ -9,6 +9,7 @@ import Math.Algebra.Group.PermutationGroup as P
 import Math.Algebra.Group.SchreierSims as SS
 import Math.Algebra.Group.RandomSchreierSims as RSS
+import Math.Algebra.Group.CayleyGraph
 import Math.Combinatorics.Graph
 import Math.Combinatorics.GraphAuts
 import Math.Projects.Rubik
@@ -56,16 +57,23 @@                    return (fromList $ unrankSN $ abs r)
                    -- return (perm (abs r))
                    -- return (perm (r^2)) -- to get some larger perms
-    coarbitrary = undefined
+    -- coarbitrary = undefined
 
 
 prop_Group (g,h,k) =
-    g*(h*k)==(g*h)*k           && -- associativity
-    1*g == g && g*1 == g       && -- identity
-    g*g^-1 == 1 && g^-1*g == 1    -- inverse
+    g*(h*k)==(g*h)*k            && -- associativity
+    1*g == g && g*1 == g        && -- identity
+    g*(g^-1) == 1 && (g^-1)*g == 1 -- inverse
 
 prop_GroupPerm (g,h,k) = prop_Group (g,h,k)
     where types = (g,h,k) :: (Permutation Int, Permutation Int, Permutation Int)
+
+
+
+
+prop_Transpositions g =
+    g == (fromTranspositions . toTranspositions) g
+    where types = g :: Permutation Int
 
 
 -- Could do more, like taking arbitrary lists of perms as generators of a group,

@@ -0,0 +1,19 @@+++module Math.Test.TRootSystem where++import Math.Projects.RootSystem+import qualified Math.Algebra.Group.StringRewriting as SG+import qualified Math.Algebra.Group.SchreierSims as SS++import qualified Data.List as L++test = testStringRewriting && testPermutations++-- tests orders of the groups via presentations+testStringRewriting = all (\(t,n) -> orderWeyl t n == L.genericLength (eltsCoxeter t n))+    [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(F,4),(G,2)]++-- tests orders of the groups via permutations+testPermutations = all (\(t,n) -> orderWeyl t n == SS.order (weylPerms t n))+    [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(E,6),(F,4),(G,2)]

@@ -26,8 +26,13 @@         (ker1,im1) = transitiveConstituentHomomorphism gs1 [1..5]         gs2 = [p [[1,2,3],[4,5,6]], p [[1,2],[4,5]]] -- note that the two halves don't move independently         (ker2,im2) = transitiveConstituentHomomorphism gs2 [1,2,3]+        gs3 = [p [[1,2],[4,5]], p [[1,2,3]], p [[4,5,6]] ]+        -- so we can achieve odd permutations in each half, but we can't achieve an odd in one without achieving an odd in the other+        -- hence the order of the group is only half the order of the left image * the order of the right image+        (ker3,im3) = transitiveConstituentHomomorphism gs3 [1,2,3]     in orderSGS ker1 == 120 && orderSGS im1 == 120 &&-       null ker2 && orderSGS im2 == 6+       null ker2 && orderSGS im2 == 6 &&+       orderSGS im3 == 6 && orderSGS ker3 == 3   testBlockSystems =

@@ -8,6 +8,7 @@ import Math.Test.TCommutativeAlgebra
 import Math.Test.TNonCommutativeAlgebra
 import Math.Test.TField
+import Math.Test.TRootSystem
 
 import Test.QuickCheck
 
@@ -19,6 +20,7 @@     ,Math.Test.TFiniteGeometry.test
     ,Math.Test.TCommutativeAlgebra.test
     ,Math.Test.TField.test
+    ,Math.Test.TRootSystem.test
     ]
 
 quickCheckAll =