This is some code to help out understanding the Braid reductions for David Amos and myself.

For Mathematica web documentation please use:

http://reference.wolfram.com/mathematica/guide/Mathematica.html

Generation and Configuration:

gen is a variable stores all the reductions. They look like:

"(Subscript[σ, 1])(Subscript[σ, 2])(Subscript[σ, 1])"->"(Subscript[σ, 2])(Subscript[σ, 1])(Subscript[σ, 2])"

or

"(Subscript[σ, 1])(Subscript[σ, 3])"->"(Subscript[σ, 3])(Subscript[σ, 1])"

Every word is a Mathemtaica texts String. Mind you the indecies are coded into a larger binary string but nontheless they are accounted for transpartent to us but get reflected at the end of our computations.

If you do not specify anything the Braid relations come out in some order, as specified in the books, this order is bothersome and impacts the results.

relations is a variable storing all relationships in a Mathematica list and Erelations is list of relations where the words reduce to unit element of the group, which in our case dealing with the positive words is left empty i.e. { }.

Notice the list of generators is ordered:

gen = makeGen[5]
relations=makeBraids[gen]
Length[relations]
Erelations = {};

randShuffle [ ] randomly disorders any list, so we applied this to the generators in order to make sure there are no patterns to the relations nor to their evaluation.

As you can see the relations are shuffeled:

gen = makeGen[5]
relations=randShuffle[makeBraids[gen]]
Length[relations]
Erelations = {};

Let’s make a random word for (Subscript[B, 5]). So the length of the number of tokens is 100 but the final concatenated word in binary is 1576 which has all the Mathematica overhead for indecies and delimeters and so on. 

In all Complexity theories this is reflected in the O(1) notation for inequalities and is unavoidable crap no matter what people did. That is why there are no equalities in complexity theory (unlike the shannon theory) and if so it is up to an additive constant. 

So this drawback is present in all formulations of all forms.

Let’s make a random word:

w=randWord[gen,100]
ByteCount[w]

Run it again and it is random but same ByteCount:

w=randWord[gen,100]
ByteCount[w]

<> in Mathematica is string concatenation, [[ ]] is the usual array indexer, here we try to make a string that represent a pattern that the relations could reduce:

i=1;
gen[[i]]<>gen[[i+2]]

i=3;
gen[[i]]<>gen[[i+2]]

Let’s look at w again:

w

Let’s see how many places there are "(Subscript[σ, 1])(Subscript[σ, 3])", by actually counting manually ... 3 ...

Now let’s use Mathemtica’s StringPosition [ ] which patten matches the entire string and issues a list of locations for a candidate pattern in the order of occurance, again we get 3:

i=1;
StringPosition[w,gen[[i]]<>gen[[i+2]]][[All,1]]

Let’s make a much larger word of say 10000 tokens:

w=randWord[gen,10000];

Let’s match "(Subscript[σ, 1])(Subscript[σ, 3])" and plot the order it was found against its physical locations and also find out how manahy such matches:

i=1;
ListPlot[StringPosition[w,gen[[i]]<>gen[[i+2]]][[All,1]]]
Length[StringPosition[w,gen[[i]]<>gen[[i+2]]][[All,1]]]

418 matches all together.

"(Subscript[σ, 3])(Subscript[σ, 5])" shows a similar graph which shows no significant gaps i.e. uniform distribution of the tokens.

i=3;
ListPlot[StringPosition[w,gen[[i]]<>gen[[i+2]]][[All,1]]]
Length[StringPosition[w,gen[[i]]<>gen[[i+2]]][[All,1]]]

399 matches all together.

Let’s do the other relations e.g. "(Subscript[σ, 1])(Subscript[σ, 2])(Subscript[σ, 1])":

i=1;
gen[[i]]<>gen[[i+1]]<>gen[[i]]

Plot like before, and we can see gaps appear but in uniform distances:

i=1;
ListPlot[StringPosition[w,gen[[i]]<>gen[[i+1]]<>gen[[i]]][[All,1]]]
Length[StringPosition[w,gen[[i]]<>gen[[i+1]]<>gen[[i]]][[All,1]]]

Only 74 matches.

Try "(Subscript[σ, 2])(Subscript[σ, 3])(Subscript[σ, 2])":

i=2;
gen[[i]]<>gen[[i+1]]<>gen[[i]]

Plot and you get only 85 matches:

i=2;
ListPlot[StringPosition[w,gen[[i]]<>gen[[i+1]]<>gen[[i]]][[All,1]]]
Length[StringPosition[w,gen[[i]]<>gen[[i+1]]<>gen[[i]]][[All,1]]]

