--
--
--
--
-- Haskell program to compute the fundamental
-- group for a connected simplicial complex.
-- The computed group is presented in terms
-- of generators and relations. This presentation
-- is simplified by eliminating relations where
-- a symbol occurs only once.
--
--
--
-- 
--
-- Author: Erik Palmgren, 
--         Department of Mathematics, 
--         Uppsala University, Sweden
--         palmgren AT math DOT uu DOT se
--         www.math.uu.se/~palmgren
--
-- Hugs source code. Version 3, March 5, 2003  
-- * renaming of generators 
-- * General recursion is avoided.
--
-- (In version 1, Febr. 27, the spanning tree function
-- produced erroneous results in certain cases, not
-- visible in the examples below.)
--
--
-- Sample run: compute the fundamental group of the torus.
--
-- Invoke the Haskell interpreter, and then type what's after 
-- the prompter ">".
--
-- bash$ hugs 
-- ...
-- Prelude> :load fundgrupp2.hs
-- ...
-- Fundamental> torus
-- [[1,2,4],[2,4,5],[2,3,5],[3,5,6],[1,3,6],[1,4,6],[4,5,7],[5,7,8],
-- [5,6,8],[6,8,9],[4,6,9],[4,7,9],[1,7,8],[1,2,8],[2,8,9],[2,3,9],
-- [3,7,9],[1,3,7]]
-- Fundamental> sgp (-1) std torus
-- "<[[1,6],[2,9]] | [1,6][2,9][1,6]^{-1}[2,9]^{-1}=1>"
-- ...
-- Fundamental> :quit
--
--             To see the n:th step in the simplification
--             process type   sgp n std torus   instead.
--             More example complexes below. 
--             std indicates that standard names are given
--             to generators. To obtain shorter expressions,
--             the standard naming convention  std  may be 
--             replaced by  (namer ["a","b"]).
--
-- Fundamental> sgp (-1) (namer ["a","b"]) kleinBottle
--  "<a, b | baab=1>"
--



-- We have used the algorithm suggested in
-- M.A. Armstrong: Basic Topology, Springer 1983.
--
-- The algorithm depends on the following well-known theorem
--
-- Theorem. For a finite, connected simplicial complex K
--          its fundamental group is isomorphic to the finitely
--          presented group G(K,L), where L is a simply
--          connected subcomplex of K which contains all
--          all vertices of K.
--
-- Suppose that the complex K consists of the vertices 
-- 1,2,...,n. Let L be a subcomplex as in the theorem.
-- The group presentation G(K,L) has for generators
--
--    g_{i,j}  where {i,j} varies over 0- or 1-simplices in K.
--    (note {i,i} is a 0-simplex.)
--
-- Its relations are of two kinds
--
--   (1)    g_{i,j}=1 for each 0- or 1-simplex {i,j} in K
--
--   (2)    g_{i,j}g_{j,k}g_{i,k}^{-1} =1 
--          for each 0-, 1- or 2-simplex {i,j,k} in K
--
-- The presentation can be further simplified as follows.
--
--  a) we need only the generators g_{i,j} where i<j.
--  b) relations given by  (1) are needed only for  i<j
--  c) relations according to (2) only when i<j<k.
--
-- L can be constructed as the spanning tree of the
-- graph of the 1-simplices of K.
--
-- The presentation still contains many relations that
-- are easy to eliminate. This is done according to the
-- following process:
--
--  1) Simplify all the relations, working in the free
--     group over the generators. This amounts to cancelling
--     all occurences xx^{-1} and x^{-1}x in a group word
--     for every generator x.
--  2) Delete duplicate relations.
--  3) Delete relations of the form 1=1
--  4) Try to isolate a generator x in some relation
--     w = uxv or ux^{-1}v, where x may not occur in u or v.
--     If successful, delete the generator and substitute 
--     x=u^{-1}wv^{-1} or x=uw^{-1}v, respectively, in 
--     the remaining relations.
--  5) Iterate 1-4 until no more generators can be isolated.
--
--
-- Note: conjugate relations are not detected as
--       as duplicates.
--
--
--
-- A complete verification would include a proof of the
-- theorem.
--


module Fundamental where

--
-- 1. Some general functions for manipulating lists
--

import List (sortBy)

-- The type of equality tests on a type a

