-- | 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
(Generator idx -> Generator idx -> Bool)
-> (Generator idx -> Generator idx -> Bool) -> Eq (Generator idx)
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,Eq (Generator idx)
Eq (Generator idx)
-> (Generator idx -> Generator idx -> Ordering)
-> (Generator idx -> Generator idx -> Bool)
-> (Generator idx -> Generator idx -> Bool)
-> (Generator idx -> Generator idx -> Bool)
-> (Generator idx -> Generator idx -> Bool)
-> (Generator idx -> Generator idx -> Generator idx)
-> (Generator idx -> Generator idx -> Generator idx)
-> Ord (Generator idx)
Generator idx -> Generator idx -> Bool
Generator idx -> Generator idx -> Ordering
Generator idx -> Generator idx -> Generator idx
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
$cp1Ord :: forall idx. Ord idx => Eq (Generator idx)
Ord,Int -> Generator idx -> ShowS
[Generator idx] -> ShowS
Generator idx -> String
(Int -> Generator idx -> ShowS)
-> (Generator idx -> String)
-> ([Generator idx] -> ShowS)
-> Show (Generator idx)
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)
Int -> ReadS (Generator idx)
ReadS [Generator idx]
(Int -> ReadS (Generator idx))
-> ReadS [Generator idx]
-> ReadPrec (Generator idx)
-> ReadPrec [Generator idx]
-> Read (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 :: 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 :: 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 :: 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 :: Generator idx -> Generator idx
absGen Generator idx
g = case Generator idx
g of
  Gen idx
x -> idx -> Generator idx
forall idx. idx -> Generator idx
Gen idx
x
  Inv idx
x -> idx -> Generator idx
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
96Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i)
showGen (Inv Int
i) = Int -> Char
chr (Int
64Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i)

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

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

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

-- | The inverse of a word
inverseWord :: Word a -> Word a
inverseWord :: Word a -> Word a
inverseWord = (Generator a -> Generator a) -> Word a -> Word a
forall a b. (a -> b) -> [a] -> [b]
map Generator a -> Generator a
forall a. Generator a -> Generator a
inverseGen (Word a -> Word a) -> (Word a -> Word a) -> Word a -> Word a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word a -> Word a
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 = Int -> [Word Int]
forall t. (Eq t, Num t) => t -> [Word Int]
go where
  go :: t -> [Word Int]
go !t
0 = [[]]
  go !t
n = [ Generator Int
xGenerator Int -> Word Int -> Word Int
forall a. a -> [a] -> [a]
:Word Int
xs | Word Int
xs <- t -> [Word Int]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) , Generator Int
x <- Word Int
elems ]
  elems :: Word Int
elems =  [ Int -> Generator Int
forall idx. idx -> Generator idx
Gen Int
a | Int
a<-[Int
1..Int
g] ]
        Word Int -> Word Int -> Word Int
forall a. [a] -> [a] -> [a]
++ [ Int -> Generator Int
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 = Int -> [Word Int]
forall t. (Eq t, Num t) => t -> [Word Int]
go where
  go :: t -> [Word Int]
go !t
0 = [[]]
  go !t
n = [ Generator Int
xGenerator Int -> Word Int -> Word Int
forall a. a -> [a] -> [a]
:Word Int
xs | Word Int
xs <- t -> [Word Int]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) , Generator Int
x <- Word Int
elems ]
  elems :: Word Int
