-- Copyright (c) David Amos, 2010. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} module Math.Algebra.Group.CayleyGraph where import Math.Core.Utils hiding (elts) 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 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