type Eqtest a             = a -> a -> Bool


-- filter away elements of a list with property p

filteraway :: (v -> Bool) -> [v] ->[v]
filteraway p [] = []
filteraway p (w:ws) | (p w)     = filteraway p ws
                   | not (p w) = (w : filteraway p ws)


-- delete an element v from a list ws. 
-- compare using given equality test

deleteElt :: v -> (Eqtest v) -> [v] -> [v] 

deleteElt v e ws = filteraway (\y -> (e v y)) ws


-- delete duplicate elements from a list.
-- compare using given equality test

deleteDup :: [v] -> (Eqtest v) -> [v]
deleteDup [] e =[]
deleteDup (w:ws) e = (w: deleteDup (deleteElt w e ws) e)

-- membership predicate.

member :: v-> (Eqtest v) -> [v] -> Bool
member v e [] = False
member v e (x:xs) = if (e v x) then True else (member v e xs) 

-- Find the entry number for an element of a list
-- Produces a number larger than the length of the
-- list if the element isn't there.

entrynumber :: v -> (Eqtest v) -> [v] -> Int
entrynumber v e [] = 1
entrynumber v e (x:xs) = if (e v x) then 1 else (1 + (entrynumber v e xs))


-- find first element with property p or report that there
-- is no such element.

data Result v = No | Value v

find :: (v -> Bool) -> [v] -> (Result v)

find p [] =  No
find p (a:as) = if (p a) then (Value a) else (find p as)

--
-- 2. Data types and basic functions for the free group
--



-- symbols are generators or inverted generators

data Symbol v = G v | I v

inv :: (Symbol v) -> (Symbol v)
inv (G v) = I v
inv (I v) = G v

--  a group word is a list of symbols

type GWord v = [Symbol v]

-- test whether a generator occurs, inverted or not, in a group word

occ :: v -> (Eqtest v) -> (GWord v) -> Bool
occ v e [] = False
occ v e ((G u):ws) = if (e v u) then True else (occ v e ws)
occ v e ((I u):ws) = if (e v u) then True else (occ v e ws)

-- multiply and invert group words

mul :: (GWord v) -> (GWord v) -> (GWord v)
mul x y = x ++ y

invert :: (GWord v) -> (GWord v)
invert [] = []
invert (a:as) = (invert as) ++ [inv a]

-- some useful equality tests

eqSymbol :: (Eqtest v) -> (Symbol v) -> (Symbol v) -> Bool
eqSymbol e (G a) (G b) = (e a b)
eqSymbol e (G a) (I b) = False
eqSymbol e (I a) (G b) = False
eqSymbol e (I a) (I b) = (e a b)

eqGWord :: (Eqtest v) -> (GWord v) -> (GWord v) -> Bool
eqGWord e []     []     = True
eqGWord e []     (b:bs) = False
eqGWord e (a:as) []     = False
eqGWord e (a:as) (b:bs) = if (eqSymbol e a b) then (eqGWord e as bs) else False

eqRelations :: (Eqtest v) -> [GWord v] -> [GWord v] -> Bool
eqRelations e []     []     = True
eqRelations e []     (b:bs) = False
eqRelations e (a:as) []     = False
eqRelations e (a:as) (b:bs) = if (eqGWord e a b) then (eqRelations e as bs) else False


-- reduce a word by deleting all adjacent inverses
--

reduce :: (Eqtest v) -> (GWord v) -> (GWord v)

reduce e w = reverse (red2 e [] w)

--
-- Invariant equality as elements of the free group
--
--    red2 e u v = (reverse v) ++ u
--
-- is maintained for all u, v (proof by induction). Thus 
-- reduce e w = (reverse ((reverse w) ++ [])) = w
--


red2 ::  (Eqtest v) -> (GWord v) -> (GWord v) -> (GWord v)
red2 e []     []     = []
red2 e []     (b:bs) = red2 e [b] bs
red2 e (a:as) (b:bs) = if (inverses e a b) then (red2 e as bs) 
                                           else (red2 e (b:(a:as)) bs)
red2 e x      []     = x

inverses :: (Eqtest v) -> (Symbol v) -> (Symbol v) -> Bool
inverses e (G u) (G v) = False
inverses e (G u) (I v) = (e u v)
inverses e (I u) (G v) = (e u v)
inverses e (I u) (I v) = False



