-- | Words in free groups (and free powers of cyclic groups).
--
-- This module is not re-exported by "Math.Combinat"
--
{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}
module Math.Combinat.Groups.Free where

--------------------------------------------------------------------------------

-- new Base exports "Word" from Data.Word...
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,7,1)
import Prelude hiding ( Word )
#endif
#elif __GLASGOW_HASKELL__ >= 709
import Prelude hiding ( Word )
#endif

import Data.Char     ( chr )
import Data.List     ( mapAccumL , groupBy )

import Control.Monad ( liftM )
import System.Random

import Math.Combinat.Numbers
import Math.Combinat.Sign
import Math.Combinat.Helper

--------------------------------------------------------------------------------
-- * Words

-- | A generator of a (free) group, indexed by which \"copy\" of the group we are dealing with.
data Generator idx
  = Gen !idx          -- @a@
  | Inv !idx          -- @a^(-1)@
  deriving (Generator idx -> Generator idx -> Bool
forall idx. Eq idx => Generator idx -> Generator idx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Generator idx -> Generator idx -> Bool
$c/= :: forall idx. Eq idx => Generator idx -> Generator idx -> Bool
== :: Generator idx -> Generator idx -> Bool
$c== :: forall idx. Eq idx => Generator idx -> Generator idx -> Bool
Eq,Generator idx -> Generator idx -> Bool
Generator idx -> Generator idx -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {idx}. Ord idx => Eq (Generator idx)
forall idx. Ord idx => Generator idx -> Generator idx -> Bool
forall idx. Ord idx => Generator idx -> Generator idx -> Ordering
forall idx.
Ord idx =>
Generator idx -> Generator idx -> Generator idx
min :: Generator idx -> Generator idx -> Generator idx
$cmin :: forall idx.
Ord idx =>
Generator idx -> Generator idx -> Generator idx
max :: Generator idx -> Generator idx -> Generator idx
$cmax :: forall idx.
Ord idx =>
Generator idx -> Generator idx -> Generator idx
>= :: Generator idx -> Generator idx -> Bool
$c>= :: forall idx. Ord idx => Generator idx -> Generator idx -> Bool
> :: Generator idx -> Generator idx -> Bool
$c> :: forall idx. Ord idx => Generator idx -> Generator idx -> Bool
<= :: Generator idx -> Generator idx -> Bool
$c<= :: forall idx. Ord idx => Generator idx -> Generator idx -> Bool
< :: Generator idx -> Generator idx -> Bool
$c< :: forall idx. Ord idx => Generator idx -> Generator idx -> Bool
compare :: Generator idx -> Generator idx -> Ordering
$ccompare :: forall idx. Ord idx => Generator idx -> Generator idx -> Ordering
Ord,Int -> Generator idx -> ShowS
forall idx. Show idx => Int -> Generator idx -> ShowS
forall idx. Show idx => [Generator idx] -> ShowS
forall idx. Show idx => Generator idx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Generator idx] -> ShowS
$cshowList :: forall idx. Show idx => [Generator idx] -> ShowS
show :: Generator idx -> String
$cshow :: forall idx. Show idx => Generator idx -> String
showsPrec :: Int -> Generator idx -> ShowS
$cshowsPrec :: forall idx. Show idx => Int -> Generator idx -> ShowS
Show,ReadPrec [Generator idx]
ReadPrec (Generator idx)
ReadS [Generator idx]
forall idx. Read idx => ReadPrec [Generator idx]
forall idx. Read idx => ReadPrec (Generator idx)
forall idx. Read idx => Int -> ReadS (Generator idx)
forall idx. Read idx => ReadS [Generator idx]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Generator idx]
$creadListPrec :: forall idx. Read idx => ReadPrec [Generator idx]
readPrec :: ReadPrec (Generator idx)
$creadPrec :: forall idx. Read idx => ReadPrec (Generator idx)
readList :: ReadS [Generator idx]
$creadList :: forall idx. Read idx => ReadS [Generator idx]
readsPrec :: Int -> ReadS (Generator idx)
$creadsPrec :: forall idx. Read idx => Int -> ReadS (Generator idx)
Read)

-- | The index of a generator
genIdx :: Generator idx -> idx
genIdx :: forall idx. Generator idx -> idx
genIdx Generator idx
g = case Generator idx
g of
  Gen idx
x -> idx
x
  Inv idx
x -> idx
x

-- | The sign of the (exponent of the) generator (that is, the generator is 'Plus', the inverse is 'Minus')
genSign :: Generator idx -> Sign
genSign :: forall idx. Generator idx -> Sign
genSign Generator idx
g = case Generator idx
g of { Gen idx
_ -> Sign
Plus ; Inv idx
_ -> Sign
Minus }  

genSignValue :: Generator idx -> Int
genSignValue :: forall idx. Generator idx -> Int
genSignValue Generator idx
g = case Generator idx
g of { Gen idx
_ -> (Int
1::Int) ; Inv idx
_ -> (-Int
1::Int) } 

-- | keep the index, but return always the 'Gen' one.
absGen :: Generator idx -> Generator idx 
absGen :: forall idx. Generator idx -> Generator idx
absGen Generator idx
g = case Generator idx
g of
  Gen idx
x -> forall idx. idx -> Generator idx
Gen idx
x
  Inv idx
x -> forall idx. idx -> Generator idx
Gen idx
x

-- | A /word/, describing (non-uniquely) an element of a group.
-- The identity element is represented (among others) by the empty word.
type Word idx = [Generator idx] 

--------------------------------------------------------------------------------

-- | Generators are shown as small letters: @a@, @b@, @c@, ...
-- and their inverses are shown as capital letters, so @A=a^-1@, @B=b^-1@, etc.
showGen :: Generator Int -> Char
showGen :: Generator Int -> Char
showGen (Gen Int
i) = Int -> Char
chr (Int
96forall a. Num a => a -> a -> a
+Int
i)
showGen (Inv Int
i) = Int -> Char
chr (Int
64forall a. Num a => a -> a -> a
+Int
i)

