Pensieve header: A program to fix UO sequences in virtual tangle diagrams (with profiling).

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\OU"];
<<"../Profile/Profile.m"

SetAttributes[VD,Orderless]

vd=VD[(Subscript[X, -1])[4,1],EOS[5],(Subscript[X, -1])[3,6],(Subscript[X, -1])[7,2],EOS[8]]

js=Cases[vd,(Subscript[X, _])[_,j_]:>j]⋂Cases[vd,(Subscript[X, _])[i_,_]:>i-1]

j1=First[js]

{{s1,i1,j1}}=Cases[vd,(Subscript[X, s_])[i_,j1]:>{s,i,j1}]

{{s2,i2,j2}}=Cases[vd,(Subscript[X, s_])[j1+1,j_]:>{s,j1+1,j}]

Complement[vd,VD[(Subscript[X, s1])[i1,j1],(Subscript[X, s2])[i2,j2]]]

out=Union[
Complement[vd,VD[(Subscript[X, s1])[i1,j1],(Subscript[X, s2])[i2,j2]]],
VD[(Subscript[X, s2])[j1,j2],(Subscript[X, s1])[i1,i2],(Subscript[X, s1 s2])[i1-.3s1,j2+.3s2],(Subscript[X, -s1 s2])[i1+.3s1,j2-.3s2]]
]

Tidy[vd_VD]:=(Subscript[PP, Tidy])@Module[{ps=Union@@(List@@@vd)},
Replace[vd,Thread[ps->Range@Length@ps],{2}] ]

Tidy[out]

γ[vd_VD] := (Subscript[PP, γ])@Module[{js,s1,i1,j1,s2,i2,j2},
js=Cases[vd,(Subscript[X, _])[_,j_]:>j]⋂Cases[vd,(Subscript[X, _])[i_,_]:>i-1];
If[Length[js]==0,vd,
j1=First[js];
{{s1,i1,j1}}=Cases[vd,(Subscript[X, s_])[i_,j1]:>{s,i,j1}];
{{s2,i2,j2}}=Cases[vd,(Subscript[X, s_])[j1+1,j_]:>{s,j1+1,j}];
Tidy@Union[
Complement[vd,VD[(Subscript[X, s1])[i1,j1],(Subscript[X, s2])[i2,j2]]],
VD[(Subscript[X, s2])[j1,j2],(Subscript[X, s1])[i1,i2],(Subscript[X, s1 s2])[i1-.3s1,j2+.3s2],(Subscript[X, -s1 s2])[i1+.3s1,j2-.3s2]]
]
]]

Γ[vd_VD]:=(Subscript[PP, Γ])@FixedPoint[γ,vd,(2^8)]

Γ[T_] /; Head[T]=!=VD := Γ[VD[T]]

vd//γ

vd//γ//γ

vd//γ//γ//γ

vd//γ//γ//γ//γ

vd//Γ // Short

VPB[n_,{σs___}]:=VPB[n,σs];

VD /: vd1_VD **vd2_VD := (Subscript[PP, "**"])@Module[{es1, es2,m2},
es1=Cases[vd1,EOS[i_]:>i];
m2=Max[es2=Cases[vd2,EOS[i_]:>i]];
Tidy[vd1⋃Replace[DeleteCases[vd2,_EOS], i_:>i/m2-1+es1[[1+Count[es2,e_/;i>e]]], {2}]]
]

vd

vd**vd

vd**vd**vd

VD[VPB[n_]]:=VD@@(EOS/@Range[n]);
VD[VPB[n_,(Subscript[σ, i_,j_])]]:=Tidy@Append[VD@@(EOS/@Range[n]),(Subscript[X, +1])[i-0.5,j-0.5]];
VD[VPB[n_,(Subscript[(OverBar[σ]), i_,j_])]]:=Tidy@Append[VD@@(EOS/@Range[n]),(Subscript[X, -1])[i-0.5,j-0.5]];
VD[VPB[n_,σ_,σs__]]:=VD[VPB[n,σ]]**VD[VPB[n,σs]]