--
-- 3. Functions for simplifying group presentations
--


-- substitute a word  w  for all generators  v  in a word.
-- Invert if generator occurs inverted. 

subst :: (Eqtest v) -> v -> (GWord v) -> (GWord v) -> (GWord v)
subst e v w [] = []
subst e v w ((G u):as) = if (e v u) then w ++ (subst e v w as)
                                    else (G u): (subst e v w as)
subst e v w ((I u):as) = if (e v u) then (invert w) ++ (subst e v w as)
                                    else (I u): (subst e v w as)


-- find all possible "contexts" in a non-empty word.
-- A context in w = [a1,...,an]  is a triple of lists
--   [[a1,...,a(m-1)],[am],[a(m+1),...,an]]
-- 1 <= m < =n

parts :: (GWord v) -> [[GWord v]]
parts [a] = [[[],[a],[]]]
parts (a:as) = [[],[a],as]: (adjoinleft a (parts as))

part1 :: [GWord v] -> (GWord v)
part1 [l,[c],r] = l
part2 :: [GWord v] -> (Symbol v)
part2 [l,[c],r] = c
part3 :: [GWord v] -> (GWord v)
part3 [l,[c],r] = r

adjoinleft a [] = []
adjoinleft a ([l,c,r]:rest) = ([(a:l),c,r]: (adjoinleft a rest))

-- test whether a context can be used to isolate a symbol

mayisolate :: (Eqtest v) -> [GWord v] -> Bool
mayisolate e [u,[(G x)],v] = (not (occ x e u)) && (not (occ x e v))
mayisolate e [u,[(I x)],v] = (not (occ x e u)) && (not (occ x e v))
mayisolate e ws = False

isolcandidates :: (Eqtest v) -> (GWord v) -> [[GWord v]]
isolcandidates e w = filter (\x -> mayisolate e x) (parts w)


-- display generators, symbols, words, relations

showGen u = u



showSymbol (G u)     =  showGen u
showSymbol (I u)     =  (showGen u) ++ "^{-1}"


showGWord [] = "1"
showGWord [a] = showSymbol a
showGWord (a: (b: rest)) = (showSymbol a) ++ (showGWord (b:rest))


showRelations []              = ""
showRelations (e :[])         = (showGWord e)++ "=1"
showRelations (e : (f:rest))  = (showGWord e)++ "=1, " ++ (showRelations (f:rest))

showGenerators []             = ""
showGenerators (e:[])         = showGen e
showGenerators (e : (f:rest)) = (showGen e) ++ ", " ++ (showGenerators (f:rest))

-- A group presentation is a pair consisting of a 
-- list of generators and a list of words over
-- these generators.

data GroupPres v = Grel [v] [GWord v]

generatorlist :: GroupPres v -> [v]
generatorlist (Grel gen rel) = gen

-- strict equality tests for lists and group presentations

eqLists :: (Eqtest v) -> [v] -> [v] -> Bool
eqLists e []     []     = True
eqLists e []     (b:bs) = False
eqLists e (a:as) []     = False
eqLists e (a:as) (b:bs) = if (e a b) then (eqLists e as bs) else False

eqGroupPres :: (Eqtest v) -> (GroupPres v) -> (GroupPres v) -> Bool
eqGroupPres e (Grel g1 r1) (Grel g2 r2) 
   = (eqLists e  g1 g2) && (eqRelations e r1 r2)

-- how to display group presentations

showGroupPres (Grel gen rel) = "<" ++ (showGenerators gen) ++ " | " ++ (showRelations rel) ++ ">"



-- The type of renamer consists of functions which to each
-- list g of generators assigns a sequence of names,
-- where only the first (length g) values need be def.
   
type Renamer v = ([v] ->Int -> String)

-- renameGrouPres f gr
--
-- rename generators of gr using the renaming function f
-- which replaces the n:th element in the generator list with f(n).


renameGen :: [v] -> (Renamer v) -> (Eqtest v) -> v -> String
renameGen gen f e a = f gen (entrynumber a e gen)

renameGWord :: [v] -> (Renamer v) -> (Eqtest v) -> (GWord v) -> (GWord String)
renameGWord gen f e [] = []
renameGWord gen f e ((G u):as) = ((G (f gen (entrynumber u e gen))): (renameGWord gen f e as))
renameGWord gen f e ((I u):as) = ((I (f gen (entrynumber u e gen))): (renameGWord gen f e as))

