-- Copyright (c) David Amos, 2010. All rights reserved.{-# LANGUAGE NoMonomorphismRestriction #-}moduleMath.Algebra.Group.CayleyGraphwhereimportMath.Algebra.Group.StringRewritingasSRimportMath.Combinatorics.Graph-- import Math.Combinatorics.GraphAutsimportMath.Algebra.Group.PermutationGroupasPimportqualifiedData.ListasLimportqualifiedData.SetasStoSet=S.toList.S.fromListdataDigrapha=DG[a][(a,a)]deriving(Eq,Ord,Show)cayleyDigraphPgs=DGvseswherevs=P.eltsgses=[(v,v')|v<-vs,v'<-nbrsv]nbrsv=L.sort[v*g|g<-gs]-- |The Cayley graph (undirected) on the generators (and their inverses),-- for a group given as permutationscayleyGraphP::(Orda,Showa)=>[Permutationa]->Graph(Permutationa)cayleyGraphPgs=graph(vs,es)where-- G vs es wherevs=P.eltsgses=toSet[L.sort[v,v']|v<-vs,v'<-nbrsv]-- toSet orders and removes duplicatesnbrsv=[v*g|g<-gs]cayleyDigraphS(gs,rs)=DGvseswherers'=knuthBendixrsvs=L.sort$nfs(gs,rs')-- calling elts would mean we invoked knuthBendix twicees=[(v,v')|v<-vs,v'<-nbrsv]nbrsv=L.sort[rewriters'(v++[g])|g<-gs]-- |The Cayley graph (undirected) on the generators (and their inverses),-- for a group given as generators and relationscayleyGraphS::(Orda)=>([a],[([a],[a])])->Graph[a]cayleyGraphS(gs,rs)=graph(vs,es)where-- G vs es wherers'=knuthBendixrsvs=L.sort$nfs(gs,rs')-- calling elts would mean we invoked knuthBendix twicees=toSet[L.sort[v,v']|v<-vs,v'<-nbrsv]-- toSet orders and removes duplicatesnbrsv=[rewriters'(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 representsfromTranspositionsts=product$map(\(Si)->p[[i,i+1]])ts-- given sequence of transpositions, return the permutation of [1..n] that it causesfromTransts=[i.^(g^-1)|i<-[1..n]]whereg=fromTranspositionstsn=maximum$suppgbubblesort[]=[]bubblesortxs=bubblesort'[]xswherebubblesort'ls(r1:r2:rs)=ifr1<=r2thenbubblesort'(r1:ls)(r2:rs)elsebubblesort'(r2:ls)(r1:rs)bubblesort'ls[r]=bubblesort(reversels)++[r]-- given a permutation of [1..n] (as a list), return the transpositions which led to ittoTrans[]=[]toTransxs=toTrans'1[][]xswheretoTrans'itsls(r1:r2:rs)=ifr1<=r2thentoTrans'(i+1)ts(r1:ls)(r2:rs)-- no swap neededelsetoTrans'(i+1)(Si:ts)(r2:ls)(r1:rs)-- swap neededtoTrans'itsls[r]=toTrans(reversels)++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 transpositionstoTranspositions1=[]toTranspositionsg=toTrans[i.^(g^-1)|i<-[1..n]]wheren=maximum$suppg-- 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)inversionsg=[(i,j)|i<-[1..n],j<-[i+1..n],i.^g>j.^g]wheren=maximum$suppg-- 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