{-# 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.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]
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
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 ]
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')
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]
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
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')
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 ]
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]
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
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]
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)
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)
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
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
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