renameGroupPres :: (Renamer v) -> (Eqtest v) -> (GroupPres v) -> (GroupPres String)
renameGroupPres f e (Grel gen rel)
   =  Grel (map (\x -> (renameGen gen f e x)) gen)
               (map (\w -> (renameGWord gen f e w)) rel)

-- A renaming function
-- namer ["a","b","c"] gen  produces a sequence 
--
--   a,b,c,a_1,b_1,c_1,a_2,b_2,c_2,...
--

namer:: [String] -> [v] -> Int -> String
namer ws gen n = let lth = length ws
                     k = n-1
                 in  
                 if (n <= lth) then (ws !! k)
                               else (ws !!(k `mod` lth))
                                     ++ "_{"++ (show (k `div` lth)) ++ "}"



     



--
-- Simplify group presentations
--


-- eliminate e v w gr: 
-- substitute word   w  for the generator  v
-- in  gr  and then delete the generator  v  from  gr.

eliminate :: (Eqtest v) -> v -> (GWord v) -> (GroupPres v) -> (GroupPres v)

eliminate e v w (Grel gen rel)  
   = (Grel (deleteElt v e gen) (map (\x -> (subst e v w x)) rel))

-- A test for checking whether it is possible
-- to isolate some generator in a word

eliminpossiblewith :: (Eqtest v) -> (GWord v) -> Bool
eliminpossiblewith e [] = False 
eliminpossiblewith e w  = not (emptyList (isolcandidates e w))

-- Reduce the relations of a presentation

reduceGroupPres :: (Eqtest v)  -> (GroupPres v) -> (GroupPres v)
reduceGroupPres e (Grel gen rel) 
   = (Grel gen (map (\x -> (reduce e x)) rel))

-- sort the relations of a presentations in increasing
-- length order

ordlength :: [v] -> [v] -> Ordering
ordlength x y | ((length x) < (length y))  = LT
              | ((length y) < (length x))  = GT
              | ((length x) == (length y)) = EQ

 
sorttolength :: [[v]] -> [[v]]
sorttolength x = sortBy ordlength x

sortGroupPres :: (GroupPres v) -> (GroupPres v)
sortGroupPres (Grel gen rel) 
   = (Grel gen (sorttolength rel))




-- Simplify by deleting empty relations and duplicates
-- (however it will not detect conjugated relations)
 
emptyList :: [v] -> Bool
emptyList [] = True
emptyList (a:as) = False

deleteEmpty :: (GroupPres v) -> (GroupPres v)
deleteEmpty (Grel gen rel)  = (Grel gen (filteraway emptyList rel))

deleteDupRel :: (Eqtest v) -> (GroupPres v) -> (GroupPres v)
deleteDupRel e (Grel gen rel) 
  = (Grel gen (deleteDup rel (\x -> (\y-> eqGWord e x y))))


-- Decide whether the presentation is
-- free (i.e. has no relations)

freeGroupPres :: (GroupPres v) -> Bool
freeGroupPres (Grel gen rel) = emptyList rel


-- simplify n e gr 
--
-- Simplify the group presentation gr by isolating and 
-- eliminating generators in relations.
-- The algorithm stops when, in each relation, every generator 
-- occurs twice after reduction.
-- 
-- n >= 0 is the maximum number of elimination steps
-- n = (-1) as many steps as it takes
--
--

simplify :: Int -> (Eqtest v) -> (GroupPres v) -> (GroupPres v)

simplify n e gr = if (n < 0) 
                  then (simplify2 (length (generatorlist gr)) e gr)
                  else (simplify2 n e gr)             

simplify2 :: Int -> (Eqtest v) -> (GroupPres v) -> (GroupPres v)
simplify2 0 e gr = gr
simplify2 n e gr = let u = simplify1pass e gr
                   in if (eqGroupPres e u gr) then u
                                              else (simplify (n-1) e u)

simplify1pass :: (Eqtest v) -> (GroupPres v) -> (GroupPres v)
simplify1pass e gr = 
  let pre = deleteEmpty (deleteDupRel e (reduceGroupPres e gr))
  in if (freeGroupPres pre) then pre
     else let sorted = sortGroupPres pre
          in (tryEliminate e sorted)

