Free Idempotent Monoid

Author

Eric W. Weisstein
August 18, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GroupTheory/FreeIdempotentMonoid.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/FreeIdempotentMonoid.html.

©2008 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Enumeration discussion and code by
Todd Rowland
October 29, 2002

Analytic Counting

Table[Sum[Binomial[n,k]Product[(k-i+1)^(2^i),{i,k}],{k,0,n}],{n,6}]

V6

Product[(k-i+1)^(2^i),{i,k}]

Table[(E^(2 ((2^k) Derivative[1,0][PolyLog][0,2]-Derivative[0,1,0][LerchPhi][2,0,-k]))),{k,6}]//FullSimplify

FunctionExpand[%]

N[%,20]//Chop

V7

Product[(k-i+1)^(2^i),{i,k}]//Timing

Table[((E^((2^(1+k)) Derivative[0,1,0][LerchPhi][2,0,0]-Derivative[0,1,0][LerchPhi][2,0,-1-k]))/(1+k)),{k,2}]//FullSimplify

FunctionExpand[%]

N[%]//Chop

TimeConstrained[Sum[Binomial[n,k]Product[(k-i+1)^(2^i),{i,k}],{k,0,n}],60]//Timing

Enumeration

Todd Rowland

In general suspicious of the idea that free idempotent monoids were finite, and unable to find the reference right away, I set out to test it.  Since any sequence with a repeated subsequence is redundant in a list of elements, it makes sense to consider those without any such repeats.

Sometimes intuition can be useful, and other times misleading.  Here my intuition told me that any sequence without a square would be a unique representative.  That is wrong though, becuase overlaps can occur which lead to new identities.  There is an algorithm called completion, and what we see here is a version of that.  New ways of transforming strings, while always maintaining equality, are introduced to lead to a set of rules which always put a string into a normal form.  In general such procedures may not work, for instance for groups there are undecidable presentations, but it is a very useful procedure, used for instance in automated theorem proving.  In this case, we find some rules which always transform a string containing 1's, 2's and 3's into a normal form, where equality is deduced from the identity a a=a.  The original article has a more general (for arbitrary number of generators) representation of elements (and normal form).  Here we see a more concrete, experimental approach.

DeleteCases[Flatten[Table[Flatten[Array[List,Table[3,{i}]],i-1],{i,4}],1],{___,b__,b__,___},1]

these functions use the rule of  reducing repeated subwords, in an attempt at finding a canonical subword.

step0[a_List]:=ReplaceList[a,{x___,b__,b__,y___}->{x,b,y}]

step1[a_]:=With[{ans=step0[a]},If[ans=={},{a},ans]]

step[a_]:=Apply[Union,step1/@a]

canons[a_]:=FixedPoint[step,{a}]

for example,

canons[{1,2,2,2}]

Doing a search showed that this works fine up to strings of length 8, in that they all get reduced to the same element.  But then there is a problem with several of length 9.