elems = [ Int -> Generator Int
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 :: Int -> g -> (Generator Int, g)
randomGenerator !Int
d !g
g0 = (Generator Int
gen, g
g2) where
  (Bool
b, !g
g1) = g -> (Bool, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random        g
g0
  (Int
k, !g
g2) = (Int, Int) -> g -> (Int, g)
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 Int -> Generator Int
forall idx. idx -> Generator idx
Gen Int
k else Int -> Generator Int
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 :: Int -> g -> (Generator Int, g)
randomGeneratorNoInv !Int
d !g
g0 = (Int -> Generator Int
forall idx. idx -> Generator idx
Gen Int
k, g
g1) where
  (!Int
k, !g
g1) = (Int, Int) -> g -> (Int, g)
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 :: Int -> Int -> g -> (Word Int, g)
randomWord !Int
d !Int
n !g
g0 = (Word Int
word,g
g1) where
  (g
g1,Word Int
word) = (g -> Int -> (g, Generator Int)) -> g -> [Int] -> (g, Word Int)
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\g
g Int
_ -> (Generator Int, g) -> (g, Generator Int)
forall a b. (a, b) -> (b, a)
swap (Int -> g -> (Generator Int, g)
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 :: Int -> Int -> g -> (Word Int, g)
randomWordNoInv !Int
d !Int
n !g
g0 = (Word Int
word,g
g1) where
  (g
g1,Word Int
word) = (g -> Int -> (g, Generator Int)) -> g -> [Int] -> (g, Word Int)
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\g
g Int
_ -> (Generator Int, g) -> (g, Generator Int)
forall a b. (a, b) -> (b, a)
swap (Int -> g -> (Generator Int, g)
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 :: Word idx -> Word idx -> Word idx
multiplyFree Word idx
w1 Word idx
w2 = Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
reduceWordFree (Word idx
w1 Word idx -> Word idx -> Word idx
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 :: Word idx -> Word idx -> Bool
equivalentFree Word idx
w1 Word idx
w2 = Word idx -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Word idx -> Bool) -> Word idx -> Bool
forall a b. (a -> b) -> a -> b
$ Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
reduceWordFree (Word idx -> Word idx) -> Word idx -> Word idx
forall a b. (a -> b) -> a -> b
$ Word idx
w1 Word idx -> Word idx -> Word idx
forall a. [a] -> [a] -> [a]
++ Word idx -> Word idx
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 :: Word idx -> Word idx
reduceWordFree = Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
loop where

  loop :: Word a -> Word a
loop Word a
w = case Word a -> Maybe (Word a)
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 :: Word a -> Maybe (Word a)
reduceStep = Bool -> Word a -> Maybe (Word a)
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
xa -> a -> Bool
forall 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
xa -> a -> Bool
forall 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)                   -> ([Generator a] -> [Generator a])
-> Maybe [Generator a] -> Maybe [Generator a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator a
thisGenerator a -> [Generator a] -> [Generator a]
forall a. a -> [a] -> [a]
:) (Maybe [Generator a] -> Maybe [Generator a])
-> Maybe [Generator a] -> Maybe [Generator 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 [Generator a] -> Maybe [Generator a]
forall a. a -> Maybe a
Just [Generator a]
w else Maybe [Generator a]
forall a. Maybe a
Nothing


-- | Naive (but canonical) reduction algorithm for the free groups
reduceWordFreeNaive :: Eq idx => Word idx -> Word idx
reduceWordFreeNaive :: Word idx -> Word idx
reduceWordFreeNaive = Word idx -> Word idx
loop where
  loop :: Word idx -> Word idx
loop Word idx
w = let w' :: Word idx
w' = Word idx -> Word idx
step Word idx
w in if Word idx
wWord idx -> Word idx -> Bool
forall a. Eq a => a -> a -> Bool
/=Word idx
w' then Word idx -> Word idx
loop Word idx
w' else Word idx
w
  step :: Word idx -> Word idx
step   = (Word idx -> Word idx) -> [Word idx] -> Word idx
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word idx -> Word idx
forall a. Word a -> Word a
worker ([Word idx] -> Word idx)
-> (Word idx -> [Word idx]) -> Word idx -> Word idx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Generator idx -> Generator idx -> Bool) -> Word idx -> [Word idx]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Generator idx -> idx) -> Generator idx -> Generator idx -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating Generator idx -> idx
forall idx. Generator idx -> idx
genIdx) where
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs 
    | Int
sInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0       = Int -> Generator idx -> [Generator idx]
forall a. Int -> a -> [a]
replicate      Int
s  (idx -> Generator idx
forall idx. idx -> Generator idx
Gen idx
i)
    | Int
sInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0       = Int -> Generator idx -> [Generator idx]
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Num a => a -> a
abs Int
s) (idx -> Generator idx
forall idx. idx -> Generator idx
Inv idx
i)
    | Bool