VD[VPB[5,(Subscript[(OverBar[σ]), 4,2])]]

vd1=VD[VPB[5,(Subscript[σ, 2,3])]]

vd2=VD[VPB[5,(Subscript[σ, 3,4])]]

VD[VPB[5,(Subscript[σ, 2,3]),(Subscript[σ, 3,4])]]

VD[VPB[5,(Subscript[σ, 2,3]),(Subscript[σ, 3,4])]]//Γ

VPB[3,(Subscript[σ, 1,2]),(Subscript[σ, 1,3]),(Subscript[σ, 2,3])]// Γ

VPB[3,(Subscript[σ, 2,3]),(Subscript[σ, 1,3]),(Subscript[σ, 1,2])]// Γ

R2ReduceB[vd_VD]:=(Subscript[PP, R2ReduceB])@Module[{R2s,R2},
R2s=Cases[vd,(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i+1,j+1]]⋂(List@@vd);
If[Length[R2s]==0,vd,
R2=First@R2s;
Tidy@Complement[vd,VD[R2,R2/.(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i-1,j-1]]]
]]

R2ReduceC[vd_VD]:=(Subscript[PP, R2ReduceC])@Module[{R2s,R2},
R2s=Cases[vd,(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i+1,j-1]]⋂(List@@vd);
If[Length[R2s]==0,vd,
R2=First@R2s;
Tidy@Complement[vd,VD[R2,R2/.(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i-1,j+1]]]
]]

R2Reduce[vd_VD]:=(Subscript[PP, R2Reduce])@FixedPoint[R2ReduceB @* R2ReduceC,vd]

R1Reduce1[vd_VD]:=(Subscript[PP, R1Reduce1])@Tidy@DeleteCases[vd,(Subscript[X, _])[i_,j_]/;Abs[i-j]==1]

R12Reduce[vd_VD]:=(Subscript[PP, R12Reduce])@FixedPoint[R2ReduceB @* R2ReduceC @* R1Reduce1,vd]

VPB[3,(Subscript[σ, 1,2]),(Subscript[σ, 1,3]),(Subscript[σ, 2,3])]// Γ//R2Reduce

VPB[2,(Subscript[σ, 1,2]),(Subscript[σ, 2,1])]//VD

VPB[2,(Subscript[σ, 1,2]),(Subscript[σ, 2,1])]//VD//Γ

VPB[2,(Subscript[σ, 1,2]),(Subscript[σ, 2,1])]//VD//Γ//R2Reduce

VPB[2,(Subscript[σ, 1,2]),(Subscript[σ, 2,1])]//VD//Γ//R12Reduce

Test1[n_,m_]:=Module[{gens,i,j,k,l},
gens=Flatten@Table[{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},{i,n},{j,DeleteCases[Range@n,i]}];
Table[
{i,j,k}=ijk;
R12Reduce[Γ[VPB[n,Sequence@@p,(Subscript[σ, i,j]),(Subscript[σ, i,k]),(Subscript[σ, j,k]),Sequence@@q]]]==R12Reduce[Γ[VPB[n,Sequence@@p,(Subscript[σ, j,k]),(Subscript[σ, i,k]),(Subscript[σ, i,j]),Sequence@@q]]],
{l,0,m-3},{p,Tuples[gens,l]},{q,Tuples[gens,m-3-l]},
{ijk,Join@@(Permutations/@Subsets[Range[n],{3}])}
]]

Test1[3,3]

Union@Flatten@Test1[4,5]

Union@Flatten@Test1[5,4]

