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