otherwise = []
    where 
      i :: idx
i = Generator idx -> idx
forall idx. Generator idx -> idx
genIdx ([Generator idx] -> Generator idx
forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = [Int] -> Int
forall a. Num a => [a] -> a
sum' ((Generator idx -> Int) -> [Generator idx] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Generator idx -> Int
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
nnInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0              = if Integer
kInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0 then Integer
1 else Integer
0
  | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& Integer
kk Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) (Integer
n  Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ggInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
i  ) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
ggInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
n  Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i  ) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (   Integer
i) ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
n  ] ]
  | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
kk = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ggInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
ggInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
kkInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
i) ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
k] ] 
  | Integer -> Bool
forall a. Integral a => a -> Bool
odd  Integer
nn Bool -> Bool -> Bool
&& Integer -> Bool
forall a. Integral a => a -> Bool
odd  Integer
kk = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ggInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
ggInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i  ) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
kkInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
i) ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
k] ]
  | Bool
otherwise          = Integer
0  
  where
    g :: Integer
g  = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gens_ :: Integer
    nn :: Integer
nn = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nn_   :: Integer
    kk :: Integer
kk = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kk_   :: Integer
    
    gg :: Integer
gg = Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
g
    n :: Integer
n = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div Integer
nn Integer
2
    k :: Integer
k = Integer -> Integer -> Integer
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 :: Word idx -> Word idx -> Word idx
multiplyZ2 Word idx
w1 Word idx
w2 = Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
reduceWordZ2 (Word idx
w1 Word idx -> Word idx -> Word idx
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 :: Word idx -> Word idx -> Word idx
multiplyZ3 Word idx
w1 Word idx
w2 = Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
reduceWordZ3 (Word idx
w1 Word idx -> Word idx -> Word idx
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 :: Int -> Word idx -> Word idx -> Word idx
multiplyZm Int
k Word idx
w1 Word idx
w2 = Int -> Word idx -> Word idx
forall idx. Eq idx => Int -> Word idx -> Word idx
reduceWordZm Int
k (Word idx
w1 Word idx -> Word idx -> Word idx
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 :: Word idx -> Word idx -> Bool
equivalentZ2 Word idx
w1 Word idx
w2 = Word idx -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Word idx -> Bool) -> Word idx -> Bool
forall a b. (a -> b) -> a -> b
$ Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
reduceWordZ2 (Word idx -> Word idx) -> Word idx -> Word idx
forall a b. (a -> b) -> a -> b
$ Word idx
w1 Word idx -> Word idx -> Word idx
forall a. [a] -> [a] -> [a]
++ Word idx -> Word idx
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 :: Word idx -> Word idx -> Bool
equivalentZ3 Word idx
w1 Word idx
w2 = Word idx -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Word idx -> Bool) -> Word idx -> Bool
forall a b. (a -> b) -> a -> b
$ Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
reduceWordZ3 (Word idx -> Word idx) -> Word idx -> Word idx
forall a b. (a -> b) -> a -> b
$ Word idx
w1 Word idx -> Word idx -> Word idx
forall a. [a] -> [a] -> [a]
++ Word idx -> Word idx
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 :: Int -> Word idx -> Word idx -> Bool
equivalentZm Int
m Word idx
w1 Word idx
w2 = Word idx -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Word idx -> Bool) -> Word idx -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Word idx -> Word idx
forall idx. Eq idx => Int -> Word idx -> Word idx
reduceWordZm Int
m (Word idx -> Word idx) -> Word idx -> Word idx
forall a b. (a -> b) -> a -> b
$ Word idx
w1 Word idx -> Word idx -> Word idx
forall a. [a] -> [a] -> [a]
++ Word idx -> Word idx
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 :: Word idx -> Word idx
reduceWordZ2 = Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
loop where
  loop :: Word a -> Word a