showWord :: Word Int -> String
showWord :: Word Int -> String
showWord = forall a b. (a -> b) -> [a] -> [b]
map Generator Int -> Char
showGen

--------------------------------------------------------------------------------
  
instance Functor Generator where
  fmap :: forall a b. (a -> b) -> Generator a -> Generator b
fmap a -> b
f Generator a
g = case Generator a
g of 
    Gen a
x -> forall idx. idx -> Generator idx
Gen (a -> b
f a
x) 
    Inv a
y -> forall idx. idx -> Generator idx
Inv (a -> b
f a
y)
    
--------------------------------------------------------------------------------

-- | The inverse of a generator
inverseGen :: Generator a -> Generator a
inverseGen :: forall idx. Generator idx -> Generator idx
inverseGen Generator a
g = case Generator a
g of
  Gen a
x -> forall idx. idx -> Generator idx
Inv a
x
  Inv a
x -> forall idx. idx -> Generator idx
Gen a
x

-- | The inverse of a word
inverseWord :: Word a -> Word a
inverseWord :: forall a. Word a -> Word a
inverseWord = forall a b. (a -> b) -> [a] -> [b]
map forall idx. Generator idx -> Generator idx
inverseGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

-- | Lists all words of the given length (total number will be @(2g)^n@).
-- The numbering of the generators is @[1..g]@.
allWords 
  :: Int         -- ^ @g@ = number of generators 
  -> Int         -- ^ @n@ = length of the word
  -> [Word Int]
allWords :: Int -> Int -> [Word Int]
allWords Int
g = forall {t}. (Eq t, Num t) => t -> [Word Int]
go where
  go :: t -> [Word Int]
go !t
0 = [[]]
  go !t
n = [ Generator Int
xforall a. a -> [a] -> [a]
:Word Int
xs | Word Int
xs <- t -> [Word Int]
go (t
nforall a. Num a => a -> a -> a
-t
1) , Generator Int
x <- Word Int
elems ]
  elems :: Word Int
elems =  [ forall idx. idx -> Generator idx
Gen Int
a | Int
a<-[Int
1..Int
g] ]
        forall a. [a] -> [a] -> [a]
++ [ forall idx. idx -> Generator idx
Inv Int
a | Int
a<-[Int
1..Int
g] ]

-- | Lists all words of the given length which do not contain inverse generators
-- (total number will be @g^n@).
-- The numbering of the generators is @[1..g]@.
allWordsNoInv 
  :: Int         -- ^ @g@ = number of generators 
  -> Int         -- ^ @n@ = length of the word
  -> [Word Int]
allWordsNoInv :: Int -> Int -> [Word Int]
allWordsNoInv Int
g = forall {t}. (Eq t, Num t) => t -> [Word Int]
go where
  go :: t -> [Word Int]
go !t
0 = [[]]
  go !t
n = [ Generator Int
xforall a. a -> [a] -> [a]
:Word Int
xs | Word Int
xs <- t -> [Word Int]
go (t
nforall a. Num a => a -> a -> a
-t
1) , Generator Int
x <- Word Int
elems ]
  elems :: Word Int
elems = [ forall idx. idx -> Generator idx
Gen Int
a | Int
a<-[Int
1..Int
g] ]

--------------------------------------------------------------------------------
-- * Random words

-- | A random group generator (or its inverse) between @1@ and @g@
randomGenerator
  :: RandomGen g
  => Int         -- ^ @g@ = number of generators 
  -> g -> (Generator Int, g)
randomGenerator :: forall g. RandomGen g => Int -> g -> (Generator Int, g)
randomGenerator !Int
d !g
g0 = (Generator Int
gen, g
g2) where
  (Bool
b, !g
g1) = forall a g. (Random a, RandomGen g) => g -> (a, g)
random        g
g0
  (Int
k, !g
g2) = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
1,Int
d) g
g1
  gen :: Generator Int
gen = if Bool
b then forall idx. idx -> Generator idx
Gen Int
k else forall idx. idx -> Generator idx
Inv Int
k

-- | A random group generator (but never its inverse) between @1@ and @g@
randomGeneratorNoInv
  :: RandomGen g
  => Int         -- ^ @g@ = number of generators 
  -> g -> (Generator Int, g)
randomGeneratorNoInv :: forall g. RandomGen g => Int -> g -> (Generator Int, g)
randomGeneratorNoInv !Int
d !g
g0 = (forall idx. idx -> Generator idx
Gen Int
k, g
g1) where
  (!Int
k, !g
g1) = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
1,Int
d) g
g0

-- | A random word of length @n@ using @g@ generators (or their inverses)
randomWord 
  :: RandomGen g
  => Int         -- ^ @g@ = number of generators 
  -> Int         -- ^ @n@ = length of the word
  -> g -> (Word Int, g)
randomWord :: forall g. RandomGen g => Int -> Int -> g -> (Word Int, g)
randomWord !Int
d !Int
n !g
g0 = (Word Int
word,g
g1) where
  (g
g1,Word Int
word) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\g
g Int
_ -> forall a b. (a, b) -> (b, a)
swap (forall g. RandomGen g => Int -> g -> (Generator Int, g)
randomGenerator Int
d g
g)) g
g0 [Int
1..Int
n]   

-- | A random word of length @n@ using @g@ generators (but not their inverses)
randomWordNoInv
  :: RandomGen g
  => Int         -- ^ @g@ = number of generators 
  -> Int         -- ^ @n@ = length of the word
  -> g -> (Word Int, g)
randomWordNoInv :: forall g. RandomGen g => Int -> Int -> g -> (Word Int, g)
randomWordNoInv !Int
d !Int
n !g
g0 = (Word Int
word,g
g1) where
  (g
g1,Word Int
word) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\g
g Int
_ -> forall a b. (a, b) -> (b, a)
swap (forall g. RandomGen g => Int -> g -> (Generator Int, g)
randomGeneratorNoInv Int
d g
g)) g
g0 [Int
1..Int
n]   
  
