```-- 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

```