(* make a random word of length n *)
randWord[gen0_, n0_]:=Module[{gen = gen0, n=n0, word={}},

Table[AppendTo[word,gen[[RandomInteger[{1, Length[gen]}]]]], {i, 1, n}];

StringJoin[word]

]

(* these are for understanding the repeated patterns caused by reductions *)
whichToken[token_,gen_]:=Module[{l=-1},
Table[If[SameQ[gen[[i]],token]==True, l = i],{i, 1, Length[gen]}];
l
]
wordString[w_]:=StringJoin@@(ToString[#,StandardForm]&/@w)

myTakePosition[w_, interval_]:=Module[{ww,sub},

ww=StringJoin@@@Partition[StringSplit[w,delim:"\!":>delim],2];
sub=ww[[interval[[1]];;interval[[2]]]];
Length[StringPosition[wordString[ww],wordString[sub]]]

]

getInterval[w_, interval_]:=Module[{ww,sub},

ww=StringJoin@@@Partition[StringSplit[w,delim:"\!":>delim],2];
wordString[ww[[interval[[1]];;interval[[2]]]]]

]

findSeqMid [w_, token_, offset_]:= Module[{ww,list,l,l2,l3,prev},

ww=StringJoin@@@Partition[StringSplit[w,delim:"\!":>delim],2];
list=Position[ww, token];
l=Floor[Length[list]/2]+offset;

(* go backwards to find the beginning of the sequence starting with token *)
l2=list[[l]][[1]]-1;
While[SameQ[ww[[l2]], token]== True, l2 = l2-1];
l2= l2+1;

l3=l2;
prev=whichToken[token,gen];
While[whichToken[ww[[l3]],gen]≤ prev,prev=whichToken[ww[[l3]],gen]; l3=l3+1];

{{l2, l3-1},wordString[ww[[l2;;l3-1]]]}

]



(* reduce the word by sequentially going down the relations list *)
(* this function is generic no assumptions about the rules *)
reduceWord1[w_, rules_]:=Module[{word=w, steps=1000000},
Table[word=FixedPoint[StringReplace[#,rules[[i]]]&, word, steps], {i, 1, Length[rules]}];

word]

(* this rewrites the string by sandwiching the StringReplace by 
replacements that reduce to unit element, before and after *)
myStringReplace[str_, rule_, Erules_]:=Module[{w=str},
w=reduceWord1[w, Erules];
w=StringReplace[w,rule];
w=reduceWord1[w, Erules]

]


(* This is a more practical reducer for the words. It uses the FixedPoint
up to 1000000 trials to reduce the word to irreducible form, but this might work for each step of the loop might not work after all relations replaced since as a set they might need more reducing *)
reduceWord[w_, rules_, Erules_]:=Module[{word=w, steps=1000000},
Table[word=FixedPoint[myStringReplace[#,rules[[i]], Erules]&, word, steps], {i, 1, Length[rules]}];

word]


(* attempts to make an inrriducible word within steps *)
reduceWordIRR[w_, rules_, Erules_, steps_]:= Module[{word=w},
FixedPoint[reduceWord[#,rules,Erules ]&, word, steps]
]


(* shuffle relationships, for experimentation puproses *)
randShuffle[rels0_]:= Module[{index, rels=rels0},
index = RandomSample[Range[Length[rels]]];
Table[rels[[index[[i]]]], {i, 1,Length[rels]}]
]


makeGen[dim_]:=Array[ToString[Subscript[σ,#1],StandardForm]&,dim]

makeBraids[gen0_]:= Module[{gen = gen0, braids, commute={}},

braids=Table[gen[[i]]<>gen[[i+1]]<>gen[[i]]->gen[[i+1]]<>gen[[i]]<>gen[[i+1]],
{i, 1, Length[gen]-1}];

(* add the commutations *)
Table[If[j-i>=2,AppendTo[commute,gen[[i]]<>gen[[j]]->gen[[j]]<>gen[[i]]]], {i, 1, Length[gen]-2}, {j, 3, Length[gen]}];

Join [Flatten[braids], Flatten[commute]]

]

makeBraidsBI[gen0_]:= Module[{gen = gen0, braids, commute={}},

braids=Table[gen[[i]]<>gen[[i+1]]<>gen[[i]]->gen[[i+1]]<>gen[[i]]<>gen[[i+1]],
{i, 1, Length[gen]-1}];

(* add the commutations *)
Table[If[j-i>=2,AppendTo[commute,gen[[i]]<>gen[[j]]->gen[[j]]<>gen[[i]]]], {i, 1, Length[gen]-2}, {j, 3, Length[gen]}];

{braids, commute}

]

makeBraids2[gen0_]:= Module[{gen = gen0, braids, commute={}},

braids=Table[gen[[i+1]]<>gen[[i]]<>gen[[i+1]]->gen[[i]]<>gen[[i+1]]<>gen[[i]],
{i, 1, Length[gen]-1}];

(* add the commutations *)
Table[If[j-i>=2,AppendTo[commute,gen[[j]]<>gen[[i]]->gen[[i]]<>gen[[j]]]], {i, 1, Length[gen]-2}, {j, 3, Length[gen]}];

Join [Flatten[braids], Flatten[commute]]

]



(* BRUTE FORCE: relations are shuffeled each time called *)
kBraidsBRUTEFORCE[n0_, wordlength0_, trials0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,w,generators ,relations,Erelations, reducew,dist, w1,w2,delta,c},

c=ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],n]]]];
generators = makeGen[n];
relations=randShuffle[makeBraids[generators]];
Erelations = {};
dist=Table[
w=randWord[generators,wordlength];
w1=ByteCount[Compress[w]];
 w2=ByteCount[Compress[reduceWord[w, relations, Erelations ]]];
delta=N[(w1-w2)/(w1-c)],
{i, 1, trials}];
{N[Max[dist]],
N[Min[dist]],
N[Mean[dist]],
Sqrt[N[Variance[dist]]],
ListPlot[dist, AxesOrigin->{0,0}]}
]

kBraidsList[n0_, wordlength0_, trials0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,w,generators ,relations,Erelations, reducew,dist, w1,w2,delta,c,word,rword,rw},

generators = makeGen[n];
relations=randShuffle[makeBraids[generators]];
Erelations = {};
word={};
rword= {};
Table[
w=randWord[generators,wordlength];
AppendTo[word,w];
rw=reduceWord[w, relations, Erelations ];
AppendTo[rword,rw],
{i, 1, trials}];

{StringJoin[word],StringJoin[rword]}

]

kBraidsListIRR[n0_, wordlength0_, trials0_,steps_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,w,generators ,relations,Erelations, reducew,dist, w1,w2,delta,c,word,rword,rw},

generators = makeGen[n];
relations=randShuffle[makeBraids[generators]];
Erelations = {};
word={};
rword= {};
Table[
w=randWord[generators,wordlength];
AppendTo[word,w];
rw=reduceWordIRR[w, relations, Erelations,steps ];
AppendTo[rword,rw],
{i, 1, trials}];

{StringJoin[word],StringJoin[rword]}

]

kBraidsList2[n0_, wordlength0_, trials0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,w,generators ,relations,Erelations, reducew,dist, w1,w2,delta,c,word,rword,rw},

generators = makeGen[n];
relations=randShuffle[makeBraids2[generators]];
Erelations = {};
word={};
rword= {};
Table[
w=randWord[generators,wordlength];
AppendTo[word,w];
rw=reduceWord[w, relations, Erelations ];
AppendTo[rword,rw],
{i, 1, trials}];

{StringJoin[word],StringJoin[rword]}

]

kBraids[n0_, wordlength0_, trials0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,words,c,w1,w2},

words=kBraidsList[n,wordlength,trials];
c=ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],wordlength*trials]]]];
w1=ByteCount[Compress[words[[1]]]];
w2=ByteCount[Compress[words[[2]]]];

