-- 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 (Digraph a -> Digraph a -> Bool
(Digraph a -> Digraph a -> Bool)
-> (Digraph a -> Digraph a -> Bool) -> Eq (Digraph a)
forall a. Eq a => Digraph a -> Digraph a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Digraph a -> Digraph a -> Bool
$c/= :: forall a. Eq a => Digraph a -> Digraph a -> Bool
== :: Digraph a -> Digraph a -> Bool
$c== :: forall a. Eq a => Digraph a -> Digraph a -> Bool
Eq,Eq (Digraph a)
Eq (Digraph a) =>
(Digraph a -> Digraph a -> Ordering)
-> (Digraph a -> Digraph a -> Bool)
-> (Digraph a -> Digraph a -> Bool)
-> (Digraph a -> Digraph a -> Bool)
-> (Digraph a -> Digraph a -> Bool)
-> (Digraph a -> Digraph a -> Digraph a)
-> (Digraph a -> Digraph a -> Digraph a)
-> Ord (Digraph a)
Digraph a -> Digraph a -> Bool
Digraph a -> Digraph a -> Ordering
Digraph a -> Digraph a -> Digraph a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Digraph a)
forall a. Ord a => Digraph a -> Digraph a -> Bool
forall a. Ord a => Digraph a -> Digraph a -> Ordering
forall a. Ord a => Digraph a -> Digraph a -> Digraph a
min :: Digraph a -> Digraph a -> Digraph a
$cmin :: forall a. Ord a => Digraph a -> Digraph a -> Digraph a
max :: Digraph a -> Digraph a -> Digraph a
$cmax :: forall a. Ord a => Digraph a -> Digraph a -> Digraph a
>= :: Digraph a -> Digraph a -> Bool
$c>= :: forall a. Ord a => Digraph a -> Digraph a -> Bool
> :: Digraph a -> Digraph a -> Bool
$c> :: forall a. Ord a => Digraph a -> Digraph a -> Bool
<= :: Digraph a -> Digraph a -> Bool
$c<= :: forall a. Ord a => Digraph a -> Digraph a -> Bool
< :: Digraph a -> Digraph a -> Bool
$c< :: forall a. Ord a => Digraph a -> Digraph a -> Bool
compare :: Digraph a -> Digraph a -> Ordering
$ccompare :: forall a. Ord a => Digraph a -> Digraph a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Digraph a)
Ord,Int -> Digraph a -> ShowS
[Digraph a] -> ShowS
Digraph a -> String
(Int -> Digraph a -> ShowS)
-> (Digraph a -> String)
-> ([Digraph a] -> ShowS)
-> Show (Digraph a)
forall a. Show a => Int -> Digraph a -> ShowS
forall a. Show a => [Digraph a] -> ShowS
forall a. Show a => Digraph a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Digraph a] -> ShowS
$cshowList :: forall a. Show a => [Digraph a] -> ShowS
show :: Digraph a -> String
$cshow :: forall a. Show a => Digraph a -> String
showsPrec :: Int -> Digraph a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Digraph a -> ShowS
Show)


cayleyDigraphP :: [a] -> Digraph a
cayleyDigraphP gs :: [a]
gs = [a] -> [(a, a)] -> Digraph a
forall a. [a] -> [(a, a)] -> Digraph a
DG [a]
vs [(a, a)]
es where
    vs :: [a]
vs = [a] -> [a]
forall a. (Num a, Ord a) => [a] -> [a]
P.elts [a]
gs
    es :: [(a, a)]