loop Word a
w = case Word a -> Maybe (Word a)
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 :: Word a -> Maybe (Word a)
reduceStep = Bool -> Word a -> Maybe (Word a)
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
xidx -> idx -> Bool
forall 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
xidx -> idx -> Bool
forall 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
xidx -> idx -> Bool
forall 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
xidx -> idx -> Bool
forall 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)                   -> ([Generator idx] -> [Generator idx])
-> Maybe [Generator idx] -> Maybe [Generator idx]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator idx -> Generator idx
forall a. Generator a -> Generator a
absGen Generator idx
thisGenerator idx -> [Generator idx] -> [Generator idx]
forall a. a -> [a] -> [a]
:) (Maybe [Generator idx] -> Maybe [Generator idx])
-> Maybe [Generator idx] -> Maybe [Generator idx]
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 [Generator idx] -> Maybe [Generator idx]
forall a. a -> Maybe a
Just [Generator idx]
w else Maybe [Generator idx]
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 :: Word idx -> Word idx
reduceWordZ3 = Word idx -> Word idx
forall idx. Eq idx => Word idx -> Word idx
loop where
  loop :: Word a -> Word a
loop Word a
w = case Word a -> Maybe (Word a)
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 :: Word a -> Maybe (Word a)
reduceStep = Bool -> Word a -> Maybe (Word a)
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 : Inv idx
y : [Generator idx]
rest)         | idx
xidx -> idx -> Bool
forall 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
xidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
y           -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Gen idx
x : Gen idx
y : Gen idx
z : [Generator idx]
rest) | idx
xidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
y Bool -> Bool -> Bool
&& idx
yidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
z   -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Inv idx
x : Inv idx
y : Inv idx
z : [Generator idx]
rest) | idx
xidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
y Bool -> Bool -> Bool
&& idx
yidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
z   -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True [Generator idx]
rest
      (Gen idx
x : Gen idx
y : [Generator idx]
rest)         | idx
xidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
y           -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True (idx -> Generator idx
forall idx. idx -> Generator idx
Inv idx
x Generator idx -> [Generator idx] -> [Generator idx]
forall a. a -> [a] -> [a]
: [Generator idx]
rest)       -- !!!
      (Inv idx
x : Inv idx
y : [Generator idx]
rest)         | idx
xidx -> idx -> Bool
forall a. Eq a => a -> a -> Bool
==idx
y           -> Bool -> [Generator idx] -> Maybe [Generator idx]
go Bool
True (idx -> Generator idx
forall idx. idx -> Generator idx
Gen idx
x Generator idx -> [Generator idx] -> [Generator idx]
forall a. a -> [a] -> [a]
: [Generator idx]
rest)
      (Generator idx
this : [Generator idx]
rest)                                   -> ([Generator idx] -> [Generator idx])
-> Maybe [Generator idx] -> Maybe [Generator idx]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator idx
thisGenerator idx -> [Generator idx] -> [Generator idx]
forall a. a -> [a] -> [a]
:) (Maybe [Generator idx] -> Maybe [Generator idx])
-> Maybe [Generator idx] -> Maybe [Generator idx]
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 [Generator idx] -> Maybe [Generator idx]
forall a. a -> Maybe a
Just [Generator idx]
w else Maybe [Generator idx]
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 :: Int -> Word idx -> Word idx
reduceWordZm Int
m = Word idx -> Word idx
loop where

  loop :: Word idx -> Word idx
loop Word idx
w = case Word idx -> Maybe (Word idx)
reduceStep Word idx
w of
    Maybe (Word idx)
Nothing -> Word idx
w
    Just Word idx
w' -> Word idx -> Word idx
loop Word idx
w'

  halfm :: Int