Select[Flatten[Table[Flatten[Array[List,Table[3,{i}]],i-1],{i,8}],1],Length[canons[#]]>1&]

Select[Flatten[Table[Flatten[Array[List,Table[3,{i}]],i-1],{i,9}],1],Length[canons[#]]>1&,1]

canons[{1,2,1,2,3,2,1,2,3}]

That string has two interpretations because there are two sets of repeating subwords, and they overlap.  So now we add this to the old rule to get two rules to try to transform strings into normal forms.

twostep0[a_List]:=ReplaceList[a,{{x___,b__,b__,y___}->{x,b,y},{x___,c__,d__,e__,d__,c__,d__,e__,y___}->{x,c,d,e,y}}]

twostep1[a_]:=With[{ans=twostep0[a]},If[ans=={},{a},ans]]

twostep[a_]:=Apply[Union,twostep1/@a]

twocanons[a_]:=FixedPoint[twostep,{a}]

But again, a search yields a string which gets reduced in more than one way.

Timing[Select[Flatten[Table[Flatten[Array[Rest[FoldList[Mod[#1+#2,3,1]&,0,List[##]]]&,Table[2,{i}]],i-1],{i,12}],1],Length[twocanons[#]]>1&,1]]

twocanons[{1,2,3,1,3,2,1,2,3,1,3,1}]

So we need to add a third rule.

tristep0[a_List]:=ReplaceList[a,{{x___,b__,b__,y___}->{x,b,y},{x___,c__,d__,e__,d__,c__,d__,e__,y___}->{x,c,d,e,y},{x___,f__,g__,h__,f__,h__,g__,f__,g__,h__,f__,y___}->{x,f,g,h,f,y}}]

tristep1[a_]:=With[{ans=tristep0[a]},If[ans=={},{a},ans]]

tristep[a_]:=Apply[Union,tristep1/@a]

tricanons[a_]:=FixedPoint[tristep,{a}]

Again, a string is found which gets reduced to more than one simplest form.

Timing[Select[Flatten[Table[Flatten[Array[FoldList[Mod[#1+#2,3,1]&,1,List[##]]&,Table[2,{i}]],i-1],{i,12}],1],Length[tricanons[#]]>1&,1]]

tricanons[{1,2,3,1,2,3,2,1,3,1,2,3}]

fourstep0[a_List]:=ReplaceList[a,{{x___,b__,b__,y___}->{x,b,y},{x___,c__,d__,e__,d__,c__,d__,e__,y___}->{x,c,d,e,y},{x___,f__,g__,h__,f__,h__,g__,f__,g__,h__,y___}->{x,f,g,h,y},{x___,ff__,gg__,hh__,gg__,ff__,hh__,ff__,gg__,hh__,y___}->{x,ff,gg,hh,y}
}]

fourstep1[a_]:=With[{ans=fourstep0[a]},If[ans=={},{a},ans]]

fourstep[a_]:=Apply[Union,fourstep1/@a]

fourcanons[a_]:=FixedPoint[fourstep,{a}]

Timing[Select[Flatten[Table[Flatten[Array[FoldList[Mod[#1+#2,3,1]&,1,List[##]]&,Table[2,{i}]],i-1],{i,12}],1],Length[fourcanons[#]]>1&,1]]

fourcanons[{1,2,3,1,2,3,2,1,3,1,2}]

Again we add a new rule, but this time one of the old ones becomes redundant and we can remove it.

fivestep0[a_List]:=ReplaceList[a,{{x___,b__,b__,y___}->{x,b,y},{x___,c__,d__,e__,d__,c__,d__,e__,y___}->{x,c,d,e,y},{x___,f__,g__,h__,f__,h__,g__,f__,y___}->{x,f,g,h,g,f,y},{x___,ff__,gg__,hh__,gg__,ff__,hh__,ff__,gg__,y___}->{x,ff,gg,hh,ff,gg,y}
}]

fivestep1[a_]:=With[{ans=fivestep0[a]},If[ans=={},{a},ans]]

fivestep[a_]:=Apply[Union,fivestep1/@a]

fivecanons[a_]:=FixedPoint[fivestep,{a}]

Timing[Select[Flatten[Table[Flatten[Array[FoldList[Mod[#1+#2,3,1]&,1,List[##]]&,Table[2,{i}]],i-1],{i,11}],1],Length[fivecanons[#]]>1&,1]]

fivecanons[{1,2,3,1,2,3,2,1,3}]

Finally, we get a set of rules which always sends a string with three letters to a canonical form.

finstep0[a_List]:=ReplaceList[a,{{x___,b__,b__,y___}->{x,b,y},{x___,c__,d__,e__,d__,c__,d__,e__,y___}->{x,c,d,e,y},{x___,f__,g__,h__,f__,h__,g__,f__,y___}->{x,f,g,h,g,f,y},{x___,ff__,gg__,hh__,gg__,ff__,hh__,ff__,gg__,y___}->{x,ff,gg,hh,ff,gg,y},{x___,fff__,ggg__,hhh__,fff__,ggg__,fff__,hhh__,y___}->{x,fff,ggg,hhh,ggg,fff,hhh,y},{x___,ffff__,gggg__,hhhh__,gggg__,ffff__,hhhh__,gggg__,y___}->{x,ffff,gggg,hhhh,ffff,hhhh,gggg,y}
}]

finstep1[a_]:=With[{ans=finstep0[a]},If[ans=={},{a},ans]]

finstep[a_]:=Apply[Union,finstep1/@a]

fincanons[a_]:=FixedPoint[finstep,{a}]

The following count the number of elements out to a certain string size, not counting the empty word which is the identity element.  So there are 160 distinct elements.

Table[Length[DeleteCases[Flatten[Table[Flatten[Array[List,Table[3,{i}]],i-1],{i,j}],1],{___,b__,b__,___}|{___,a__,bb__,c__,bb__,a__,bb__,c__,___}|{___,aa__,bbb__,cc__,aa__,cc__,bbb__,aa__,___}|{___,aaa__,bbbb__,ccc__,bbbb__,aaa__,ccc__,aaa__,bbbb__,___}|{___,aaaa__,bbbbb__,cccc__,aaaa__,bbbbb__,aaaa__,cccc__,___}|{___,aaaaa__,bbbbbb__,ccccc__,bbbbbb__,aaaaa__,ccccc__,bbbbbb__,___},1]],{j,9}]

Length[Union[First[fincanons[#]]&/@Flatten[Table[Flatten[Array[Rest[FoldList[Mod[#1+#2,3,1]&,0,List[##]]]&,Table[If[j==1,3,2],{j,i}]],i-1],{i,9}],1]]]

Union[First[fincanons[#]]&/@Flatten[Table[Flatten[Array[Rest[FoldList[Mod[#1+#2,2,1]&,0,List[##]]]&,Table[If[j==1,2,1],{j,i}]],i-1],{i,8}],1]]

fisg2={{1},{2},{1,2},{2,1},{1,2,1},{2,1,2}};

fisg3=Union[First[fincanons[#]]&/@Flatten[Table[Flatten[Array[Rest[FoldList[Mod[#1+#2,3,1]&,0,List[##]]]&,Table[If[j==1,3,2],{j,i}]],i-1],{i,8}],1]];

assQ[m_]:=With[{n=Length[m]},Apply[And,Flatten[Table[m[[m[[i,j]],k]]==m[[i,m[[j,k]]]],{i,n},{j,n},{k,n}]]]]

Although we have already verified that up to string length 12 there is one canonical form for each string, and that no new strings get made past length 8 (overkill).  So there are 160 elements in the free idempotent  monoid with 3 generators.  But for even more overkill, we can verify that these representatives are associative under Join, and so form a monoid.

Timing[assQ[Table[Position[fisg3,First[fincanons[Join[fisg3[[i]],fisg3[[j]]]]]][[1,1]],{i,159},{j,159}]]]

fisg3

strings=Flatten[{"1",StringJoin@@(#/.Thread[{1,2,3}->{"a","b","c"}])&/@fisg3}]

Length[strings]