Test2[n_,m_]:=Module[{gens,s,r=0,ij,ijk,ijkl,perm,i,j,k,l,tests},
gens=Flatten@Table[{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},{i,n},{j,DeleteCases[Range@n,i]}];
tests=Flatten[{
Table[{i,j}=ij; {
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},q]],VPB[n,Join[p,q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), i,j]),(Subscript[σ, i,j])},q]],VPB[n,Join[p,q]]]
},
{s,0,m-2},{t,0,s},{p,Tuples[gens,t]},{q,Tuples[gens,s-t]},
{ij,Join@@(Permutations/@Subsets[Range[n],{2}])}
],
Table[{i,j,k}=ijk; {
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[σ, i,k]),(Subscript[σ, j,k])},q]],VPB[n,Join[p,{(Subscript[σ, j,k]),(Subscript[σ, i,k]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), j,i]),(Subscript[σ, i,k]),(Subscript[σ, j,k])},q]],VPB[n,Join[p,{(Subscript[σ, j,k]),(Subscript[σ, i,k]),(Subscript[(OverBar[σ]), j,i])},q]]],
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[σ, i,k]),(Subscript[(OverBar[σ]), k,j])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,j]),(Subscript[σ, i,k]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), k,j])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,j]),(Subscript[(OverBar[σ]), k,i]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), j,i]),(Subscript[(OverBar[σ]), k,i]),(Subscript[σ, j,k])},q]],VPB[n,Join[p,{(Subscript[σ, j,k]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), j,i])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), j,i]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), k,j])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,j]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), j,i])},q]]]
},
{s,0,m-3},{t,0,s},{p,Tuples[gens,t]},{q,Tuples[gens,s-t]},
{ijk,Join@@(Permutations/@Subsets[Range[n],{3}])}
],
Table[{i,j,k,l}=ijkl[[perm]]; {
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[σ, k,l])},q]],VPB[n,Join[p,{(Subscript[σ, k,l]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), i,j]),(Subscript[σ, k,l])},q]],VPB[n,Join[p,{(Subscript[σ, k,l]),(Subscript[(OverBar[σ]), i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), k,l])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,l]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), i,j]),(Subscript[(OverBar[σ]), k,l])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,l]),(Subscript[(OverBar[σ]), i,j])},q]]]
},
{s,0,m-2},{t,0,s},{p,Tuples[gens,t]},{q,Tuples[gens,s-t]},
{ijkl,Subsets[Range[n],{4}]},{perm,{{1,2,3,4},{1,3,2,4},{1,4,2,3}}}
]
}];
Cases[tests, T[b1_,b2_]/;R12Reduce[Γ[b1]]=!=R12Reduce[Γ[b2]]]
]

Test2[3,3]

Test2[3,4]

Test2[3,5]

Test2[4,2]

Test2[4,3]

VPB[3,(Subscript[(OverBar[σ]), 1,2]),(Subscript[σ, 1,3]),(Subscript[σ, 2,3])]//Γ//R2Reduce

VPB[3,(Subscript[σ, 2,3]),(Subscript[σ, 1,3]),(Subscript[(OverBar[σ]), 1,2])]//Γ//R2Reduce

AllVPBInvariants[n_,m_]:=Module[{gens,k},
gens=Flatten@Table[{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},{i,n},{j,DeleteCases[Range@n,i]}];
Flatten@Table[VPB[n,Sequence@@p]->R12Reduce@Γ@VPB[n,Sequence@@p], {k,0,m},{p,Tuples[gens,k]}]]

AllVPBInvariants[2,2]//Column

VPBGenerators[n_]:=VPBGenerators[n]=Flatten@Table[{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},{i,n},{j,DeleteCases[Range@n,i]}];

VPBGenerators[5]

(*CountOUForms[n_,m_]:=Module[{k},
Length@Union@Flatten@Table[R12Reduce@Γ@VPB[n,Sequence@@p], {k,0,m},{p,Tuples[VPBGenerators[n],k]}]]*)

ProudFollowers[n_,(Subscript[σ, i_,j_])] :=ProudFollowers[n,(Subscript[σ, i,j])]= (Subscript[PP, ProudFollowers])@Module[{p,q,s},
Flatten@{(Subscript[σ, i,j]),(Subscript[σ, j,i]),(Subscript[(OverBar[σ]), j,i]),
Table[{(Subscript[σ, p,q]),(Subscript[σ, q,p]),(Subscript[(OverBar[σ]), p,q]),(Subscript[(OverBar[σ]), q,p])},{p,{i,j}},{q,Complement[Range[n],{i,j}]}],
Table[{(Subscript[σ, p,q]),(Subscript[(OverBar[σ]), p,q])},{p,Complement[Range[i+1,n],{j}]},{q,Complement[Range[n],{i,j,p}]}]
}];
ProudFollowers[n_,(Subscript[(OverBar[σ]), i_,j_])] := ProudFollowers[n,(Subscript[(OverBar[σ]), i,j])]=ProudFollowers[n,(Subscript[σ, i,j])]/.(Subscript[σ, i,j])->(Subscript[(OverBar[σ]), i,j])