--------------------------------------------------------------------------------
-- * The free group on @g@ generators

{-# SPECIALIZE multiplyFree        :: Word Int -> Word Int -> Word Int #-}
{-# SPECIALIZE equivalentFree      :: Word Int -> Word Int -> Bool     #-}
{-# SPECIALIZE reduceWordFree      :: Word Int -> Word Int #-}
{-# SPECIALIZE reduceWordFreeNaive :: Word Int -> Word Int #-}

-- | Multiplication of the free group (returns the reduced result). It is true
-- for any two words w1 and w2 that
--
-- > multiplyFree (reduceWordFree w1) (reduceWord w2) = multiplyFree w1 w2
--
multiplyFree :: Eq idx => Word idx -> Word idx -> Word idx
multiplyFree :: forall idx. Eq idx => Word idx -> Word idx -> Word idx
multiplyFree Word idx
w1 Word idx
w2 = forall idx. Eq idx => Word idx -> Word idx
reduceWordFree (Word idx
w1 forall a. [a] -> [a] -> [a]
++ Word idx
w2)

-- | Decides whether two words represent the same group element in the free group
equivalentFree :: Eq idx => Word idx -> Word idx -> Bool
equivalentFree :: forall idx. Eq idx => Word idx -> Word idx -> Bool
equivalentFree Word idx
w1 Word idx
w2 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall idx. Eq idx => Word idx -> Word idx
reduceWordFree forall a b. (a -> b) -> a -> b
$ Word idx
w1 forall a. [a] -> [a] -> [a]
++ forall a. Word a -> Word a
inverseWord Word idx
w2

-- | Reduces a word in a free group by repeatedly removing @x*x^(-1)@ and
-- @x^(-1)*x@ pairs. The set of /reduced words/ forms the free group; the
-- multiplication is obtained by concatenation followed by reduction.
--
reduceWordFree :: Eq idx => Word idx -> Word idx
reduceWordFree :: forall idx. Eq idx => Word idx -> Word idx
reduceWordFree = forall idx. Eq idx => Word idx -> Word idx
loop where

  loop :: Word a -> Word a
loop Word a
w = case forall a. Eq a => Word a -> Maybe (Word a)
reduceStep Word a
w of
    Maybe (Word a)
Nothing -> Word a
w
    Just Word a
w' -> Word a -> Word a
loop Word a
w'
  
  reduceStep :: Eq a => Word a -> Maybe (Word a)
  reduceStep :: forall a. Eq a => Word a -> Maybe (Word a)
reduceStep = forall {a}. Eq a => Bool -> [Generator a] -> Maybe [Generator a]
go Bool
False where    
    go :: Bool -> [Generator a] -> Maybe [Generator a]
go !Bool
changed [Generator a]
w = case [Generator a]
w of
      (Gen a
x : Inv a
y : [Generator a]
rest) | a
xforall a. Eq a => a -> a -> Bool
==a
y   -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Inv a
x : Gen a
y : [Generator a]
rest) | a
xforall a. Eq a => a -> a -> Bool
==a
y   -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Generator a
this : [Generator a]
rest)                   -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator a
thisforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ Bool -> [Generator a] -> Maybe [Generator a]
go Bool
changed [Generator a]
rest
      [Generator a]
_                               -> if Bool
changed then forall a. a -> Maybe a
Just [Generator a]
w else forall a. Maybe a
Nothing


-- | Naive (but canonical) reduction algorithm for the free groups
reduceWordFreeNaive :: Eq idx => Word idx -> Word idx
reduceWordFreeNaive :: forall idx. Eq idx => Word idx -> Word idx
reduceWordFreeNaive = [Generator idx] -> [Generator idx]
loop where
  loop :: [Generator idx] -> [Generator idx]
loop [Generator idx]
w = let w' :: [Generator idx]
w' = [Generator idx] -> [Generator idx]
step [Generator idx]
w in if [Generator idx]
wforall a. Eq a => a -> a -> Bool
/=[Generator idx]
w' then [Generator idx] -> [Generator idx]
loop [Generator idx]
w' else [Generator idx]
w
  step :: [Generator idx] -> [Generator idx]
step   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Word a -> Word a
worker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating forall idx. Generator idx -> idx
genIdx) where
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs 
    | Int
sforall a. Ord a => a -> a -> Bool
>Int
0       = forall a. Int -> a -> [a]
replicate      Int
s  (forall idx. idx -> Generator idx
Gen idx
i)
    | Int
sforall a. Ord a => a -> a -> Bool
<Int
0       = forall a. Int -> a -> [a]
replicate (forall a. Num a => a -> a
abs Int
s) (forall idx. idx -> Generator idx
Inv idx
i)
    | Bool
otherwise = []
    where 
      i :: idx
i = forall idx. Generator idx -> idx
genIdx (forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = forall a. Num a => [a] -> a
sum' (forall a b. (a -> b) -> [a] -> [b]
map forall idx. Generator idx -> Int
genSignValue [Generator idx]
gs)

--------------------------------------------------------------------------------

-- | Counts the number of words of length @n@ which reduce to the identity element.
--
-- Generating function is @Gf_g(u) = \\frac {2g-1} { g-1 + g \\sqrt{ 1 - (8g-4)u^2 } }@
--
countIdentityWordsFree
  :: Int   -- ^ g = number of generators in the free group
  -> Int   -- ^ n = length of the unreduced word
  -> Integer
countIdentityWordsFree :: Int -> Int -> Integer
countIdentityWordsFree Int
g Int
n = Int -> Int -> Int -> Integer
countWordReductionsFree Int
g Int
n Int
0
  
-- | Counts the number of words of length @n@ whose reduced form has length @k@
-- (clearly @n@ and @k@ must have the same parity for this to be nonzero):
--
-- > countWordReductionsFree g n k == sum [ 1 | w <- allWords g n, k == length (reduceWordFree w) ]
--
countWordReductionsFree 
  :: Int   -- ^ g = number of generators in the free group
  -> Int   -- ^ n = length of the unreduced word
  -> Int   -- ^ k = length of the reduced word
  -> Integer
countWordReductionsFree :: Int -> Int -> Int -> Integer
countWordReductionsFree Int
gens_ Int
nn_ Int
kk_
  | Integer
nnforall a. Eq a => a -> a -> Bool
==Integer
0              = if Integer
kforall a. Eq a => a -> a -> Bool
==Integer
0 then Integer
1 else Integer
0
  | forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& Integer
kk forall a. Eq a => a -> a -> Bool
== Integer
0 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) (Integer
n  forall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
ggforall a b. (Num a, Integral b) => a -> b -> a
^(Integer
i  ) forall a. Num a => a -> a -> a
* (Integer
ggforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
n  forall a. Num a => a -> a -> a
-Integer
i  ) forall a. Num a => a -> a -> a
* (   Integer
i) ) forall a. Integral a => a -> a -> a
`div` (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
n  ] ]
  | forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& forall a. Integral a => a -> Bool