halfm = Int -> Int -> Int
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 :: Word idx -> Maybe (Word idx)
reduceStep = Bool -> Word idx -> Maybe (Word idx)
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
xa -> a -> Bool
forall 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
xa -> a -> Bool
forall 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) <- [Generator a] -> Maybe (Int, [Generator a])
forall a. Eq a => [a] -> Maybe (Int, [a])
dropIfMoreThanHalf [Generator a]
w    -> Bool -> [Generator a] -> Maybe [Generator a]
go Bool
True (Int -> Generator a -> [Generator a]
forall a. Int -> a -> [a]
replicate (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k) (Generator a -> Generator a
forall a. Generator a -> Generator a
inverseGen ([Generator a] -> Generator a
forall a. [a] -> a
head [Generator a]
w)) [Generator a] -> [Generator a] -> [Generator a]
forall a. [a] -> [a] -> [a]
++ [Generator a]
rest)
      (Generator a
this : [Generator a]
rest)                                        -> ([Generator a] -> [Generator a])
-> Maybe [Generator a] -> Maybe [Generator a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Generator a
thisGenerator a -> [Generator a] -> [Generator a]
forall a. a -> [a] -> [a]
:) (Maybe [Generator a] -> Maybe [Generator a])
-> Maybe [Generator a] -> Maybe [Generator 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 [Generator a] -> Maybe [Generator a]
forall a. a -> Maybe a
Just [Generator a]
w else Maybe [Generator a]
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) = [a] -> (Int, [a])
forall a. Eq a => [a] -> (Int, [a])
dropWhileEqual [a]
w 
    in  if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
halfm then (Int, [a]) -> Maybe (Int, [a])
forall a. a -> Maybe a
Just (Int
k,[a]
rest)
                     else Maybe (Int, [a])
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
kInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
m then (Int
m,[a]
xxs) 
                               else if a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x0 then Int -> [a] -> (Int, [a])
go (Int
kInt -> Int -> Int
forall 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 :: Word idx -> Word idx
reduceWordZ2Naive = Word idx -> Word idx
loop where
  loop :: Word idx -> Word idx
loop Word idx
w = let w' :: Word idx
w' = Word idx -> Word idx
step Word idx
w in if Word idx
wWord idx -> Word idx -> Bool
forall a. Eq a => a -> a -> Bool
/=Word idx
w' then Word idx -> Word idx
loop Word idx
w' else Word idx
w
  step :: Word idx -> Word idx
step   = (Word idx -> Word idx) -> [Word idx] -> Word idx
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word idx -> Word idx
forall a. Word a -> Word a
worker ([Word idx] -> Word idx)
-> (Word idx -> [Word idx]) -> Word idx -> Word idx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Generator idx -> Generator idx -> Bool) -> Word idx -> [Word idx]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Generator idx -> idx) -> Generator idx -> Generator idx -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating Generator idx -> idx
forall idx. Generator idx -> idx
genIdx) where
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs = 
    case Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
s Int
2 of
      Int
1 -> [idx -> Generator idx
forall idx. idx -> Generator idx
Gen idx
i]
      Int
0 -> []
      Int
_ -> String -> [Generator idx]
forall a. HasCallStack => String -> a
error String
"reduceWordZ2: fatal error, shouldn't happen"
    where 
      i :: idx
i = Generator idx -> idx
forall idx. Generator idx -> idx
genIdx ([Generator idx] -> Generator idx
forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = [Int] -> Int
forall a. Num a => [a] -> a
sum' ((Generator idx -> Int) -> [Generator idx] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Generator idx -> Int
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 :: Word idx -> Word idx
reduceWordZ3Naive = Word idx -> Word idx
loop where
  loop :: Word idx -> Word idx
loop Word idx
w = let w' :: Word idx
w' = Word idx -> Word idx
step Word idx
w in if Word idx
wWord idx -> Word idx -> Bool
forall a. Eq a => a -> a -> Bool
/=Word idx
w' then Word idx -> Word idx
loop Word idx
w' else Word idx
w
  step :: Word idx -> Word idx
step   = (Word idx -> Word idx) -> [Word idx] -> Word idx
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word idx -> Word idx
forall a. Word a -> Word a
worker ([Word idx] -> Word idx)
-> (Word idx -> [Word idx]) -> Word idx -> Word idx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Generator idx -> Generator idx -> Bool) -> Word idx -> [Word idx]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Generator idx -> idx) -> Generator idx -> Generator idx -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating Generator idx -> idx
forall idx. Generator idx -> idx
genIdx) where
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs = 
    case Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
s Int
3 of
      Int
0 -> []
      Int
1 -> [idx -> Generator idx
forall idx. idx -> Generator idx
Gen idx
i]
      Int
2 -> [idx -> Generator idx
forall idx. idx -> Generator idx
Inv idx
i]
      Int