ProudFollowers[5,(Subscript[σ, 2,3])]

ProudFollowers[5,(Subscript[(OverBar[σ]), 2,3])]

ProudVPBs[n_,0]:={VPB[n]};
ProudVPBs[n_,1]:=VPB[n,#]&/@VPBGenerators[n];
ProudVPBs[n_,m_]/;m>1:=(Subscript[PP, ProudVPBs])[
Flatten[ProudVPBs[n,m-1]/.VPB[n,σs___,σ_]:>(VPB[n,σs,σ,#]&/@ProudFollowers[n,σ])]]

ProudVPBs[2,2]

ProudVPBs[3,3]

CountOUForms[n_,m_]:=(Subscript[PP, CountOUForms])@Module[{k},
Length@Union@Flatten@Table[R12Reduce@Γ@vpb, {k,0,m},{vpb,ProudVPBs[n,k]}]]

Timing@CountOUForms[2,1]

Timing@CountOUForms[2,2]

Timing@CountOUForms[2,3]

Timing@CountOUForms[2,4]

Timing@CountOUForms[2,5]

Timing@CountOUForms[2,6]

FindSequenceFunction[{5,17,53,161,485,1457}]

FindLinearRecurrence[{5,17,53,161,485,1457}]

Timing@CountOUForms[3,1]

Timing@CountOUForms[3,2]

Timing@CountOUForms[3,3]

Timing@CountOUForms[3,4]

Timing@CountOUForms[3,5]

Timing@CountOUForms[3,6]

{17038.5`,1913737}

((17038.5`)^2)/484.328125`

FindSequenceFunction[{13,145,1561,16717,178873,1913737}]

Timing@CountOUForms[4,1]

Timing@CountOUForms[4,2]

Timing@CountOUForms[4,3]

Timing@CountOUForms[4,4]

Timing@CountOUForms[4,5]

((9002.375`)^2)/243.4375`

{25,529,10873,222289,4540201}

Timing@CountOUForms[5,1]

Timing@CountOUForms[5,2]

Timing@CountOUForms[5,3]

Timing@CountOUForms[5,4]

((1459.640625`)^2)/24.515625`

Timing@CountOUForms[5,5]

{41,1361,43121, 1351481}

Timing@CountOUForms[6,1]

Timing@CountOUForms[6,2]

Timing@CountOUForms[6,3]

Timing@CountOUForms[6,4]

FindSequenceFunction@{61,2881,127021,5484721}

Timing@CountOUForms[7,1]

Timing@CountOUForms[7,2]

Timing@CountOUForms[7,3]

{85,5377,310633}

Timing@CountOUForms[8,1]

Timing@CountOUForms[8,2]

Timing@CountOUForms[8,3]

{113,9185,668081}

Timing@CountOUForms[9,1]

Timing@CountOUForms[9,2]

Timing@CountOUForms[9,3]

{145,14689}

CountOUForms[n,1]:

n//FindSequenceFunction@{1,5,13,25,41,61,85,113,145}

CountOUForms[n,2]:

n//FindSequenceFunction@{1,17,145,529,1361,2881,5377,9185,14689}

CountOUForms[n,3]:

n//FindSequenceFunction@{1,53,1561,10873,43121,127021,310633,668081,1307233}

Profiling

Timing@CountOUForms[3,4]

BeginProfile[];Timing@CountOUForms[3,4]
EndProfile[]; PrintProfile[]

BeginProfile[];Timing@CountOUForms[4,4]
EndProfile[]; PrintProfile[]

??Profile