module Math.Combinat.FreeGroups where
import Data.Char ( chr )
import Data.List ( mapAccumL )
import Control.Monad ( liftM )
import System.Random
import Math.Combinat.Numbers
import Math.Combinat.Helper
data Generator a
= Gen a
| Inv a
deriving (Eq,Ord,Show,Read)
unGen :: Generator a -> a
unGen g = case g of
Gen x -> x
Inv x -> x
type Word a = [Generator a]
showGen :: Generator Int -> Char
showGen (Gen i) = chr (96+i)
showGen (Inv i) = chr (64+i)
showWord :: Word Int -> String
showWord = map showGen
instance Functor Generator where
fmap f g = case g of
Gen x -> Gen (f x)
Inv y -> Inv (f y)
inverseGen :: Generator a -> Generator a
inverseGen g = case g of
Gen x -> Inv x
Inv x -> Gen x
inverseWord :: Word a -> Word a
inverseWord = map inverseGen . reverse
allWords
:: Int
-> Int
-> [Word Int]
allWords g = go where
go 0 = [[]]
go n = [ x:xs | xs <- go (n1) , x <- elems ]
elems = [ Gen a | a<-[1..g] ]
++ [ Inv a | a<-[1..g] ]
allWordsNoInv
:: Int
-> Int
-> [Word Int]
allWordsNoInv g = go where
go 0 = [[]]
go n = [ x:xs | xs <- go (n1) , x <- elems ]
elems = [ Gen a | a<-[1..g] ]
randomGenerator
:: RandomGen g
=> Int
-> g -> (Generator Int, g)
randomGenerator d g0 = (gen,g2) where
(b,g1) = random g0
(k,g2) = randomR (1,d) g1
gen = if b then Gen k else Inv k
randomGeneratorNoInv
:: RandomGen g
=> Int
-> g -> (Generator Int, g)
randomGeneratorNoInv d g0 = (Gen k,g1) where
(k,g1) = randomR (1,d) g0
randomWord
:: RandomGen g
=> Int
-> Int
-> g -> (Word Int, g)
randomWord d n g0 = (word,g1) where
(g1,word) = mapAccumL (\g _ -> swap (randomGenerator d g)) g0 [1..n]
randomWordNoInv
:: RandomGen g
=> Int
-> Int
-> g -> (Word Int, g)
randomWordNoInv d n g0 = (word,g1) where
(g1,word) = mapAccumL (\g _ -> swap (randomGeneratorNoInv d g)) g0 [1..n]
multiplyFree :: Eq a => Word a -> Word a -> Word a
multiplyFree w1 w2 = reduceWordFree (w1++w2)
reduceWordFree :: Eq a => Word a -> Word a
reduceWordFree = loop where
loop w = case reduceStep w of
Nothing -> w
Just w' -> loop w'
reduceStep :: Eq a => Word a -> Maybe (Word a)
reduceStep = go False where
go changed w = case w of
(Gen x : Inv y : rest) | x==y -> go True rest
(Inv x : Gen y : rest) | x==y -> go True rest
(this : rest) -> liftM (this:) $ go changed rest
_ -> if changed then Just w else Nothing
countIdentityWordsFree
:: Int
-> Int
-> Integer
countIdentityWordsFree g n = countWordReductionsFree g n 0
countWordReductionsFree
:: Int
-> Int
-> Int
-> Integer
countWordReductionsFree gens_ nn_ kk_
| nn==0 = if k==0 then 1 else 0
| even nn && kk == 0 = sum [ ( binomial (nni) (n i) * gg^(i ) * (gg1)^(n i ) * ( i) ) `div` (nni) | i<-[0..n ] ]
| even nn && even kk = sum [ ( binomial (nni) (nki) * gg^(i+1) * (gg1)^(n+ki1) * (kk+i) ) `div` (nni) | i<-[0..nk] ]
| odd nn && odd kk = sum [ ( binomial (nni) (nki) * gg^(i+1) * (gg1)^(n+ki ) * (kk+i) ) `div` (nni) | i<-[0..nk] ]
| otherwise = 0
where
g = fromIntegral gens_ :: Integer
nn = fromIntegral nn_ :: Integer
kk = fromIntegral kk_ :: Integer
gg = 2*g
n = div nn 2
k = div kk 2
multiplyZ2 :: Eq a => Word a -> Word a -> Word a
multiplyZ2 w1 w2 = reduceWordZ2 (w1++w2)
multiplyZ3 :: Eq a => Word a -> Word a -> Word a
multiplyZ3 w1 w2 = reduceWordZ3 (w1++w2)
multiplyZm :: Eq a => Int -> Word a -> Word a -> Word a
multiplyZm k w1 w2 = reduceWordZm k (w1++w2)
reduceWordZ2 :: Eq a => Word a -> Word a
reduceWordZ2 = loop where
loop w = case reduceStep w of
Nothing -> w
Just w' -> loop w'
reduceStep :: Eq a => Word a -> Maybe (Word a)
reduceStep = go False where
go changed w = case w of
(Gen x : Gen y : rest) | x==y -> go True rest
(Gen x : Inv y : rest) | x==y -> go True rest
(Inv x : Gen y : rest) | x==y -> go True rest
(Inv x : Inv y : rest) | x==y -> go True rest
(this : rest) -> liftM (this:) $ go changed rest
_ -> if changed then Just w else Nothing
reduceWordZ3 :: Eq a => Word a -> Word a
reduceWordZ3 = loop where
loop w = case reduceStep w of
Nothing -> w
Just w' -> loop w'
reduceStep :: Eq a => Word a -> Maybe (Word a)
reduceStep = go False where
go changed w = case w of
(Gen x : Inv y : rest) | x==y -> go True rest
(Inv x : Gen y : rest) | x==y -> go True rest
(Gen x : Gen y : Gen z : rest) | x==y && y==z -> go True rest
(Inv x : Inv y : Inv z : rest) | x==y && y==z -> go True rest
(Gen x : Gen y : rest) | x==y -> go True (Inv x : rest)
(Inv x : Inv y : rest) | x==y -> go True (Gen x : rest)
(this : rest) -> liftM (this:) $ go changed rest
_ -> if changed then Just w else Nothing
reduceWordZm :: Eq a => Int -> Word a -> Word a
reduceWordZm m = loop where
loop w = case reduceStep w of
Nothing -> w
Just w' -> loop w'
halfm = div m 2
reduceStep :: Eq a => Word a -> Maybe (Word a)
reduceStep = go False where
go changed w = case w of
(Gen x : Inv y : rest) | x==y -> go True rest
(Inv x : Gen y : rest) | x==y -> go True rest
something | Just (k,rest) <- dropIfMoreThanHalf w -> go True (replicate (mk) (inverseGen (head w)) ++ rest)
(this : rest) -> liftM (this:) $ go changed rest
_ -> if changed then Just w else Nothing
dropIfMoreThanHalf :: Eq a => Word a -> Maybe (Int, Word a)
dropIfMoreThanHalf w =
let (k,rest) = dropWhileEqual w
in if k > halfm then Just (k,rest)
else Nothing
dropWhileEqual :: Eq a => Word a -> (Int, Word a)
dropWhileEqual [] = (0,[])
dropWhileEqual (x0:rest) = go 1 rest where
go k [] = (k,[])
go k xxs@(x:xs) = if k==m then (m,xxs)
else if x==x0 then go (k+1) xs
else (k,xxs)
countIdentityWordsZ2
:: Int
-> Int
-> Integer
countIdentityWordsZ2 g n = countWordReductionsZ2 g n 0
countWordReductionsZ2
:: Int
-> Int
-> Int
-> Integer
countWordReductionsZ2 gens_ nn_ kk_
| nn==0 = if k==0 then 1 else 0
| even nn && kk == 0 = sum [ ( binomial (nni) (n i) * g^(i ) * (g1)^(n i ) * ( i) ) `div` (nni) | i<-[0..n ] ]
| even nn && even kk = sum [ ( binomial (nni) (nki) * g^(i+1) * (g1)^(n+ki1) * (kk+i) ) `div` (nni) | i<-[0..nk] ]
| odd nn && odd kk = sum [ ( binomial (nni) (nki) * g^(i+1) * (g1)^(n+ki ) * (kk+i) ) `div` (nni) | i<-[0..nk] ]
| otherwise = 0
where
g = fromIntegral gens_ :: Integer
nn = fromIntegral nn_ :: Integer
kk = fromIntegral kk_ :: Integer
n = div nn 2
k = div kk 2
countIdentityWordsZ3NoInv
:: Int
-> Int
-> Integer
countIdentityWordsZ3NoInv gens_ nn_
| nn==0 = 1
| mod nn 3 == 0 = sum [ ( binomial (3*ni1) (ni) * g^i * (g1)^(ni) * i ) `div` n | i<-[1..n] ]
| otherwise = 0
where
g = fromIntegral gens_ :: Integer
nn = fromIntegral nn_ :: Integer
n = div nn 3