even Integer
kk = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) (Integer
nforall a. Num a => a -> a -> a
-Integer
kforall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
ggforall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iforall a. Num a => a -> a -> a
+Integer
1) forall a. Num a => a -> a -> a
* (Integer
ggforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nforall a. Num a => a -> a -> a
+Integer
kforall a. Num a => a -> a -> a
-Integer
iforall a. Num a => a -> a -> a
-Integer
1) forall a. Num a => a -> a -> a
* (Integer
kkforall a. Num a => a -> a -> a
+Integer
i) ) forall a. Integral a => a -> a -> a
`div` (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nforall a. Num a => a -> a -> a
-Integer
k] ] 
  | forall a. Integral a => a -> Bool
odd  Integer
nn Bool -> Bool -> Bool
&& forall a. Integral a => a -> Bool
odd  Integer
kk = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) (Integer
nforall a. Num a => a -> a -> a
-Integer
kforall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
ggforall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iforall a. Num a => a -> a -> a
+Integer
1) forall a. Num a => a -> a -> a
* (Integer
ggforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nforall a. Num a => a -> a -> a
+Integer
kforall a. Num a => a -> a -> a
-Integer
i  ) forall a. Num a => a -> a -> a
* (Integer
kkforall a. Num a => a -> a -> a
+Integer
i) ) forall a. Integral a => a -> a -> a
`div` (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nforall a. Num a => a -> a -> a
-Integer
k] ]
  | Bool
otherwise          = Integer
0  
  where
    g :: Integer
g  = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gens_ :: Integer
    nn :: Integer
nn = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nn_   :: Integer
    kk :: Integer
kk = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kk_   :: Integer
    
    gg :: Integer
gg = Integer
2forall a. Num a => a -> a -> a
*Integer
g
    n :: Integer
n = forall a. Integral a => a -> a -> a
div Integer
nn Integer
2
    k :: Integer
k = forall a. Integral a => a -> a -> a
div Integer
kk Integer
2
    
--------------------------------------------------------------------------------
-- * Free powers of cyclic groups