es = [(a
v,a
v') | a
v <- [a]
vs, a
v' <- a -> [a]
nbrs a
v ]
    nbrs :: a -> [a]
nbrs v :: a
v = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
v a -> a -> a
forall a. Num a => a -> a -> a
* a
g | a
g <- [a]
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 :: [Permutation a] -> Graph (Permutation a)
cayleyGraphP gs :: [Permutation a]
gs = ([Permutation a], [[Permutation a]]) -> Graph (Permutation a)
forall t. Ord t => ([t], [[t]]) -> Graph t
graph ([Permutation a]
vs,[[Permutation a]]
es) where -- G vs es where
    vs :: [Permutation a]
vs = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
P.elts [Permutation a]
gs
    es :: [[Permutation a]]
es = [[Permutation a]] -> [[Permutation a]]
forall a. Ord a => [a] -> [a]
toSet [ [Permutation a] -> [Permutation a]
forall a. Ord a => [a] -> [a]
L.sort [Permutation a
v,Permutation a
v'] | Permutation a
v <- [Permutation a]
vs, Permutation a
v' <- Permutation a -> [Permutation a]
nbrs Permutation a
v ] -- toSet orders and removes duplicates
    nbrs :: Permutation a -> [Permutation a]
nbrs v :: Permutation a
v = [Permutation a
v Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
* Permutation a
g | Permutation a
g <- [Permutation a]
gs]


cayleyDigraphS :: ([a], [([a], [a])]) -> Digraph [a]
cayleyDigraphS (gs :: [a]
gs,rs :: [([a], [a])]
rs) = [[a]] -> [([a], [a])] -> Digraph [a]
forall a. [a] -> [(a, a)] -> Digraph a
DG [[a]]
vs [([a], [a])]
es where
    rs' :: [([a], [a])]
rs' = [([a], [a])] -> [([a], [a])]
forall a. Ord a => [([a], [a])] -> [([a], [a])]
knuthBendix [([a], [a])]
rs
    vs :: [[a]]
vs = [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a], [([a], [a])]) -> [[a]]
forall a. Ord a => ([a], [([a], [a])]) -> [[a]]
nfs ([a]
gs,[([a], [a])]
rs') -- calling elts would mean we invoked knuthBendix twice
    es :: [([a], [a])]
es = [([a]
v,[a]
v') | [a]
v <- [[a]]
vs, [a]
v' <- [a] -> [[a]]
nbrs [a]
v ]
    nbrs :: [a] -> [[a]]
nbrs v :: [a]
v = [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort [[([a], [a])] -> [a] -> [a]
forall a. Eq a => [([a], [a])] -> [a] -> [a]
rewrite [([a], [a])]
rs' ([a]
v [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
g]) | a
g <- [a]
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 :: ([a], [([a], [a])]) -> Graph [a]
cayleyGraphS (gs :: [a]
gs,rs :: [([a], [a])]
rs) = ([[a]], [[[a]]]) -> Graph [a]
forall t. Ord t => ([t], [[t]]) -> Graph t
graph ([[a]]
vs,[[[a]]]
es) where -- G vs es where
    rs' :: [([a], [a])]
rs' = [([a], [a])] -> [([a], [a])]
forall a. Ord a => [([a], [a])] -> [([a], [a])]
knuthBendix [([a], [a])]
rs
    vs :: [[a]]
vs = [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a], [([a], [a])]) -> [[a]]
forall a. Ord a => ([a], [([a], [a])]) -> [[a]]
nfs ([a]
gs,[([a], [a])]
rs') -- calling elts would mean we invoked knuthBendix twice
    es :: [[[a]]]
es = [[[a]]] -> [[[a]]]
forall a. Ord a => [a] -> [a]
toSet [ [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort [[a]
v,[a]
v'] | [a]
v <- [[a]]
vs, [a]
v' <- [a] -> [[a]]
nbrs [a]
v ] -- toSet orders and removes duplicates
    nbrs :: [a] -> [[a]]
nbrs v :: [a]
v = [[([a], [a])] -> [a] -> [a]
forall a. Eq a => [([a], [a])] -> [a] -> [a]
rewrite [([a], [a])]
rs' ([a]
v [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
g]) | a
g <- [a]
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 :: [SGen] -> Permutation Int
fromTranspositions ts :: [SGen]
ts = [Permutation Int] -> Permutation Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Permutation Int] -> Permutation Int)
-> [Permutation Int] -> Permutation Int
forall a b. (a -> b) -> a -> b
$ (SGen -> Permutation Int) -> [SGen] -> [Permutation Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(S i :: Int
i) -> [[Int]] -> Permutation Int
forall a. Ord a => [[a]] -> Permutation a
p [[Int
i,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1]]) [SGen]
ts

-- given sequence of transpositions, return the permutation of [1..n] that it causes
fromTrans :: [SGen] -> [Int]
fromTrans ts :: [SGen]
ts = [Int
i Int -> Permutation Int -> Int
forall a. Ord a => a -> Permutation a -> a
.^ (Permutation Int
gPermutation Int -> Integer -> Permutation Int
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1) | Int
i <- [1..Int
n] ] where
    g :: Permutation Int
g = [SGen] -> Permutation Int
fromTranspositions [SGen]
ts
    n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Permutation Int -> [Int]
forall a. Permutation a -> [a]
supp Permutation Int
g


bubblesort :: [a] -> [a]
bubblesort [] = []
bubblesort xs :: [a]
xs = [a] -> [a] -> [a]
bubblesort' [] [a]
xs where
    bubblesort' :: [a] -> [a] -> [a]
bubblesort' ls :: [a]
ls (r1 :: a
r1:r2 :: a
r2:rs :: [a]
rs) = if a
r1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
r2 then [a] -> [a] -> [a]
bubblesort' (a
r1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls) (a
r2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs) else [a] -> [a] -> [a]
bubblesort' (a
r2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls) (a
r1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs)
    bubblesort' ls :: [a]
ls [r :: a
r] = [a] -> [a]
bubblesort ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
r]

-- given a permutation of [1..n] (as a list), return the transpositions which led to it
toTrans :: [a] -> [SGen]
toTrans [] = []
toTrans xs :: [a]
xs = Int -> [SGen] -> [a] -> [a] -> [SGen]
toTrans' 1 [] [] [a]
xs where
    toTrans' :: Int -> [SGen] -> [a] -> [a] -> [SGen]
toTrans' i :: Int
i ts :: [SGen]
ts ls :: [a]
ls (r1 :: a
r1:r2 :: a
r2:rs :: [a]
rs) = 
        if a
r1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
r2
        then Int -> [SGen] -> [a] -> [a] -> [SGen]
toTrans' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [SGen]
ts (a
r1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls) (a
r2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs)         -- no swap needed
        else Int -> [SGen] -> [a] -> [a] -> [SGen]
toTrans' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Int -> SGen
S Int
i SGen -> [SGen] -> [SGen]
forall a. a -> [a] -> [a]
: [SGen]
ts) (a
r2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls) (a
r1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs) -- swap needed
    toTrans' i :: Int