select :: [v] -> v
select (a:as) = a

tryEliminate :: (Eqtest v) -> (GroupPres v) -> (GroupPres v)
tryEliminate e (Grel gen rel) = 
   case (find (\x -> eliminpossiblewith e x) rel) of
        No -> (Grel gen rel)
        (Value w) -> let ws = select (isolcandidates e w)
                         rel2 = deleteElt w (\x -> (\y-> eqGWord e x y)) rel  
                     in 
                     let l = part1 ws
                         c = part2 ws
                         r = part3 ws
                     in case c of 
                        (G u) -> eliminate e u (mul (invert l) (invert r)) (Grel gen rel2) 
                        (I u) -> eliminate e u (mul r l)                   (Grel gen rel2) 

--
-- 4.  Functions for manipulating simplices
--

-- chooseN xs : construct all possible sublists of xs of length N (N=1,2,3)

choose1 xs = [[x] | x <- xs]

choose2 :: [v] -> [[v]]
choose2 [] = []
choose2 (x:xs) = let y = choose1 xs
                 in [(x:z) | z <- y] ++ choose2 xs

choose3 :: [v] -> [[v]]
choose3 [] = []
choose3 (x:xs) = let y = choose2 xs
                 in [(x:z) | z <- y] ++ choose3 xs


-- Test whether an element is a vertex of a simplex

vertexof          :: v -> (Eqtest v) -> [[v]] -> Bool
vertexof a e []     = False
vertexof a e (x:xs) = if (member a e x)  then True   else (vertexof a e xs)

-- Compute the spanning tree of a list of 1-simplices
 

spanning :: (Eqtest v) -> [[v]] -> [[v]]

spanning e [] = []
spanning e (x:xs) = spanning2 e (length xs) [x] xs

spanning2 :: (Eqtest v) -> Int -> [[v]] -> [[v]] -> [[v]]

spanning2 e 0 t  xs = t
spanning2 e n t  xs = let u = extendtree e t xs
                     in  
                     if (length u == length t) then u
                                               else (spanning2 e (n-1) u xs)

extendtree :: (Eqtest v) -> [[v]] -> [[v]] -> [[v]]
extendtree e t [] = t
extendtree e t ([x1,x2]:xs) = if (xor (vertexof x1 e  t)  (vertexof x2 e  t))
                              then extendtree e ([x1,x2]:t) xs
                              else extendtree e t xs

xor :: Bool -> Bool -> Bool
xor True True  = False 
xor True False = True 
xor False True = True 
xor False False = False 
       
--
-- Define the vertices to be the integers
-- (this can be changed)


type Vertex = Integer

eqVertex :: Vertex -> Vertex -> Bool
eqVertex = (==)
ordVertex :: Vertex -> Vertex -> Ordering
ordVertex x y | (x < y) = LT
              | (y < x) = GT
              | (x == y) = EQ

-- A simplex is a list of vertices.
-- It is assumed to be non-empty, ordered according to ordVertex
-- and contain no duplicates.


type Simplex = [Vertex]

-- A simplicial complex is a list of simplices.
-- It is assumed that there are no duplicates in the list.

type Scomplex = [Simplex]

eqSimplex :: Simplex -> Simplex -> Bool
eqSimplex = (==)

-- normalise a complex by ordering each simplex 
-- and then deleting duplicates

normalise :: Scomplex -> Scomplex

normalise sc = deleteDup [ (sortBy ordVertex s) | s <- sc] eqSimplex 


simp1 :: Scomplex -> Scomplex
simp1 [] = []
simp1 (s:sc) = (choose2 s) ++ (simp1 sc)

simplices1 :: Scomplex -> Scomplex
simplices1 sc = normalise (simp1 sc)


simp2 :: Scomplex -> Scomplex
simp2 [] = []
simp2 (s:sc) = (choose3 s) ++ (simp2 sc)

simplices2 :: Scomplex -> Scomplex
simplices2 sc = normalise (simp2 sc)

--
--  5. Construct a group presentation from a simplicial complex
--



-- Calculate a group presentation for a connected complex  sc 
-- by letting the 1-simplices be the generators.


