Word Problem for Braid Group

word_problem_braid_group.hs

default (Int, Integer, Rational, Double)

if' :: Bool -> a -> a -> a
if' True  x _ = x
if' False _ y = y

isBraidIdentity x n = 
  [1..n] == concat (map (braidReduce x) [[y] | y <- [1..n]])

braidReduce = flip (foldr homomorphism)

homomorphism :: Int -> [Int] -> [Int]
homomorphism i list =
  (freeReduce . concat. (map func)) list
  where func = if' (i>0) (sigma i) (invSigma (-i))

sign i 
  | i < 0 = -1
  | otherwise = 1

sigma i j
  | abs j == i+1 && j>0  = coef [i+1, i, -(i+1)]
  | abs j == i+1 && j<0  = coef (reverse [i+1, i, -(i+1)])
  | abs j == i           = coef [i+1]
  | otherwise            = [j]
  where coef = map (*(sign j))

invSigma i j
  | abs j == i+1   = coef [i]
  | abs j == i && j<0  = coef (reverse [-i, (i+1), i])
  | abs j == i && j>0  = coef [-i, (i+1), i]
  | otherwise  = [j]
  where coef = map (*(sign j))

freeReduce []   = []
freeReduce (x:xs)
    | xs == [] || length reduced == 0   = [x]
    | x == -(head reduced)              = tail reduced
    | otherwise                         = x:reduced
    where reduced = freeReduce xs