Try "(Subscript[σ, 3])(Subscript[σ, 2])(Subscript[σ, 3])" i.e. the reduction target of "(Subscript[σ, 2])(Subscript[σ, 3])(Subscript[σ, 2])"->"(Subscript[σ, 3])(Subscript[σ, 2])(Subscript[σ, 3])" for replacement:

i=2;
gen[[i+1]]<>gen[[i]]<>gen[[i+1]]

You get the same ball-park number 77 again due to the randomness of the word and uniform distribution of the tokens:

i=2;
ListPlot[StringPosition[w,gen[[i+1]]<>gen[[i]]<>gen[[i+1]]][[All,1]]]
Length[StringPosition[w,gen[[i+1]]<>gen[[i]]<>gen[[i+1]]][[All,1]]]

Let’s study the replacements but we need to separate the two kinds, as you can see below we get a nested list of the form { {...}, {...} }:

gen = makeGen[5]
bi=makeBraidsBI[gen]

Make sure both lists are correct:

bi[[1]]

bi[[2]]

Let’s make a tiny random word:

w=randWord[generators,20]

And look for "(Subscript[σ, 1])(Subscript[σ, 3])"

i=1;
gen[[i]]<>gen[[i+2]]

There are 3 such patterns

i=1;
Length[StringPosition[w,gen[[i]]<>gen[[i+2]]][[All,1]]]

Notice that there are no "(Subscript[σ, 1])(Subscript[σ, 2])" in the code.

Now call reduceWord [ ] which is my rountine that replaces "(Subscript[σ, 1])(Subscript[σ, 3])"->"(Subscript[σ, 3])(Subscript[σ, 1])" for example, it uses FixedPoint [ ] in Mathematica to know when to stop replacing and max is set to 1000000 such replacements at a time:

w2=reduceWord[w, bi[[2]],{}]

The current code is 1-pass i.e. we stop at the word above for "(Subscript[σ, 1])(Subscript[σ, 3])"->"(Subscript[σ, 3])(Subscript[σ, 1])".

Notice that there is NOW "(Subscript[σ, 1])(Subscript[σ, 2])" in the code. 

But as you can see we can take the output w2 above and re-apply the "(Subscript[σ, 1])(Subscript[σ, 3])"->"(Subscript[σ, 3])(Subscript[σ, 1])" and get another word:

reduceWord[w2, bi[[2]],{}]

Q: Why we limited ourselves to 1-pass? 
A1: The replacements might fall into infinite loops i.e. some pattern replacements might be circular. 1-pass has no such risk. 

A2: The irriducible outcome is not unique!

See checkredution for counterexamples. 


TODO: So our estimates are all for 1-pass. We need to investigate multi-pass if possible.

Lemma: The irriducible outputs are lower in complexity (i.e. multi-pass), therefore the upperbound estimates for the difference in complexity are higher for the 1-pass.

Shuffling the evaluation made no difference since the word is small in length:

reduceWord[w, bi[[2]],{}]
reduceWord[w, randShuffle[bi[[2]]],{}]

No reduction for the other list of relations, again since the word is small:

w
reduceWord[w, bi[[1]],{}]

Let’s make a longer random word:

w3 = randWord[generators,50]

Now let’s see if the order of the relations matter. 
 
 Ordered list:

bi[[2]]

Shuffeled relations:

randShuffle[bi[[2]]]

1-pass replacement will not produce the same results:

reduceWord[w3, bi[[2]],{}]===reduceWord[w3, randShuffle[bi[[2]]],{}]
reduceWord[w3, bi[[2]],{}]
reduceWord[w3, randShuffle[bi[[2]]],{}]

Let’s get brave and make irriducible reductions for long braid words, FixedPoint [ ] does that in Mathematica for any function:

reduceWord[w3, bi[[2]],{}]
FixedPoint[reduceWord[#,bi[[2]],{}]&, w3, 1000000]

As we can see there is a difference.

Let’s experiment and see how much the approximation to compexity drops, by using ByteCount[Compress[ ] ] as the approximation, which Compress [ ] in Mathematica is I believe LZW of some kind.

wlarge is a random word, wReduced is 1-pass reduction but the relations are ordered, wRandReduced is randomizes the relations but still 1-pass, wIR is irriducible output by with the relations ordered, wRandIR irriducible and  relations shuffeled:

gen = makeGen[5]
relations=makeBraids[gen]
Erelations = {};
wlarge = randWord[gen,20000];
wReduced=reduceWord[wlarge,relations,Erelations ];
wRandReduced=reduceWord[wlarge,randShuffle[relations],Erelations ];
wIR=FixedPoint[reduceWord[#,relations,Erelations ]&, wlarge, 1000000];
wRandIR=FixedPoint[reduceWord[#,randShuffle[relations],Erelations ]&, wlarge, 1000000];

ByteCount[Compress[wlarge]]
ByteCount[Compress[wReduced]]
ByteCount[Compress[wRandReduced]]
ByteCount[Compress[wIR]]
ByteCount[Compress[wRandIR]]

So the word’s complexity is 20520, reducing 1-pass gets that to 18472 and irriducible reduction reduces the complexity to 14376.

I made a new routine that tries to get the irriducible replacements for the word called

kBraidsStatIRR[n,segment_length,segment_num,trials,fixedpoint_num] 

It breaks up the large word into segments of length segement_length and total number of segments to be segment_num, try that for trials many words and attempt to apply FixedPoint [ ] to make sure the output is unchanged up to fixedpoint_num

The earlier code does not care about the replacements being irriducible
kBraidsStat[n,segment_length,segment_num,trials]

As you can see below the distribution is the same, but the kBraidsStatIRR [ ] is more accurate estimate.

gen = makeGen[5]
relations=makeBraids[gen];
Length[relations];
Erelations = {};

w = randWord[gen,50];
reduceWord[w, relations, Erelations]
reduceWordIRR[w,relations, Erelations,1000000]

Now let’s do the same but with irriducible words. As you can see the distribution is almost a line i.e. the complexity reached a limit. 

first number is Max, then Min, then Mean, then standard diviation. 
Noticec how wobbly the distribution is.

kBraidsStatIRR[3,20000,2,2,100]

kBraidsStatIRR[4,20000,2,2,100]

kBraidsStatIRR[5,20000,2,2,100]

kBraidsStatIRR[6,20000,2,10,100]

kBraidsStatIRR[13,20000,2,10,100]

kBraidsStatIRR[13,10000,10,10,100]

kBraidsStatIRR[20,10000,10,10,100]

kBraidsStatIRR[20,10000,2,2,100]

kBraidsStatIRR[20,20000,2,2,100]

kBraidsStatIRR[20,10000,2,2,200]

kBraidsStatIRR[25,10000,2,2,100]

kBraidsStatIRR[30,10000,2,2,100]

kBraidsStatIRR[40,10000,2,2,100]

kBraidsStatIRR[40,20000,2,2,100]

kBraidsStatIRR[60,10000,2,2,100]

kBraidsStatIRR[80,20000,2,2,100]

kBraidsStatIRR[90,20000,2,2,100]

Some sort of Gamma distribution for multi-path or 100-path :

n=.;
list = {{3,0.23076923076923078},  {4,0.3125},{5,0.3333333333333333},{6,0.38999999999999996},{13,0.43034677917618913},{20,0.40336134453781514},{25,0.35555555555555557},{30,0.17777777777777778},{40,0.11686557537938556},{60,0.09580838323353294 }, {80,0.06963397168402116}};


dist =c*(E^(-a*n))*(n^b )+0.08;
params=FindFit[list,dist,{a,b,c,d,f},n];
expr=dist/.params
Show[ListPlot[list, PlotStyle->Red], Plot[expr, {n,3, 80},AxesOrigin->{0,0}, PlotRange->All],AxesOrigin->{0,0}, PlotRange->All,AxesLabel->{"n", "(Underscript[C, (Subscript[ℱ, n]), (Subscript[ℬ, n])])"}]

Poisson does not look like a match:

n=.;
list = {{3,0.23076923076923078},  {4,0.3125},{5,0.3333333333333333},{6,0.38999999999999996},{13,0.38461538461538464},{20,0.40336134453781514},{25,0.35555555555555557},{30,0.17777777777777778},{40,0.11686557537938556},{60,0.09580838323353294 }, {80,0.06963397168402116}};


dist =c*((E^(-μ))*(μ^n )/n!)+0.06;
params=FindFit[list,dist,{μ,c},n];
expr=dist/.params
Show[ListPlot[list, PlotStyle->Red], Plot[expr, {n,3, 80},AxesOrigin->{0,0}, PlotRange->All],AxesOrigin->{0,0}, PlotRange->All,AxesLabel->{"n", "(Underscript[C, (Subscript[ℱ, n]), (Subscript[ℬ, n])])"}]