_ -> String -> [Generator idx]
forall a. HasCallStack => String -> a
error String
"reduceWordZ3: fatal error, shouldn't happen"
    where 
      i :: idx
i = Generator idx -> idx
forall idx. Generator idx -> idx
genIdx ([Generator idx] -> Generator idx
forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = [Int] -> Int
forall a. Num a => [a] -> a
sum' ((Generator idx -> Int) -> [Generator idx] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Generator idx -> Int
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 :: Int -> Word idx -> Word idx
reduceWordZmNaive Int
m = Word idx -> Word idx
loop where
  loop :: Word idx -> Word idx
loop Word idx
w = let w' :: Word idx
w' = Word idx -> Word idx
step Word idx
w in if Word idx
wWord idx -> Word idx -> Bool
forall a. Eq a => a -> a -> Bool
/=Word idx
w' then Word idx -> Word idx
loop Word idx
w' else Word idx
w
  step :: Word idx -> Word idx
step   = (Word idx -> Word idx) -> [Word idx] -> Word idx
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word idx -> Word idx
forall a. Word a -> Word a
worker ([Word idx] -> Word idx)
-> (Word idx -> [Word idx]) -> Word idx -> Word idx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Generator idx -> Generator idx -> Bool) -> Word idx -> [Word idx]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Generator idx -> idx) -> Generator idx -> Generator idx -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating Generator idx -> idx
forall idx. Generator idx -> idx
genIdx) where
  halfm1 :: Int
halfm1 = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
2
  worker :: [Generator idx] -> [Generator idx]
worker [Generator idx]
gs 
    | Int
mods Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
halfm1  = Int -> Generator idx -> [Generator idx]
forall a. Int -> a -> [a]
replicate    Int
mods  (idx -> Generator idx
forall idx. idx -> Generator idx
Gen idx
i)
    | Bool
otherwise       = Int -> Generator idx -> [Generator idx]
forall a. Int -> a -> [a]
replicate (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
mods) (idx -> Generator idx
forall idx. idx -> Generator idx
Inv idx
i)
    where 
      i :: idx
i = Generator idx -> idx
forall idx. Generator idx -> idx
genIdx ([Generator idx] -> Generator idx
forall a. [a] -> a
head [Generator idx]
gs)
      s :: Int
s = [Int] -> Int
forall a. Num a => [a] -> a
sum' ((Generator idx -> Int) -> [Generator idx] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Generator idx -> Int
forall idx. Generator idx -> Int
genSignValue [Generator idx]
gs)
      mods :: Int
mods = Int -> Int -> Int
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
nnInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0              = if Integer
kInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0 then Integer
1 else Integer
0
  | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& Integer
kk Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) (Integer
n  Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
gInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
i  ) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
gInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
n  Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i  ) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (   Integer
i) ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
n  ] ]
  | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
nn Bool -> Bool -> Bool
&& Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
kk = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
gInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
gInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
kkInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
i) ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
k] ] 
  | Integer -> Bool
forall a. Integral a => a -> Bool
odd  Integer
nn Bool -> Bool -> Bool
&& Integer -> Bool
forall a. Integral a => a -> Bool
odd  Integer
kk = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
gInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
gInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i  ) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
kkInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
i) ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
nnInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) | Integer
i<-[Integer
0..Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
k] ]
  | Bool
otherwise          = Integer
0  
  where
    g :: Integer
g  = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gens_ :: Integer
    nn :: Integer
nn = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nn_   :: Integer
    kk :: Integer
kk = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kk_   :: Integer
    
    n :: Integer
n = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div Integer
nn Integer
2
    k :: Integer
k = Integer -> Integer -> Integer
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
nnInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0           = Integer
1
  | Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod Integer
nn Integer
3 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0   = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ ( Integer -> Integer -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Integer
3Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
gInteger -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
gInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
i ) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
n | Integer
i<-[Integer
1..Integer
n] ]
  | Bool
otherwise       = Integer
0
  where
    g :: Integer
g  = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gens_ :: Integer
    nn :: Integer
nn = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nn_   :: Integer
    
    n :: Integer
n = Integer -> Integer -> Integer
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 ]

-}

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