{-# SPECIALIZE multiplyZ2 ::        Word Int -> Word Int -> Word Int #-}
{-# SPECIALIZE multiplyZ3 ::        Word Int -> Word Int -> Word Int #-}
{-# SPECIALIZE multiplyZm :: Int -> Word Int -> Word Int -> Word Int #-}

-- | Multiplication in free products of Z2's
multiplyZ2 :: Eq idx => Word idx -> Word idx -> Word idx
multiplyZ2 :: forall idx. Eq idx => Word idx -> Word idx -> Word idx
multiplyZ2 Word idx
w1 Word idx
w2 = forall idx. Eq idx => Word idx -> Word idx
reduceWordZ2 (Word idx
w1 forall a. [a] -> [a] -> [a]
++ Word idx
w2)

-- | Multiplication in free products of Z3's
multiplyZ3 :: Eq idx => Word idx -> Word idx -> Word idx
multiplyZ3 :: forall idx. Eq idx => Word idx -> Word idx -> Word idx
multiplyZ3 Word idx
w1 Word idx
w2 = forall idx. Eq idx => Word idx -> Word idx
reduceWordZ3 (Word idx
w1 forall a. [a] -> [a] -> [a]
++ Word idx
w2)

-- | Multiplication in free products of Zm's
multiplyZm :: Eq idx => Int -> Word idx -> Word idx -> Word idx
multiplyZm :: forall idx. Eq idx => Int -> Word idx -> Word idx -> Word idx
multiplyZm Int
k Word idx
w1 Word idx
w2 = forall idx. Eq idx => Int -> Word idx -> Word idx
reduceWordZm Int
k (Word idx
w1 forall a. [a] -> [a] -> [a]
++ Word idx
w2)

--------------------------------------------------------------------------------

{-# SPECIALIZE equivalentZ2 ::        Word Int -> Word Int -> Bool #-}
{-# SPECIALIZE equivalentZ3 ::        Word Int -> Word Int -> Bool #-}
{-# SPECIALIZE equivalentZm :: Int -> Word Int -> Word Int -> Bool #-}

-- | Decides whether two words represent the same group element in free products of Z2
equivalentZ2 :: Eq idx => Word idx -> Word idx -> Bool
equivalentZ2 :: forall idx. Eq idx => Word idx -> Word idx -> Bool
equivalentZ2 Word idx
w1 Word idx
w2 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall idx. Eq idx => Word idx -> Word idx
reduceWordZ2 forall a b. (a -> b) -> a -> b
$ Word idx
w1 forall a. [a] -> [a] -> [a]
++ forall a. Word a -> Word a
inverseWord Word idx
w2

-- | Decides whether two words represent the same group element in free products of Z3
equivalentZ3 :: Eq idx => Word idx -> Word idx -> Bool
equivalentZ3 :: forall idx. Eq idx => Word idx -> Word idx -> Bool
equivalentZ3 Word idx
w1 Word idx
w2 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall idx. Eq idx => Word idx -> Word idx
reduceWordZ3 forall a b. (a -> b) -> a -> b
$ Word idx
w1 forall a. [a] -> [a] -> [a]
++ forall a. Word a -> Word a
inverseWord Word idx
w2

-- | Decides whether two words represent the same group element in free products of Zm
equivalentZm :: Eq idx => Int -> Word idx -> Word idx -> Bool
equivalentZm :: forall idx. Eq idx => Int -> Word idx -> Word idx -> Bool
equivalentZm Int
m Word idx
w1 Word idx
w2 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall idx. Eq idx => Int -> Word idx -> Word idx
reduceWordZm Int
m forall a b. (a -> b) -> a -> b
$ Word idx
w1 forall a. [a] -> [a] -> [a]
++ forall a. Word a -> Word a
inverseWord Word idx
w2

--------------------------------------------------------------------------------

{-# SPECIALIZE reduceWordZ2 ::        Word Int -> Word Int #-}
{-# SPECIALIZE reduceWordZ3 ::        Word Int -> Word Int #-}
{-# SPECIALIZE reduceWordZm :: Int -> Word Int -> Word Int #-}

--------------------------------------------------------------------------------

-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@
-- (that is, free products of Z2's)
reduceWordZ2 :: Eq idx => Word idx -> Word idx
reduceWordZ2 :: forall idx. Eq idx => Word idx -> Word idx
reduceWordZ2 = forall idx. Eq idx => Word idx -> Word idx
loop where
  loop :: Word a -> Word a
loop Word a
w = case forall a. Eq a => Word a -> Maybe (Word a)
reduceStep Word a
w of
    Maybe (Word a)
Nothing -> Word a
w
    Just Word a
w' -> Word a -> Word a
loop Word a
w'
 
  reduceStep :: Eq a => Word a -> Maybe (Word a)
  reduceStep :: forall a. Eq a => Word a -> Maybe (Word a)
reduceStep = forall {a}. Eq a => Bool -> [Generator a] -> Maybe [Generator a]
go Bool
False where   
    go :: Bool -> [Generator idx] -> Maybe [Generator idx]
go !Bool
changed [Generator idx]
w = case [Generator idx]
w of
      (Gen idx
x : Gen idx
y : [Generator idx]
rest) | idx
xforall a. Eq a => a -> a -> Bool
==idx
y   -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Gen idx
x : Inv idx
y : [Generator idx]
rest) | idx
xforall a. Eq a => a -> a -> Bool
==idx
y   -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Inv idx
x : Gen idx
y : [Generator idx]
rest) | idx
xforall a. Eq a => a -> a -> Bool
==idx
y   -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Inv idx
x : Inv idx
y : [Generator idx]
rest) | idx
xforall a. Eq a => a -> a -> Bool
==idx
y   -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Generator idx
this : [Generator idx]
rest)                   -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall idx. Generator idx -> Generator idx
absGen Generator idx
thisforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
changed [Generator idx]
rest
      [Generator idx]
_                               -> if Bool
changed then forall a. a -> Maybe a
Just [Generator idx]
w else forall a. Maybe a
Nothing

-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@
-- (that is, free products of Z3's)
reduceWordZ3 :: Eq idx => Word idx -> Word idx
reduceWordZ3 :: forall idx. Eq idx => Word idx -> Word idx
reduceWordZ3 = forall idx. Eq idx => Word idx -> Word idx
loop where
  loop :: Word a -> Word a
loop Word a
w = case forall a. Eq a => Word a -> Maybe (Word a)
reduceStep Word a
w of
    Maybe (Word a)
Nothing -> Word a
w
    Just Word a
w' -> Word a -> Word a
loop Word a
w'
 
  reduceStep :: Eq a => Word a -> Maybe (Word a)
  reduceStep :: forall a. Eq a => Word a -> Maybe (Word a)
reduceStep = forall {a}. Eq a => Bool -> [Generator a] -> Maybe [Generator a]
go Bool
False where   
    go :: Bool -> [Generator a] -> Maybe [Generator a]
go !Bool
changed [Generator a]
w = case [Generator a]
w of
      (Gen a
x : Inv a
y : [Generator a]
rest)         | a
xforall a. Eq a => a -> a -> Bool
==a
y           -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Inv a
x : Gen a
y : [Generator a]
rest)         | a
xforall a. Eq a => a -> a -> Bool
==a
y           -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Gen a
x : Gen a
y : Gen a
z : [Generator a]
rest) | a
xforall a. Eq a => a -> a -> Bool
==a
y Bool -> Bool -> Bool
&& a
yforall a. Eq a => a -> a -> Bool
==a
z   -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Inv a
x : Inv a
y : Inv a
z : [Generator a]
rest) | a
xforall a. Eq a => a -> a -> Bool
==a
y Bool -> Bool -> Bool
&& a
yforall a. Eq a => a -> a -> Bool
==a
z   -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Gen a
x : Gen a
y : [Generator a]
rest)         | a
xforall a. Eq a => a -> a -> Bool
==a
y           -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True (forall idx. idx -> Generator idx
Inv a
x forall a. a -> [a] -> [a]
: [Generator a]
rest)       -- !!!
      (Inv a
x : Inv a
y : [Generator a]
rest)         | a
xforall a. Eq a => a -> a -> Bool
==a
y           -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True (forall idx. idx -> Generator idx
Gen a
x forall a. a -> [a] -> [a]
: [Generator a]
rest)
      (Generator a
this : [Generator a]
rest)                                   -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator a
thisforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ Bool -> [Generator a] -> Maybe [Generator a]
go Bool
changed [Generator a]
rest
      [Generator a]
_                                               -> if Bool
changed then forall a. a -> Maybe a
Just [Generator a]
w else forall a. Maybe a
Nothing
      
-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@
-- (that is, free products of Zm's)
reduceWordZm :: Eq idx => Int -> Word idx -> Word idx
reduceWordZm :: forall idx. Eq idx => Int -> Word idx -> Word idx
reduceWordZm Int
m = [Generator idx] -> [Generator idx]
loop where

  loop :: [Generator idx] -> [Generator idx]
loop [Generator idx]
w = case [Generator idx] -> Maybe [Generator idx]
reduceStep [Generator idx]
w of
    Maybe [Generator idx]
Nothing -> [Generator idx]
w
    Just [Generator idx]
w' -> [Generator idx] -> [Generator idx]
loop [Generator idx]
w'

  halfm :: Int
halfm = forall a. Integral a => a -> a -> a
div Int
m Int
2  -- if we encounter strictly more than m/2 equal elements in a row, we replace them by the inverses
 
  -- reduceStep :: Eq a => Word a -> Maybe (Word a)
  reduceStep :: [Generator idx] -> Maybe [Generator idx]
reduceStep = forall {a}. Eq a => Bool -> [Generator a] -> Maybe [Generator a]
go Bool
False where   
    go :: Bool -> [Generator a] -> Maybe [Generator a]
go !Bool
changed [Generator a]
w = case [Generator a]
w of
      (Gen a
x : Inv a
y : [Generator a]
rest) | a
xforall a. Eq a => a -> a -> Bool
==a
y                        -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      (Inv a
x : Gen a
y : [Generator a]
rest) | a
xforall a. Eq a => a -> a -> Bool
==a
y                        -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True [Generator a]
rest
      [Generator a]
something | Just (Int
k,[Generator a]
rest) <- forall {a}. Eq a => [a] -> Maybe (Int, [a])
dropIfMoreThanHalf [Generator a]
w    -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True (forall a. Int -> a -> [a]
replicate (Int
mforall a. Num a => a -> a -> a
-Int
k) (forall idx. Generator idx -> Generator idx
inverseGen (forall a. [a] -> a
head [Generator a]
w)) forall a. [a] -> [a] -> [a]
++ [Generator a]
rest)
      (Generator a
this : [Generator a]
rest)                                        -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator a
thisforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ Bool -> [Generator a] -> Maybe [Generator a]
go Bool
changed [Generator a]
rest
      [Generator a]
_                                                    -> if Bool
changed then forall a. a -> Maybe a
Just [Generator a]
w else forall a. Maybe a
Nothing
  
  -- dropIfMoreThanHalf :: Eq a => Word a -> Maybe (Int, Word a)
  dropIfMoreThanHalf :: [a] -> Maybe (Int, [a])
dropIfMoreThanHalf [a]
w = 
    let (!Int
k,[a]
rest) = forall {a}. Eq a => [a] -> (Int, [a])
dropWhileEqual [a]
w 
    in  if Int
k forall a. Ord a => a -> a -> Bool
> Int
halfm then forall a. a -> Maybe a
Just (Int
k,[a]
rest)
                     else forall a. Maybe a
Nothing
                     
  -- dropWhileEqual :: Eq a => Word a -> (Int, Word a) 
  dropWhileEqual :: [a] -> (Int, [a])
dropWhileEqual []     = (Int
0,[])
  dropWhileEqual (a
x0:[a]
rest) = Int -> [a] -> (Int, [a])
go Int
1 [a]
rest where
    go :: Int -> [a] -> (Int, [a])
go !Int
k []         = (Int
k,[])
    go !Int
k xxs :: [a]
xxs@(a
x:[a]
xs) = if Int
kforall a. Eq a => a -> a -> Bool
==Int
m then (Int
m,[a]
xxs) 
                               else if a
xforall a. Eq a => a -> a -> Bool
==a
x0 then Int -> [a] -> (Int, [a])
go (Int
kforall a. Num a => a -> a -> a
+Int
1) [a]
xs 
                                             else (Int
k,[a]
xxs)

{-  
  dropm :: Eq a => Word a -> Maybe (Word a)    
  dropm []     = Nothing
  dropm (x:xs) = go (m-1) xs where
    go 0 rest    = Just rest
    go j (y:ys)  = if y==x 
      then go (j-1) ys
      else Nothing 
    go j []      = Nothing
-}

--------------------------------------------------------------------------------

{-# SPECIALIZE reduceWordZ2Naive ::        Word Int -> Word Int #-}
{-# SPECIALIZE reduceWordZ3Naive ::        Word Int -> Word Int #-}
{-# SPECIALIZE reduceWordZmNaive :: Int -> Word Int -> Word Int #-}

-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@
-- (that is, free products of Z2's). Naive (but canonical) algorithm.
reduceWordZ2Naive :: Eq idx => Word idx -> Word idx
reduceWordZ2Naive :: forall idx. Eq idx => Word idx -> Word idx
reduceWordZ2Naive = [Generator idx] -> [Generator idx]
loop where
  loop :: [Generator idx] -> [Generator idx]
loop [Generator idx]
w = let w' :: [Generator idx]
w' = [Generator idx] -> [Generator idx]
step [Generator idx]
w in if [Generator idx]
wforall a. Eq a => a -> a -> Bool
/=[Generator idx]
w' then [Generator idx] -> [Generator idx]
loop [Generator idx]
w' else [Generator idx]
w
  step :: [Generator idx] -> [Generator idx]
step   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Word a -> Word a
worker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating forall idx. Generator idx -> idx
genIdx) where
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs = 
    case forall a. Integral a => a -> a -> a
mod Int
s Int
2 of
      Int
1 -> [forall idx. idx -> Generator idx
Gen idx
i]
      Int
0 -> []
      Int
_ -> forall a. HasCallStack => String -> a
error String
"reduceWordZ2: fatal error, shouldn't happen"
    where 
      i :: idx
i = forall idx. Generator idx -> idx
genIdx (forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = forall a. Num a => [a] -> a
sum' (forall a b. (a -> b) -> [a] -> [b]
map forall idx. Generator idx -> Int
genSignValue [Generator idx]
gs)

-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@
-- (that is, free products of Z3's). Naive (but canonical) algorithm.
reduceWordZ3Naive :: Eq idx => Word idx -> Word idx
reduceWordZ3Naive :: forall idx. Eq idx => Word idx -> Word idx
reduceWordZ3Naive = [Generator idx] -> [Generator idx]
loop where
  loop :: [Generator idx] -> [Generator idx]
loop [Generator idx]
w = let w' :: [Generator idx]
w' = [Generator idx] -> [Generator idx]
step [Generator idx]
w in if [Generator idx]
wforall a. Eq a => a -> a -> Bool
/=[Generator idx]
w' then [Generator idx] -> [Generator idx]
loop [Generator idx]
w' else [Generator idx]
w
  step :: [Generator idx] -> [Generator idx]
step   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Word a -> Word a
worker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating forall idx. Generator idx -> idx
genIdx) where
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs = 
    case forall a. Integral a => a -> a -> a
mod Int
s Int
3 of
      Int
0 -> []
      Int
1 -> [forall idx. idx -> Generator idx
Gen idx
i]
      Int
2 -> [forall idx. idx -> Generator idx
Inv idx
i]
      Int
_ -> forall a. HasCallStack => String -> a
error String
"reduceWordZ3: fatal error, shouldn't happen"
    where 
      i :: idx
i = forall idx. Generator idx -> idx
genIdx (forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = forall a. Num a => [a] -> a
sum' (forall a b. (a -> b) -> [a] -> [b]
map forall idx. Generator idx -> Int
genSignValue [Generator idx]
gs)

-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@
-- (that is, free products of Zm's). Naive (but canonical) algorithm.
reduceWordZmNaive :: Eq idx => Int -> Word idx -> Word idx
reduceWordZmNaive :: forall idx. Eq idx => Int -> Word idx -> Word idx
reduceWordZmNaive Int
m = [Generator idx] -> [Generator idx]
loop where
  loop :: [Generator idx] -> [Generator idx]
loop [Generator idx]
w = let w' :: [Generator idx]
w' = [Generator idx] -> [Generator idx]
step [Generator idx]
w in if [Generator idx]
wforall a. Eq a => a -> a -> Bool
/=[Generator idx]
w' then [Generator idx] -> [Generator idx]
loop [Generator idx]
w' else [Generator idx]
w
  step :: [Generator idx] -> [Generator idx]
step   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Word a -> Word a
worker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating forall idx. Generator idx -> idx
genIdx) where
  halfm1 :: Int
halfm1 = forall a. Integral a => a -> a -> a
div (Int
mforall a. Num a => a -> a -> a
+Int
1) Int
2
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs 
    | Int
mods forall a. Ord a => a -> a -> Bool
<= Int
halfm1  = forall a. Int -> a -> [a]
replicate    Int
mods  (forall idx. idx -> Generator idx
Gen idx
i)
    | Bool
otherwise       = forall a. Int -> a -> [a]
replicate (Int
mforall a. Num a => a -> a -> a
-Int
mods) (forall idx. idx -> Generator idx
Inv idx
i)
    where 
      i :: idx
i = forall idx. Generator idx -> idx
genIdx (forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = forall a. Num a => [a] -> a
sum' (forall a b. (a -> b) -> [a] -> [b]
map forall idx. Generator idx -> Int
genSignValue [Generator idx]
gs)
      mods :: Int
mods = forall a. Integral a => a -> a -> a
mod Int
s Int
m

--------------------------------------------------------------------------------

-- | Counts the number of words (without inverse generators) of length @n@ 
-- which reduce to the identity element, using the relations @x^2=1@.
--
-- Generating function is @Gf_g(u) = \\frac {2g-2} { g-2 + g \\sqrt{ 1 - (4g-4)u^2 } }@
--
-- The first few @g@ cases:
--
-- > A000984 = [ countIdentityWordsZ2 2 (2*n) | n<-[0..] ] = [1,2,6,20,70,252,924,3432,12870,48620,184756...]
-- > A089022 = [ countIdentityWordsZ2 3 (2*n) | n<-[0..] ] = [1,3,15,87,543,3543,23823,163719,1143999,8099511,57959535...]
-- > A035610 = [ countIdentityWordsZ2 4 (2*n) | n<-[0..] ] = [1,4,28,232,2092,19864,195352,1970896,20275660,211823800,2240795848...]
-- > A130976 = [ countIdentityWordsZ2 5 (2*n) | n<-[0..] ] = [1,5,45,485,5725,71445,925965,12335685,167817405,2321105525,32536755565...]
--
countIdentityWordsZ2
  :: Int   -- ^ g = number of generators in the free group
  -> Int   -- ^ n = length of the unreduced word
  -> Integer
countIdentityWordsZ2 :: Int -> Int -> Integer
countIdentityWordsZ2 Int
g Int
n = Int -> Int -> Int -> Integer
countWordReductionsZ2 Int
g Int
n Int
0

-- | Counts the number of words (without inverse generators) of length @n@ whose 
-- reduced form in the product of Z2-s (that is, for each generator @x@ we have @x^2=1@) 
-- has length @k@
-- (clearly @n@ and @k@ must have the same parity for this to be nonzero):
--
-- > countWordReductionsZ2 g n k == sum [ 1 | w <- allWordsNoInv g n, k == length (reduceWordZ2 w) ]
--
countWordReductionsZ2 
  :: Int   -- ^ g = number of generators in the free group
  -> Int   -- ^ n = length of the unreduced word
  -> Int   -- ^ k = length of the reduced word
  -> Integer
countWordReductionsZ2 :: Int -> Int -> Int -> Integer
countWordReductionsZ2 Int
gens_ Int
nn_ Int
kk_
  | Integer
nnforall a. Eq a => a -> a -> Bool
==Integer
0              = if Integer
kforall a. Eq a => a -> a -> Bool
==Integer
0 then Integer
1 else Integer
0
  | forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& Integer
kk forall a. Eq a => a -> a -> Bool
== Integer
0 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) (Integer
n  forall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
gforall a b. (Num a, Integral b) => a -> b -> a
^(Integer
i  ) forall a. Num a => a -> a -> a
* (Integer
gforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
n  forall a. Num a => a -> a -> a
-Integer
i  ) forall a. Num a => a -> a -> a
* (   Integer
i) ) forall a. Integral a => a -> a -> a
`div` (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
n  ] ]
  | forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& forall a. Integral a => a -> Bool
even Integer
kk = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) (Integer
nforall a. Num a => a -> a -> a
-Integer
kforall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
gforall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iforall a. Num a => a -> a -> a
+Integer
1) forall a. Num a => a -> a -> a
* (Integer
gforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nforall a. Num a => a -> a -> a
+Integer
kforall a. Num a => a -> a -> a
-Integer
iforall a. Num a => a -> a -> a
-Integer
1) forall a. Num a => a -> a -> a
* (Integer
kkforall a. Num a => a -> a -> a
+Integer
i) ) forall a. Integral a => a -> a -> a
`div` (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nforall a. Num a => a -> a -> a
-Integer
k] ] 
  | forall a. Integral a => a -> Bool
odd  Integer
nn Bool -> Bool -> Bool
&& forall a. Integral a => a -> Bool
odd  Integer
kk = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) (Integer
nforall a. Num a => a -> a -> a
-Integer
kforall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
gforall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iforall a. Num a => a -> a -> a
+Integer
1) forall a. Num a => a -> a -> a
* (Integer
gforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nforall a. Num a => a -> a -> a
+Integer
kforall a. Num a => a -> a -> a
-Integer
i  ) forall a. Num a => a -> a -> a
* (Integer
kkforall a. Num a => a -> a -> a
+Integer
i) ) forall a. Integral a => a -> a -> a
`div` (Integer
nnforall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nforall a. Num a => a -> a -> a
-Integer
k] ]
  | Bool