i ts :: [SGen]
ts ls :: [a]
ls [r :: a
r] = [a] -> [SGen]
toTrans ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls) [SGen] -> [SGen] -> [SGen]
forall a. [a] -> [a] -> [a]
++ [SGen]
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 :: Permutation a -> [SGen]
toTranspositions 1 = []
toTranspositions g :: Permutation a
g = [a] -> [SGen]
forall a. Ord a => [a] -> [SGen]
toTrans [a
i a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ (Permutation a
gPermutation a -> Integer -> Permutation a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1) | a
i <- [1..a
n] ] where
    n :: a
n = [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ Permutation a -> [a]
forall a. Permutation a -> [a]
supp Permutation a
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 :: Permutation b -> [(b, b)]
inversions g :: Permutation b
g = [(b
i,b
j) | b
i <- [1..b
n], b
j <- [b
ib -> b -> b
forall a. Num a => a -> a -> a
+1..b
n], b
i b -> Permutation b -> b
forall a. Ord a => a -> Permutation a -> a
.^ Permutation b
g b -> b -> Bool
forall a. Ord a => a -> a -> Bool
> b
j b -> Permutation b -> b
forall a. Ord a => a -> Permutation a -> a
.^ Permutation b
g]
    where n :: b
n = [b] -> b
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([b] -> b) -> [b] -> b
forall a b. (a -> b) -> a -> b
$ Permutation b -> [b]
forall a. Permutation a -> [a]
supp Permutation b
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