    -- Copyright (c) David Amos, 2008. All rights reserved.

    module Math.Algebra.Group.StringRewriting where

    import Data.List as L
    import Data.Maybe (catMaybes)

    -- REWRITING

    -- |Given a list of rewrite rules of the form (left,right), and a word,

    -- rewrite it by repeatedly replacing any left substring in the word by the corresponding right

    rewrite :: (Eq a) => [([a], [a])] -> [a] -> [a]
    rewrite :: [([a], [a])] -> [a] -> [a]
    rewrite rules :: [([a], [a])]
    rules word :: [a]
    word = [([a], [a])] -> [a] -> [a]
    rewrite' [([a], [a])]
    rules [a]
    word where
        rewrite' :: [([a], [a])] -> [a] -> [a]
    rewrite' (r :: ([a], [a])
    r:rs :: [([a], [a])]
    rs) xs :: [a]
    xs =
            case ([a], [a]) -> [a] -> Maybe [a]
    forall a. Eq a => ([a], [a]) -> [a] -> Maybe [a]
    rewrite1 ([a], [a])
    r [a]
    xs of
            Nothing -> [([a], [a])] -> [a] -> [a]
    rewrite' [([a], [a])]
    rs [a]
    xs
            Just ys :: [a]
    ys -> [([a], [a])] -> [a] -> [a]
    rewrite' [([a], [a])]
    rules [a]
    ys
        rewrite' [] xs :: [a]
    xs = [a]
    xs

    rewrite1 :: ([a], [a]) -> [a] -> Maybe [a]
    rewrite1 (l :: [a]
    l,r :: [a]
    r) xs :: [a]
    xs =
        case [a]
    xs [a] -> [a] -> Maybe ([a], [a])
    forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
    `splitSubstring` [a]
    l of
        Nothing -> Maybe [a]
    forall a. Maybe a
    Nothing
        Just (a :: [a]
    a,b :: [a]
    b) -> [a] -> Maybe [a]
    forall a. a -> Maybe a
    Just ([a]
    a[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    r[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    b)

    -- given a string x and a substring b, find if possible (a,c) such that xs = abc

    splitSubstring :: [a] -> [a] -> Maybe ([a], [a])
    splitSubstring xs :: [a]
    xs ys :: [a]
    ys = [a] -> [a] -> Maybe ([a], [a])
    splitSubstring' [] [a]
    xs where
        splitSubstring' :: [a] -> [a] -> Maybe ([a], [a])
    splitSubstring' ls :: [a]
    ls [] = Maybe ([a], [a])
    forall a. Maybe a
    Nothing
        splitSubstring' ls :: [a]
    ls (r :: a
    r:rs :: [a]
    rs) =
            if [a]
    ys [a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `L.isPrefixOf` (a
    ra -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    rs)
            then ([a], [a]) -> Maybe ([a], [a])
    forall a. a -> Maybe a
    Just ([a] -> [a]
    forall a. [a] -> [a]
    reverse [a]
    ls, Int -> [a] -> [a]
    forall a. Int -> [a] -> [a]
    drop ([a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [a]
    ys) (a
    ra -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    rs))
            else [a] -> [a] -> Maybe ([a], [a])
    splitSubstring' (a
    ra -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    ls) [a]
    rs
    -- there might be a more efficient way to do this

    -- KNUTH-BENDIX

    -- given two strings x,y, find if possible a,b,c with x=ab y=bc

    findOverlap :: [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap xs :: [a]
    xs ys :: [a]
    ys = [a] -> [a] -> [a] -> Maybe ([a], [a], [a])
    forall a. Eq a => [a] -> [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap' [] [a]
    xs [a]
    ys where
        findOverlap' :: [a] -> [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap' as :: [a]
    as [] cs :: [a]
    cs = Maybe ([a], [a], [a])
    forall a. Maybe a
    Nothing -- (reverse as, [], cs)

        findOverlap' as :: [a]
    as (b :: a
    b:bs :: [a]
    bs) cs :: [a]
    cs =
            if (a
    ba -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    bs) [a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `L.isPrefixOf` [a]
    cs
            then ([a], [a], [a]) -> Maybe ([a], [a], [a])
    forall a. a -> Maybe a
    Just ([a] -> [a]
    forall a. [a] -> [a]
    reverse [a]
    as, a
    ba -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    bs, Int -> [a] -> [a]
    forall a. Int -> [a] -> [a]
    drop ([a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (a
    ba -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    bs)) [a]
    cs)
            else [a] -> [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap' (a
    ba -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    as) [a]
    bs [a]
    cs
    -- there might be a more efficient way to do this

    -- note that findOverlap "abab" "abab" won't find the partial overlap ("ab","ab","ab")

    -- Knuth-Bendix algorithm

    -- http://en.wikipedia.org/wiki/Knuth-Bendix_algorithm

    -- Given a set of rules (assumed already reduced with respect to each other)

    -- return a confluent rewrite system

    knuthBendix1 :: [([a], [a])] -> [([a], [a])]
    knuthBendix1 rules :: [([a], [a])]
    rules = [([a], [a])] -> [(([a], [a]), ([a], [a]))] -> [([a], [a])]
    forall a.
    Ord a =>
    [([a], [a])] -> [(([a], [a]), ([a], [a]))] -> [([a], [a])]
    knuthBendix' [([a], [a])]
    rules [(([a], [a]), ([a], [a]))]
    pairs where
        pairs :: [(([a], [a]), ([a], [a]))]
    pairs = [(([a], [a])
    lri,([a], [a])
    lrj) | ([a], [a])
    lri <- [([a], [a])]
    rules, ([a], [a])
    lrj <- [([a], [a])]
    rules, ([a], [a])
    lri ([a], [a]) -> ([a], [a]) -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ([a], [a])
    lrj]
        knuthBendix' :: [([a], [a])] -> [(([a], [a]), ([a], [a]))] -> [([a], [a])]
    knuthBendix' rules :: [([a], [a])]
    rules [] = [([a], [a])]
    rules -- should reduce in some way

        knuthBendix' rules :: [([a], [a])]
    rules ( ((li :: [a]
    li,ri :: [a]
    ri),(lj :: [a]
    lj,rj :: [a]
    rj)) : ps :: [(([a], [a]), ([a], [a]))]
    ps) =
            case [a] -> [a] -> Maybe ([a], [a], [a])
    forall a. Eq a => [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap [a]
    li [a]
    lj of
            Nothing -> [([a], [a])] -> [(([a], [a]), ([a], [a]))] -> [([a], [a])]
    knuthBendix' [([a], [a])]
    rules [(([a], [a]), ([a], [a]))]
    ps
            Just (a :: [a]
    a,b :: [a]
    b,c :: [a]
    c) -> case [a] -> [a] -> Maybe ([a], [a])
    forall (t :: * -> *) a.
    (Ord (t a), Foldable t) =>
    t a -> t a -> Maybe (t a, t a)
    ordpair ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite [([a], [a])]
    rules ([a]
    ri[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    c)) ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite [([a], [a])]
    rules ([a]
    a[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    rj)) of
                            Nothing -> [([a], [a])] -> [(([a], [a]), ([a], [a]))] -> [([a], [a])]
    knuthBendix' [([a], [a])]
    rules [(([a], [a]), ([a], [a]))]
    ps -- they both reduce to the same thing

                            Just rule' :: ([a], [a])
    rule' -> let rules' :: [([a], [a])]
    rules' = ([a], [a]) -> [([a], [a])] -> [([a], [a])]
    forall a b b. Eq a => ([a], b) -> [([a], b)] -> [([a], b)]
    reduce ([a], [a])
    rule' [([a], [a])]
    rules
                                              ps' :: [(([a], [a]), ([a], [a]))]
    ps' = [(([a], [a]), ([a], [a]))]
    ps [(([a], [a]), ([a], [a]))]
    -> [(([a], [a]), ([a], [a]))] -> [(([a], [a]), ([a], [a]))]
    forall a. [a] -> [a] -> [a]
    ++ [(([a], [a])
    rule',([a], [a])
    rule) | ([a], [a])
    rule <- [([a], [a])]
    rules'] [(([a], [a]), ([a], [a]))]
    -> [(([a], [a]), ([a], [a]))] -> [(([a], [a]), ([a], [a]))]
    forall a. [a] -> [a] -> [a]
    ++ [(([a], [a])
    rule,([a], [a])
    rule') | ([a], [a])
    rule <- [([a], [a])]
    rules']
                                          in [([a], [a])] -> [(([a], [a]), ([a], [a]))] -> [([a], [a])]
    knuthBendix' (([a], [a])
    rule'([a], [a]) -> [([a], [a])] -> [([a], [a])]
    forall a. a -> [a] -> [a]
    :[([a], [a])]
    rules') [(([a], [a]), ([a], [a]))]
    ps'
                        	-- the new rule comes from seeing that

                        	-- a ++ b ++ c == l1 ++ c -> r1 ++ c (by rule 1)

                        	-- a ++ b ++ c == a ++ l2 -> a ++ r2 (by rule 2)

        reduce :: ([a], b) -> [([a], b)] -> [([a], b)]
    reduce rule :: ([a], b)
    rule@(l :: [a]
    l,r :: b
    r) rules :: [([a], b)]
    rules = (([a], b) -> Bool) -> [([a], b)] -> [([a], b)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(l' :: [a]
    l',r' :: b
    r') -> Bool -> Bool
    not ([a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    L.isInfixOf [a]
    l [a]
    l')) [([a], b)]
    rules
            -- [rule' | rule'@(l',r') <- rules, not (l `L.isInfixOf` l')]

    ordpair :: t a -> t a -> Maybe (t a, t a)
    ordpair x :: t a
    x y :: t a
    y =
        case t a -> t a -> Ordering
    forall (t :: * -> *) a.
    (Ord (t a), Foldable t) =>
    t a -> t a -> Ordering
    shortlex t a
    x t a
    y of
        LT -> (t a, t a) -> Maybe (t a, t a)
    forall a. a -> Maybe a
    Just (t a
    y,t a
    x)
        EQ -> Maybe (t a, t a)
    forall a. Maybe a
    Nothing
        GT -> (t a, t a) -> Maybe (t a, t a)
    forall a. a -> Maybe a
    Just (t a
    x,t a
    y)

    shortlex :: t a -> t a -> Ordering
    shortlex x :: t a
    x y :: t a
    y = (Int, t a) -> (Int, t a) -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    x, t a
    x) (t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    y, t a
    y)

    -- for groups, where "letters" will take the form Either a a, we will want a different order, because we will want x^-1 -> x^3 to be the right way round

    -- An optimisation - keep the rules ordered smallest first, and process the pairs smallest first

    -- Appears to be significantly faster on average

    knuthBendix2 :: [([a], [a])] -> [([a], [a])]
    knuthBendix2 rules :: [([a], [a])]
    rules = ((Int, ([a], [a])) -> ([a], [a]))
    -> [(Int, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, ([a], [a])) -> ([a], [a])
    forall a b. (a, b) -> b
    snd ([(Int, ([a], [a]))] -> [([a], [a])])
    -> [(Int, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> a -> b
    $ [(Int, ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]))]
    forall a.
    Ord a =>
    [(Int, ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]))]
    knuthBendix' [(Int, ([a], [a]))]
    rules' [(Int, ([a], [a]), ([a], [a]))]
    pairs where
        rules' :: [(Int, ([a], [a]))]
    rules' = [(Int, ([a], [a]))] -> [(Int, ([a], [a]))]
    forall a. Ord a => [a] -> [a]
    L.sort ([(Int, ([a], [a]))] -> [(Int, ([a], [a]))])
    -> [(Int, ([a], [a]))] -> [(Int, ([a], [a]))]
    forall a b. (a -> b) -> a -> b
    $ (([a], [a]) -> (Int, ([a], [a])))
    -> [([a], [a])] -> [(Int, ([a], [a]))]
    forall a b. (a -> b) -> [a] -> [b]
    map ([a], [a]) -> (Int, ([a], [a]))
    forall (t :: * -> *) a b. Foldable t => (t a, b) -> (Int, (t a, b))
    sizedRule [([a], [a])]
    rules
        pairs :: [(Int, ([a], [a]), ([a], [a]))]
    pairs = [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]), ([a], [a]))]
    forall a. Ord a => [a] -> [a]
    L.sort [(Int, ([a], [a]))
    -> (Int, ([a], [a])) -> (Int, ([a], [a]), ([a], [a]))
    forall a b c. Num a => (a, b) -> (a, c) -> (a, b, c)
    sizedPair (Int, ([a], [a]))
    sri (Int, ([a], [a]))
    srj | (Int, ([a], [a]))
    sri <- [(Int, ([a], [a]))]
    rules', (Int, ([a], [a]))
    srj <- [(Int, ([a], [a]))]
    rules', (Int, ([a], [a]))
    sri (Int, ([a], [a])) -> (Int, ([a], [a])) -> Bool
    forall a. Eq a => a -> a -> Bool
    /= (Int, ([a], [a]))
    srj]
        knuthBendix' :: [(Int, ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]))]
    knuthBendix' rules :: [(Int, ([a], [a]))]
    rules [] = [(Int, ([a], [a]))]
    rules
        knuthBendix' rules :: [(Int, ([a], [a]))]
    rules ( (s :: Int
    s,(li :: [a]
    li,ri :: [a]
    ri),(lj :: [a]
    lj,rj :: [a]
    rj)) : ps :: [(Int, ([a], [a]), ([a], [a]))]
    ps) =
            case [a] -> [a] -> Maybe ([a], [a], [a])
    forall a. Eq a => [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap [a]
    li [a]
    lj of
            Nothing -> [(Int, ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]))]
    knuthBendix' [(Int, ([a], [a]))]
    rules [(Int, ([a], [a]), ([a], [a]))]
    ps
            Just (a :: [a]
    a,b :: [a]
    b,c :: [a]
    c) -> case [a] -> [a] -> Maybe (Int, ([a], [a]))
    forall (t :: * -> *) a.
    (Ord (t a), Foldable t) =>
    t a -> t a -> Maybe (Int, (t a, t a))
    ordpair ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite (((Int, ([a], [a])) -> ([a], [a]))
    -> [(Int, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, ([a], [a])) -> ([a], [a])
    forall a b. (a, b) -> b
    snd [(Int, ([a], [a]))]
    rules) ([a]
    ri[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    c)) ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite (((Int, ([a], [a])) -> ([a], [a]))
    -> [(Int, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, ([a], [a])) -> ([a], [a])
    forall a b. (a, b) -> b
    snd [(Int, ([a], [a]))]
    rules) ([a]
    a[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    rj)) of
                            Nothing -> [(Int, ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]))]
    knuthBendix' [(Int, ([a], [a]))]
    rules [(Int, ([a], [a]), ([a], [a]))]
    ps -- they both reduce to the same thing

                            Just rule' :: (Int, ([a], [a]))
    rule' -> let rules' :: [(Int, ([a], [a]))]
    rules' = ([a], [a]) -> [(Int, ([a], [a]))] -> [(Int, ([a], [a]))]
    forall a b a b.
    Eq a =>
    ([a], b) -> [(a, ([a], b))] -> [(a, ([a], b))]
    reduce ((Int, ([a], [a])) -> ([a], [a])
    forall a b. (a, b) -> b
    snd (Int, ([a], [a]))
    rule') [(Int, ([a], [a]))]
    rules
                                              -- ps' = L.sort $ ps ++ [sizedPair rule' rule | rule <- rules'] ++ [sizedPair rule rule' | rule <- rules']

                                              ps' :: [(Int, ([a], [a]), ([a], [a]))]
    ps' = [(Int, ([a], [a]), ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))]
    forall a. Ord a => [a] -> [a] -> [a]
    merge [(Int, ([a], [a]), ([a], [a]))]
    ps ([(Int, ([a], [a]), ([a], [a]))]
     -> [(Int, ([a], [a]), ([a], [a]))])
    -> [(Int, ([a], [a]), ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))]
    forall a b. (a -> b) -> a -> b
    $ [(Int, ([a], [a]), ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))]
    forall a. Ord a => [a] -> [a] -> [a]
    merge [(Int, ([a], [a]))
    -> (Int, ([a], [a])) -> (Int, ([a], [a]), ([a], [a]))
    forall a b c. Num a => (a, b) -> (a, c) -> (a, b, c)
    sizedPair (Int, ([a], [a]))
    rule' (Int, ([a], [a]))
    rule | (Int, ([a], [a]))
    rule <- [(Int, ([a], [a]))]
    rules'] [(Int, ([a], [a]))
    -> (Int, ([a], [a])) -> (Int, ([a], [a]), ([a], [a]))
    forall a b c. Num a => (a, b) -> (a, c) -> (a, b, c)
    sizedPair (Int, ([a], [a]))
    rule (Int, ([a], [a]))
    rule' | (Int, ([a], [a]))
    rule <- [(Int, ([a], [a]))]
    rules']
                                         in [(Int, ([a], [a]))]
    -> [(Int, ([a], [a]), ([a], [a]))] -> [(Int, ([a], [a]))]
    knuthBendix' ((Int, ([a], [a])) -> [(Int, ([a], [a]))] -> [(Int, ([a], [a]))]
    forall a. Ord a => a -> [a] -> [a]
    L.insert (Int, ([a], [a]))
    rule' [(Int, ([a], [a]))]
    rules') [(Int, ([a], [a]), ([a], [a]))]
    ps'
        reduce :: ([a], b) -> [(a, ([a], b))] -> [(a, ([a], b))]
    reduce rule :: ([a], b)
    rule@(l :: [a]
    l,r :: b
    r) rules :: [(a, ([a], b))]
    rules = ((a, ([a], b)) -> Bool) -> [(a, ([a], b))] -> [(a, ([a], b))]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(s' :: a
    s',(l' :: [a]
    l',r' :: b
    r')) -> Bool -> Bool
    not ([a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    L.isInfixOf [a]
    l [a]
    l')) [(a, ([a], b))]
    rules
        -- reduce rule@(l,r) rules = [rule' | rule'@(s',(l',r')) <- rules, not (l `L.isInfixOf` l')]

        ordpair :: t a -> t a -> Maybe (Int, (t a, t a))
    ordpair x :: t a
    x y :: t a
    y =
            let lx :: Int
    lx = t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    x; ly :: Int
    ly = t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    y in
                case (Int, t a) -> (Int, t a) -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (Int
    lx,t a
    x) (Int
    ly,t a
    y) of
                LT -> (Int, (t a, t a)) -> Maybe (Int, (t a, t a))
    forall a. a -> Maybe a
    Just (Int
    ly,(t a
    y,t a
    x)); EQ -> Maybe (Int, (t a, t a))
    forall a. Maybe a
    Nothing; GT -> (Int, (t a, t a)) -> Maybe (Int, (t a, t a))
    forall a. a -> Maybe a
    Just (Int
    lx,(t a
    x,t a
    y))
        sizedRule :: (t a, b) -> (Int, (t a, b))
    sizedRule (rule :: (t a, b)
    rule@(l :: t a
    l,r :: b
    r)) = (t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    l, (t a, b)
    rule)
        sizedPair :: (a, b) -> (a, c) -> (a, b, c)
    sizedPair (s1 :: a
    s1,r1 :: b
    r1) (s2 :: a
    s2,r2 :: c
    r2) = (a
    s1a -> a -> a
    forall a. Num a => a -> a -> a
    +a
    s2,b
    r1,c
    r2)

    -- merge two ordered lists

    merge :: [a] -> [a] -> [a]
    merge (x :: a
    x:xs :: [a]
    xs) (y :: a
    y:ys :: [a]
    ys) =
        case a -> a -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare a
    x a
    y of
        LT -> a
    x a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : [a] -> [a] -> [a]
    merge [a]
    xs (a
    ya -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    ys)
        GT -> a
    y a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : [a] -> [a] -> [a]
    merge (a
    xa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    xs) [a]
    ys
        EQ -> [Char] -> [a]
    forall a. HasCallStack => [Char] -> a
    error "" -- shouldn't happen in our case

    merge xs :: [a]
    xs ys :: [a]
    ys = [a]
    xs[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    ys

    -- Another optimisation - at the stage where we remove some rules, we remove corresponding pairs too

    -- Seems to perform about 25% faster on large problems (eg Coxeter groups A4-12, B4-12)

    knuthBendix3 :: [([a], [a])] -> [([a], [a])]
    knuthBendix3 rules :: [([a], [a])]
    rules = [(Int, Int, ([a], [a]))]
    -> [(Int, (Int, Int), (([a], [a]), ([a], [a])))]
    -> Int
    -> [([a], [a])]
    forall a a.
    (Num a, Ord a, Ord a) =>
    [(Int, a, ([a], [a]))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))] -> a -> [([a], [a])]
    knuthBendix' [(Int, Int, ([a], [a]))]
    rules' [(Int, (Int, Int), (([a], [a]), ([a], [a])))]
    pairs ([(Int, Int, ([a], [a]))] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Int, Int, ([a], [a]))]
    rules' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + 1) where
        rules' :: [(Int, Int, ([a], [a]))]
    rules' = [(Int, Int, ([a], [a]))] -> [(Int, Int, ([a], [a]))]
    forall a. Ord a => [a] -> [a]
    L.sort ([(Int, Int, ([a], [a]))] -> [(Int, Int, ([a], [a]))])
    -> [(Int, Int, ([a], [a]))] -> [(Int, Int, ([a], [a]))]
    forall a b. (a -> b) -> a -> b
    $ (Int -> ([a], [a]) -> (Int, Int, ([a], [a])))
    -> [Int] -> [([a], [a])] -> [(Int, Int, ([a], [a]))]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\i :: Int
    i (l :: [a]
    l,r :: [a]
    r) -> ([a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [a]
    l,Int
    i,([a]
    l,[a]
    r)) ) [1..] [([a], [a])]
    rules
        pairs :: [(Int, (Int, Int), (([a], [a]), ([a], [a])))]
    pairs = [(Int, (Int, Int), (([a], [a]), ([a], [a])))]
    -> [(Int, (Int, Int), (([a], [a]), ([a], [a])))]
    forall a. Ord a => [a] -> [a]
    L.sort [(Int, Int, ([a], [a]))
    -> (Int, Int, ([a], [a]))
    -> (Int, (Int, Int), (([a], [a]), ([a], [a])))
    forall a a a b b.
    Num a =>
    (a, a, a) -> (a, b, b) -> (a, (a, b), (a, b))
    sizedPair (Int, Int, ([a], [a]))
    ri (Int, Int, ([a], [a]))
    rj | (Int, Int, ([a], [a]))
    ri <- [(Int, Int, ([a], [a]))]
    rules', (Int, Int, ([a], [a]))
    rj <- [(Int, Int, ([a], [a]))]
    rules', (Int, Int, ([a], [a]))
    ri (Int, Int, ([a], [a])) -> (Int, Int, ([a], [a])) -> Bool
    forall a. Eq a => a -> a -> Bool
    /= (Int, Int, ([a], [a]))
    rj]
        knuthBendix' :: [(Int, a, ([a], [a]))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))] -> a -> [([a], [a])]
    knuthBendix' rules :: [(Int, a, ([a], [a]))]
    rules [] k :: a
    k = ((Int, a, ([a], [a])) -> ([a], [a]))
    -> [(Int, a, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(s :: Int
    s,i :: a
    i,r :: ([a], [a])
    r) -> ([a], [a])
    r) [(Int, a, ([a], [a]))]
    rules
        knuthBendix' rules :: [(Int, a, ([a], [a]))]
    rules ( (s :: Int
    s,(i :: a
    i,j :: a
    j),((li :: [a]
    li,ri :: [a]
    ri),(lj :: [a]
    lj,rj :: [a]
    rj))) : ps :: [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps) k :: a
    k =
            case [a] -> [a] -> Maybe ([a], [a], [a])
    forall a. Eq a => [a] -> [a] -> Maybe ([a], [a], [a])
    findOverlap [a]
    li [a]
    lj of
            Nothing -> [(Int, a, ([a], [a]))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))] -> a -> [([a], [a])]
    knuthBendix' [(Int, a, ([a], [a]))]
    rules [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps a
    k
            Just (a :: [a]
    a,b :: [a]
    b,c :: [a]
    c) -> case a -> [a] -> [a] -> Maybe (Int, a, ([a], [a]))
    forall (t :: * -> *) a b.
    (Ord (t a), Foldable t) =>
    b -> t a -> t a -> Maybe (Int, b, (t a, t a))
    ordpair a
    k ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite (((Int, a, ([a], [a])) -> ([a], [a]))
    -> [(Int, a, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, a, ([a], [a])) -> ([a], [a])
    forall a b c. (a, b, c) -> c
    third [(Int, a, ([a], [a]))]
    rules) ([a]
    ri[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    c)) ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite (((Int, a, ([a], [a])) -> ([a], [a]))
    -> [(Int, a, ([a], [a]))] -> [([a], [a])]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, a, ([a], [a])) -> ([a], [a])
    forall a b c. (a, b, c) -> c
    third [(Int, a, ([a], [a]))]
    rules) ([a]
    a[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    rj)) of
                            Nothing -> [(Int, a, ([a], [a]))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))] -> a -> [([a], [a])]
    knuthBendix' [(Int, a, ([a], [a]))]
    rules [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps a
    k -- they both reduce to the same thing

                            Just rule' :: (Int, a, ([a], [a]))
    rule'@(_,_,(l :: [a]
    l,r :: [a]
    r)) ->
                                let (outrules :: [(Int, a, ([a], [a]))]
    outrules,inrules :: [(Int, a, ([a], [a]))]
    inrules) = ((Int, a, ([a], [a])) -> Bool)
    -> [(Int, a, ([a], [a]))]
    -> ([(Int, a, ([a], [a]))], [(Int, a, ([a], [a]))])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    L.partition (\(s' :: Int
    s',i' :: a
    i',(l' :: [a]
    l',r' :: [a]
    r')) -> [a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    L.isInfixOf [a]
    l [a]
    l') [(Int, a, ([a], [a]))]
    rules
                                    removedIndices :: [a]
    removedIndices = ((Int, a, ([a], [a])) -> a) -> [(Int, a, ([a], [a]))] -> [a]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, a, ([a], [a])) -> a
    forall a b c. (a, b, c) -> b
    second [(Int, a, ([a], [a]))]
    outrules
                                    ps' :: [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps' = [(Int, (a, a), (([a], [a]), ([a], [a])))
    p | p :: (Int, (a, a), (([a], [a]), ([a], [a])))
    p@(s :: Int
    s,(i :: a
    i,j :: a
    j),(ri :: ([a], [a])
    ri,rj :: ([a], [a])
    rj)) <- [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps, a
    i a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [a]
    removedIndices, a
    j a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [a]
    removedIndices]
                                    ps'' :: [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps'' = [(Int, (a, a), (([a], [a]), ([a], [a])))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))]
    forall a. Ord a => [a] -> [a] -> [a]
    merge [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps' ([(Int, (a, a), (([a], [a]), ([a], [a])))]
     -> [(Int, (a, a), (([a], [a]), ([a], [a])))])
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))]
    forall a b. (a -> b) -> a -> b
    $ [(Int, (a, a), (([a], [a]), ([a], [a])))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))]
    forall a. Ord a => [a] -> [a] -> [a]
    merge [(Int, a, ([a], [a]))
    -> (Int, a, ([a], [a])) -> (Int, (a, a), (([a], [a]), ([a], [a])))
    forall a a a b b.
    Num a =>
    (a, a, a) -> (a, b, b) -> (a, (a, b), (a, b))
    sizedPair (Int, a, ([a], [a]))
    rule' (Int, a, ([a], [a]))
    rule | (Int, a, ([a], [a]))
    rule <- [(Int, a, ([a], [a]))]
    inrules] [(Int, a, ([a], [a]))
    -> (Int, a, ([a], [a])) -> (Int, (a, a), (([a], [a]), ([a], [a])))
    forall a a a b b.
    Num a =>
    (a, a, a) -> (a, b, b) -> (a, (a, b), (a, b))
    sizedPair (Int, a, ([a], [a]))
    rule (Int, a, ([a], [a]))
    rule' | (Int, a, ([a], [a]))
    rule <- [(Int, a, ([a], [a]))]
    inrules]
                                in [(Int, a, ([a], [a]))]
    -> [(Int, (a, a), (([a], [a]), ([a], [a])))] -> a -> [([a], [a])]
    knuthBendix' ((Int, a, ([a], [a]))
    -> [(Int, a, ([a], [a]))] -> [(Int, a, ([a], [a]))]
    forall a. Ord a => a -> [a] -> [a]
    L.insert (Int, a, ([a], [a]))
    rule' [(Int, a, ([a], [a]))]
    inrules) [(Int, (a, a), (([a], [a]), ([a], [a])))]
    ps'' (a
    ka -> a -> a
    forall a. Num a => a -> a -> a
    +1)
        ordpair :: b -> t a -> t a -> Maybe (Int, b, (t a, t a))
    ordpair k :: b
    k x :: t a
    x y :: t a
    y =
            let lx :: Int
    lx = t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    x; ly :: Int
    ly = t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    y in
                case (Int, t a) -> (Int, t a) -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (Int
    lx,t a
    x) (Int
    ly,t a
    y) of
                LT -> (Int, b, (t a, t a)) -> Maybe (Int, b, (t a, t a))
    forall a. a -> Maybe a
    Just (Int
    ly,b
    k,(t a
    y,t a
    x)); EQ -> Maybe (Int, b, (t a, t a))
    forall a. Maybe a
    Nothing; GT -> (Int, b, (t a, t a)) -> Maybe (Int, b, (t a, t a))
    forall a. a -> Maybe a
    Just (Int
    lx,b
    k,(t a
    x,t a
    y))
        second :: (a, b, c) -> b
    second (s :: a
    s,i :: b
    i,r :: c
    r) = b
    i
        third :: (a, b, c) -> c
    third (s :: a
    s,i :: b
    i,r :: c
    r) = c
    r
        sizedPair :: (a, a, a) -> (a, b, b) -> (a, (a, b), (a, b))
    sizedPair (si :: a
    si,i :: a
    i,ri :: a
    ri) (sj :: a
    sj,j :: b
    j,rj :: b
    rj) = (a
    sia -> a -> a
    forall a. Num a => a -> a -> a
    +a
    sj,(a
    i,b
    j),(a
    ri,b
    rj))

    -- |Implementation of the Knuth-Bendix algorithm. Given a list of relations, return a confluent rewrite system.

    -- The algorithm is not guaranteed to terminate.

    knuthBendix :: (Ord a) => [([a], [a])] -> [([a], [a])]
    knuthBendix :: [([a], [a])] -> [([a], [a])]
    knuthBendix relations :: [([a], [a])]
    relations = [([a], [a])] -> [([a], [a])]
    forall a. Ord a => [([a], [a])] -> [([a], [a])]
    knuthBendix3 ([([a], [a])] -> [([a], [a])] -> [([a], [a])]
    forall a. Ord a => [([a], [a])] -> [([a], [a])] -> [([a], [a])]
    reduce [] [([a], [a])]
    rules) where
        rules :: [([a], [a])]
    rules = [Maybe ([a], [a])] -> [([a], [a])]
    forall a. [Maybe a] -> [a]
    catMaybes [[a] -> [a] -> Maybe ([a], [a])
    forall (t :: * -> *) a.
    (Ord (t a), Foldable t) =>
    t a -> t a -> Maybe (t a, t a)
    ordpair [a]
    x [a]
    y | (x :: [a]
    x,y :: [a]
    y) <- [([a], [a])]
    relations]
        reduce :: [([a], [a])] -> [([a], [a])] -> [([a], [a])]
    reduce ls :: [([a], [a])]
    ls (r :: ([a], [a])
    r:rs :: [([a], [a])]
    rs) = [([a], [a])] -> [([a], [a])] -> [([a], [a])]
    reduce (([a], [a])
    r([a], [a]) -> [([a], [a])] -> [([a], [a])]
    forall a. a -> [a] -> [a]
    : ([a], [a]) -> [([a], [a])] -> [([a], [a])]
    forall a. Ord a => ([a], [a]) -> [([a], [a])] -> [([a], [a])]
    reduce' ([a], [a])
    r [([a], [a])]
    ls) (([a], [a]) -> [([a], [a])] -> [([a], [a])]
    forall a. Ord a => ([a], [a]) -> [([a], [a])] -> [([a], [a])]
    reduce' ([a], [a])
    r [([a], [a])]
    rs)
        reduce ls :: [([a], [a])]
    ls [] = [([a], [a])]
    ls
        reduce' :: ([a], [a]) -> [([a], [a])] -> [([a], [a])]
    reduce' r :: ([a], [a])
    r rules :: [([a], [a])]
    rules = [Maybe ([a], [a])] -> [([a], [a])]
    forall a. [Maybe a] -> [a]
    catMaybes [[a] -> [a] -> Maybe ([a], [a])
    forall (t :: * -> *) a.
    (Ord (t a), Foldable t) =>
    t a -> t a -> Maybe (t a, t a)
    ordpair ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite [([a], [a])
    r] [a]
    lhs) ([([a], [a])] -> [a] -> [a]
    forall a. Eq a => [([a], [a])] -> [a] -> [a]
    rewrite [([a], [a])
    r] [a]
    rhs) | (lhs :: [a]
    lhs,rhs :: [a]
    rhs) <- [([a], [a])]
    rules]

    -- |Given generators and a confluent rewrite system, return (normal forms of) all elements

    nfs :: (Ord a) => ([a], [([a], [a])]) -> [[a]]
    nfs :: ([a], [([a], [a])]) -> [[a]]
    nfs (gs :: [a]
    gs,rs :: [([a], [a])]
    rs) = [[a]] -> [[a]]
    nfs' [[]] where
        nfs' :: [[a]] -> [[a]]
    nfs' [] = [] -- we have run out of words - this monoid is finite

        nfs' ws :: [[a]]
    ws = let ws' :: [[a]]
    ws' = [a
    ga -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    w | a
    g <- [a]
    gs, [a]
    w <- [[a]]
    ws, Bool -> Bool
    not (([a] -> Bool) -> [[a]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ([a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `L.isPrefixOf` (a
    ga -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    w)) ((([a], [a]) -> [a]) -> [([a], [a])] -> [[a]]
    forall a b. (a -> b) -> [a] -> [b]
    map ([a], [a]) -> [a]
    forall a b. (a, b) -> a
    fst [([a], [a])]
    rs))]
                  in [[a]]
    ws [[a]] -> [[a]] -> [[a]]
    forall a. [a] -> [a] -> [a]
    ++ [[a]] -> [[a]]
    nfs' [[a]]
    ws'

    -- |Given generators and relations, return (normal forms of) all elements

    elts :: (Ord a) => ([a], [([a], [a])]) -> [[a]]
    elts :: ([a], [([a], [a])]) -> [[a]]
    elts (gs :: [a]
    gs,rs :: [([a], [a])]
    rs) = ([a], [([a], [a])]) -> [[a]]
    forall a. Ord a => ([a], [([a], [a])]) -> [[a]]
    nfs ([a]
    gs, [([a], [a])] -> [([a], [a])]
    forall a. Ord a => [([a], [a])] -> [([a], [a])]
    knuthBendix [([a], [a])]
    rs)

    -- PRESENTATIONS FOR SOME STANDARD GROUPS

    -- Would like to add a few more to this list

    newtype SGen = S Int deriving (SGen -> SGen -> Bool
    (SGen -> SGen -> Bool) -> (SGen -> SGen -> Bool) -> Eq SGen
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: SGen -> SGen -> Bool
    $c/= :: SGen -> SGen -> Bool
    == :: SGen -> SGen -> Bool
    $c== :: SGen -> SGen -> Bool
    Eq,Eq SGen
    Eq SGen =>
    (SGen -> SGen -> Ordering)
    -> (SGen -> SGen -> Bool)
    -> (SGen -> SGen -> Bool)
    -> (SGen -> SGen -> Bool)
    -> (SGen -> SGen -> Bool)
    -> (SGen -> SGen -> SGen)
    -> (SGen -> SGen -> SGen)
    -> Ord SGen
    SGen -> SGen -> Bool
    SGen -> SGen -> Ordering
    SGen -> SGen -> SGen
    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
    min :: SGen -> SGen -> SGen
    $cmin :: SGen -> SGen -> SGen
    max :: SGen -> SGen -> SGen
    $cmax :: SGen -> SGen -> SGen
    >= :: SGen -> SGen -> Bool
    $c>= :: SGen -> SGen -> Bool
    > :: SGen -> SGen -> Bool
    $c> :: SGen -> SGen -> Bool
    <= :: SGen -> SGen -> Bool
    $c<= :: SGen -> SGen -> Bool
    < :: SGen -> SGen -> Bool
    $c< :: SGen -> SGen -> Bool
    compare :: SGen -> SGen -> Ordering
    $ccompare :: SGen -> SGen -> Ordering
    $cp1Ord :: Eq SGen
    Ord)

    instance Show SGen where
        show :: SGen -> [Char]
    show (S i :: Int
    i) = "s" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    i

    s_ :: Int -> SGen
    s_ i :: Int
    i = Int -> SGen
    S Int
    i
    s1 :: SGen
    s1 = Int -> SGen
    s_ 1
    s2 :: SGen
    s2 = Int -> SGen
    s_ 2
    s3 :: SGen
    s3 = Int -> SGen
    s_ 3

    -- D L Johnson, Presentations of Groups, p62

    -- symmetric group, generated by adjacent transpositions

    _S :: Int -> ([SGen], [([SGen], [a])])
    _S n :: Int
    n = ([SGen]
    gs, [([SGen], [a])]
    forall a. [([SGen], [a])]
    r [([SGen], [a])] -> [([SGen], [a])] -> [([SGen], [a])]
    forall a. [a] -> [a] -> [a]
    ++ [([SGen], [a])]
    forall a. [([SGen], [a])]
    s [([SGen], [a])] -> [([SGen], [a])] -> [([SGen], [a])]
    forall a. [a] -> [a] -> [a]
    ++ [([SGen], [a])]
    forall a. [([SGen], [a])]
    t) where
        gs :: [SGen]
    gs = (Int -> SGen) -> [Int] -> [SGen]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> SGen
    s_ [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]
        r :: [([SGen], [a])]
    r = [([Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ Int
    i],[]) | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]]
        s :: [([SGen], [a])]
    s = [([[SGen]] -> [SGen]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[SGen]] -> [SGen]) -> [[SGen]] -> [SGen]
    forall a b. (a -> b) -> a -> b
    $ Int -> [SGen] -> [[SGen]]
    forall a. Int -> a -> [a]
    replicate 3 [Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1)],[]) | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -2]]
        t :: [([SGen], [a])]
    t = [([Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ Int
    j, Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ Int
    j],[]) | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1], Int
    j <- [Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +2..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]]

    -- braid presentation for Sn

    _S' :: Int -> ([SGen], [([SGen], [SGen])])
    _S' n :: Int
    n = ([SGen]
    gs, [([SGen], [SGen])]
    forall a. [([SGen], [a])]
    r [([SGen], [SGen])] -> [([SGen], [SGen])] -> [([SGen], [SGen])]
    forall a. [a] -> [a] -> [a]
    ++ [([SGen], [SGen])]
    s [([SGen], [SGen])] -> [([SGen], [SGen])] -> [([SGen], [SGen])]
    forall a. [a] -> [a] -> [a]
    ++ [([SGen], [SGen])]
    forall a. [([SGen], [a])]
    t) where
        gs :: [SGen]
    gs = (Int -> SGen) -> [Int] -> [SGen]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> SGen
    s_ [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]
        r :: [([SGen], [a])]
    r = [([Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ Int
    i], []) | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]]
        s :: [([SGen], [SGen])]
    s = [([Int -> SGen
    s_ (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1), Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1)], [Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1), Int -> SGen
    s_ Int
    i] ) | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -2]]
        t :: [([SGen], [a])]
    t = [([Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ Int
    j, Int -> SGen
    s_ Int
    i, Int -> SGen
    s_ Int
    j], []) | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1], Int
    j <- [Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +2..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]]

    -- http://en.wikipedia.org/wiki/Triangle_group

    -- triangle groups - Johnson p127ff

    tri :: Int -> Int -> Int -> ([Char], [([Char], [Char])])
    tri l :: Int
    l m :: Int
    m n :: Int
    n = ("abc", [("aa",""),("bb",""),("cc",""),("ab" [Char] -> Int -> [Char]
    forall a. [a] -> Int -> [a]
    ^ Int
    l,""),("bc" [Char] -> Int -> [Char]
    forall a. [a] -> Int -> [a]
    ^ Int
    n,""),("ca" [Char] -> Int -> [Char]
    forall a. [a] -> Int -> [a]
    ^ Int
    m,"" )])
        where xs :: [a]
    xs ^ :: [a] -> Int -> [a]
    ^ i :: Int
    i = [[a]] -> [a]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[a]] -> [a]) -> [[a]] -> [a]
    forall a b. (a -> b) -> a -> b
    $ Int -> [a] -> [[a]]
    forall a. Int -> a -> [a]
    replicate Int
    i [a]
    xs

    -- von Dyck groups - Johnson p121ff

    -- The subgroup of index 2 in the triangle group consisting of elts that preserve the orientation of the triangle

    _D :: Int -> Int -> Int -> ([Char], [([Char], [Char])])
    _D l :: Int
    l m :: Int
    m n :: Int
    n = ("xy", [("x" [Char] -> Int -> [Char]
    forall a. [a] -> Int -> [a]
    ^ Int
    l,""), ("y" [Char] -> Int -> [Char]
    forall a. [a] -> Int -> [a]
    ^ Int
    m,""), ("xy" [Char] -> Int -> [Char]
    forall a. [a] -> Int -> [a]
    ^ Int
    n,"")])
        where xs :: [a]
    xs ^ :: [a] -> Int -> [a]
    ^ i :: Int
    i = [[a]] -> [a]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[a]] -> [a]) -> [[a]] -> [a]
    forall a b. (a -> b) -> a -> b
    $ Int -> [a] -> [[a]]
    forall a. Int -> a -> [a]
    replicate Int
    i [a]
    xs

    -- Degenerate cases: n == 1 => cyclic group

    -- l,2,2, l>=2 -> n-gon bipyramid - dihedral group

    -- Spherical case: 1/l+1/m+1/n > 1

    -- 3,3,2 -> tetrahedron; 4,3,2 -> octahedron; 5,3,2 -> icosahedron

    -- Euclidean case: 1/l+1/m+1/n == 1

    -- 3,3,3  4,4,2  6,3,2

    -- Hyperbolic case: 1/l+1/m+1/n < 1