grouppres :: Scomplex -> GroupPres Simplex
grouppres sc = let generators   = simplices1 sc
                   s2   = simplices2 sc
                   tree = spanning (eqVertex) generators
                   relations = [[(G t)] | t <- tree ]
                              ++[[(G (v12 s)), (G (v23 s)), (I (v13 s))] | s <- s2]
               in
               Grel generators relations


v12:: Simplex -> Simplex
v12 [x1,x2,x3] = [x1,x2]
v23:: Simplex -> Simplex
v23 [x1,x2,x3] = [x2,x3]
v13:: Simplex -> Simplex
v13 [x1,x2,x3] = [x1,x3]


--  sgp n naming sc:  compute and simplify group presentation.
--  sc  a simplicial complex (e.g torus below)
--  n>0 limit simplification steps, n = (-1) no limit
--  naming   is a naming function . 
--    The argument  std  give the relevant 1-simplices as generator names. 
--    the argument (namer ["a","b","c"]) replaces these names by
--    a, b, c, a_1, b_1, c_1, a_2, ...

std gen n = show (gen !! (n-1))


sgp n naming sc = showGroupPres (renameGroupPres naming eqSimplex (simplify n eqSimplex (grouppres sc)))


sh gr = showGroupPres gr

test1 sc = reduceGroupPres eqSimplex (grouppres sc)

test2 sc = deleteDupRel eqSimplex (reduceGroupPres eqSimplex (grouppres sc))


--




-- check for connectedness


flatten :: [[v]] -> [v]
flatten []     = []
flatten (a:as) = a ++ (flatten as)

vertexcount :: Scomplex -> Int
vertexcount sc = length (deleteDup (flatten sc) eqVertex)

connected :: Scomplex -> Bool

connected sc = let tree = spanning (eqVertex) (simplices1 sc)
                in (vertexcount sc == vertexcount tree)





--
--  6. Some examples
--



--   Klein's bottle
--
--   1 -- 2 -- 3 -- 1
--   |  / |  / |  / |
--   | /  | /  | /  |
--   4 -- 5 -- 6 -- 7
--   |  / |  / |  / |
--   | /  | /  | /  |
--   7 -- 8 -- 9 -- 4
--   |  / |  / |  / |
--   | /  | /  | /  |
--   1 -- 2 -- 3 -- 1
--



kleinBottle :: Scomplex

kleinBottle =[[1,2,4],[2,3,5],[3,1,6],[2,5,4],[3,6,5],[1,7,6],[4,5,7],[5,6,8],[6,7,9],[5,8,7],[6,9,8],[7,4,9],[7,8,1],[8,9,2],[9,4,3],[8,2,1],[9,3,2],[4,1,3]]

-- A bocquet of four discs

discs = [[1,2,3],[1,4,5],[1,6,7],[1,8,9]]

-- Obtain circles by considering only the 1-simplices
-- of discs.

circles = simplices1 discs


--   projective plane
--
--   1 -- 2 -- 3 -- 4
--   |  / |  / |  / |
--   | /  | /  | /  |
--   5 -- 6 -- 7 -- 8
--   |  / |  / |  / |
--   | /  | /  | /  |
--   8 -- 10 --11-- 5
--   |  / |  / |  / |
--   | /  | /  | /  |
--   4 -- 3 -- 2 -- 1
--




projective = [[1,2,5],[2,5,6],[2,3,6],[3,6,7],[3,4,7],[4,7,8],[5,6,8],[6,8,10],[6,7,10],[7,10,11],[7,8,11],[5,8,11],[4,8,10],[3,4,10],[3,10,11],[2,3,11],[2,5,11],[1,2,5]]


--   torus
--
--   1 -- 2 -- 3 -- 1
--   |  / |  / |  / |
--   | /  | /  | /  |
--   4 -- 5 -- 6 -- 4
--   |  / |  / |  / |
--   | /  | /  | /  |
--   7 -- 8 -- 9 -- 7
--   |  / |  / |  / |
--   | /  | /  | /  |
--   1 -- 2 -- 3 -- 1
--



torus = [[1,2,4],[2,4,5],[2,3,5],[3,5,6],[1,3,6],[1,4,6],[4,5,7],[5,7,8],[5,6,8],[6,8,9],[4,6,9],[4,7,9],[1,7,8],[1,2,8],[2,8,9],[2,3,9],[3,7,9],[1,3,7]]