otherwise          = Integer
0  
  where
    g :: Integer
g  = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gens_ :: Integer
    nn :: Integer
nn = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nn_   :: Integer
    kk :: Integer
kk = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kk_   :: Integer
    
    n :: Integer
n = forall a. Integral a => a -> a -> a
div Integer
nn Integer
2
    k :: Integer
k = forall a. Integral a => a -> a -> a
div Integer
kk Integer
2

-- | Counts the number of words (without inverse generators) of length @n@ 
-- which reduce to the identity element, using the relations @x^3=1@.
--
-- > countIdentityWordsZ3NoInv g n == sum [ 1 | w <- allWordsNoInv g n, 0 == length (reduceWordZ2 w) ]
--
-- In mathematica, the formula is: @Sum[ g^k * (g-1)^(n-k) * k/n * Binomial[3*n-k-1, n-k] , {k, 1,n} ]@
--
countIdentityWordsZ3NoInv
  :: Int   -- ^ g = number of generators in the free group
  -> Int   -- ^ n = length of the unreduced word
  -> Integer
countIdentityWordsZ3NoInv :: Int -> Int -> Integer
countIdentityWordsZ3NoInv Int
gens_ Int
nn_ 
  | Integer
nnforall a. Eq a => a -> a -> Bool
==Integer
0           = Integer
1
  | forall a. Integral a => a -> a -> a
