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