N[(w1-w2)/(w1-c)]

]

kBraidsIRR[n0_, wordlength0_, trials0_, steps_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,words,c,w1,w2},

words=kBraidsListIRR[n,wordlength,trials,steps];
c=ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],wordlength*trials]]]];
w1=ByteCount[Compress[words[[1]]]];
w2=ByteCount[Compress[words[[2]]]];

N[(w1-w2)/(w1-c)]

]

kBraids2[n0_, wordlength0_, trials0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,words,c,w1,w2},

words=kBraidsList2[n,wordlength,trials];
c=ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],wordlength*trials]]]];
w1=ByteCount[Compress[words[[1]]]];
w2=ByteCount[Compress[words[[2]]]];

N[(w1-w2)/(w1-c)]

]

kBraidsStat[n0_, wordlength0_, trials0_, samples0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,samples=samples0,dist},

dist=Table[kBraids[n,wordlength,trials],{i,1,samples}];
{N[Max[dist]],
N[Min[dist]],
N[Mean[dist]],
Sqrt[N[Variance[dist]]],
ListPlot[dist, AxesOrigin->{0,0}]}
]

kBraidsStatIRR[n0_, wordlength0_, trials0_, samples0_,steps_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,samples=samples0,dist},

dist=Table[kBraidsIRR[n,wordlength,trials,steps],{i,1,samples}];
{N[Max[dist]],
N[Min[dist]],
N[Mean[dist]],
Sqrt[N[Variance[dist]]],
ListPlot[dist, AxesOrigin->{0,0}]}
]