mod Integer
nn Integer
3 forall a. Eq a => a -> a -> Bool
== Integer
0   = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( forall a. Integral a => a -> a -> Integer
binomial (Integer
3forall a. Num a => a -> a -> a
*Integer
nforall a. Num a => a -> a -> a
-Integer
iforall a. Num a => a -> a -> a
-Integer
1) (Integer
nforall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
gforall a b. (Num a, Integral b) => a -> b -> a
^Integer
i forall a. Num a => a -> a -> a
* (Integer
gforall a. Num a => a -> a -> a
-Integer
1)forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nforall a. Num a => a -> a -> a
-Integer
i) forall a. Num a => a -> a -> a
* Integer
i ) forall a. Integral a => a -> a -> a
`div` Integer
n | Integer
i<-[Integer
1..Integer
n] ]
  | Bool
otherwise       = Integer
0
  where
    g :: Integer
g  = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gens_ :: Integer
    nn :: Integer
nn = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nn_   :: Integer
    
    n :: Integer
n = forall a. Integral a => a -> a -> a
div Integer
nn Integer
3
  
--------------------------------------------------------------------------------
      
{-

-- some basic testing. TODO: real tests

import Math.Combinat.Helper
import Math.Combinat.Groups.Free

g    = 3 :: Int
maxn = 8 :: Int

bad_free = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordFree w `equivalentFree` reduceWordFreeNaive w) ]
bad_z2   = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ2   w `equivalentZ2`   reduceWordZ2Naive   w) ]
bad_z3   = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ3   w `equivalentZ3`   reduceWordZ3Naive   w) ]
bad_zm m = [ w | n<-[0..maxn] , w <- allWords g n , not (equivalentZm m (reduceWordZm m w) (reduceWordZmNaive m w)) ]

speed_free = sum' [ length (reduceWordFree w) | n<-[0..maxn] , w <- allWords g n ]
speed_z2   = sum' [ length (reduceWordZ2   w) | n<-[0..maxn] , w <- allWords g n ]
speed_z3   = sum' [ length (reduceWordZ3   w) | n<-[0..maxn] , w <- allWords g n ]
speed_zm m = sum' [ length (reduceWordZm m w) | n<-[0..maxn] , w <- allWords g n ]

naive_speed_free = sum' [ length (reduceWordFreeNaive w) | n<-[0..maxn] , w <- allWords g n ]
naive_speed_z2   = sum' [ length (reduceWordZ2Naive   w) | n<-[0..maxn] , w <- allWords g n ]
naive_speed_z3   = sum' [ length (reduceWordZ3Naive   w) | n<-[0..maxn] , w <- allWords g n ]
naive_speed_zm m = sum' [ length (reduceWordZmNaive m w) | n<-[0..maxn] , w <- allWords g n ]

-}

--------------------------------------------------------------------------------