kBraidsStat2[n0_, wordlength0_, trials0_, samples0_]:=Module[{n=n0,wordlength = wordlength0,trials=trials0,samples=samples0,dist},

dist=Table[kBraids2[n,wordlength,trials],{i,1,samples}];
{N[Max[dist]],
N[Min[dist]],
N[Mean[dist]],
Sqrt[N[Variance[dist]]],
ListPlot[dist, AxesOrigin->{0,0}]}
]

generators = makeGen[5]
relations=makeBraids[generators]
Length[relations]
(*relations=randShuffle[makeBraids[generators]]*)
Erelations = {};

generators = makeGen[5]
relations=makeBraids2[generators]
Length[relations]
(*relations=randShuffle[makeBraids[generators]]*)
Erelations = {};

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

n=100;
ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],n]]]]
StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],50]]
ByteCount[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],50]]]
ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],50]]]]
rel=ToString[Subscript[σ,5],StandardForm]<>ToString[Subscript[σ,7],StandardForm]->ToString[Subscript[σ,7],StandardForm]<>ToString[Subscript[σ,5],StandardForm]
w2=StringReplace[w,rel]
ByteCount[Compress[w]]
ByteCount[Compress[w2]]

w=randWord[generators,60000];
ByteCount[w]
c=ByteCount[Compress[StringJoin[ConstantArray[ToString[Subscript[σ,1],StandardForm],n]]]];
ww2=reduceWord[w, relations,Erelations ];
w1=ByteCount[Compress[w]]
w2=ByteCount[Compress[ww2]]

N[(w1-w2)/(w1-c)]

kBraidsList[3,5,4]

kBraids[3,20000,50]

kBraidsStat[5,20000,50,10]

kBraidsStat[10,20000,50,10]

kBraidsStat[11,20000,50,10]

kBraidsStat[20,20000,50,10]

kBraidsStat[30,20000,50,10]

kBraidsStat[40,20000,50,10]

kBraidsStat[60,20000,50,10]

kBraidsStat[100,20000,50,10]

generators = makeGen[5]
relations=makeBraids2[generators]
Length[relations]
Erelations = {};

The different types of reductions are the same statistics:

kBraidsStat2[3,5000,50,10]

kBraidsStat[3,5000,50,10]

kBraidsStat[10,1000,50,10]
kBraidsStat2[10,1000,50,10]

list = {{3,0.1850366009326074},  {5,0.13782165449169198},{10,0.08908591736522065},{20,0.033005866897323946},{30,0.020967431391238817},{40,0.019239566365197837},{60,0.012979309928502786}, {100,0.008618504572613407}};
curve=Fit[list,{1,n^-1},n]
Show[ListPlot[list, PlotStyle->Red], Plot[curve, {n, 3, 110},AxesOrigin->{0,0}, PlotRange->All],AxesLabel->{"n", "(Underscript[C, (Subscript[ℱ, n]), (Subscript[ℬ, n])])"}]