Code
Code
In[]:=
CombinatorStep[Automatic,expr_,{"Parallel","Innermost"}]:=MapAt[Replace[#,{s[x_][y_][z_]:>x[z][y[z]],k[x_][y_]:>x}]&,expr,ParallelInnermostParts[Position[expr,s[_][_][_]|k[_][_]]]]
In[]:=
LexSort[list_]:=(ToExpression/@Characters[#])&/@Sort[StringJoin/@Map[ToString,list,{2}]]
In[]:=
InnerOnly[list_]:=Catch[Append[Table[If[ListStrictPrefixQ[list[[i+1]],list[[i]]],Nothing,list[[i]]],{i,Length[list]-1}],Last[list,Throw[{}]]]]
In[]:=
ParallelInnermostParts[list_]:=InnerOnly[LexSort[list]]
In[]:=
ParallelInnermostParts[Position[s[s[s][s][s[s][k[k][s]][s]]][s][s][s[k[s][k]][k][s]],s[_][_][_]|k[_][_]]]
Out[]=
{{0,0,0,1,1,0,1},{1,0,0,1}}
Tests
Tests
In[]:=
LeafCount/@NestList[CombinatorStep[Automatic,#,{"Parallel","Innermost"}]&,s[s][s][s[s]][s][s],60]
Out[]=
{7,8,8,11,11,11,12,17,25,33,41,50,59,68,77,87,97,107,117,127,137,148,159,170,193,216,239,262,286,310,346,407,529,676,823,1057,1328,1661,2240,3178,4477,5962,7963,10939,14954,19888,26346,35897,50152,69829,94590,125736,168678,230446,313582,425808,578143,791630,1087484,1496997,2050375}
In[]:=
Ratios[%]//N
Out[]=
{1.14286,1.,1.375,1.,1.,1.09091,1.41667,1.47059,1.32,1.24242,1.21951,1.18,1.15254,1.13235,1.12987,1.11494,1.10309,1.09346,1.08547,1.07874,1.08029,1.07432,1.06918,1.13529,1.11917,1.10648,1.09623,1.0916,1.08392,1.11613,1.1763,1.29975,1.27788,1.21746,1.28433,1.25639,1.25075,1.34859,1.41875,1.40875,1.3317,1.33563,1.37373,1.36704,1.32995,1.32472,1.36252,1.39711,1.39235,1.35459,1.32927,1.34153,1.36619,1.36076,1.35788,1.35776,1.36926,1.37373,1.37657,1.36966}
In[]:=
ListStepPlot[%]
Out[]=
In[]:=
LeafCount/@NestList[CombinatorStep[Automatic,#,{"Parallel","Innermost"}]&,s[s[s]][s][s][s][s],80]
Out[]=
$Aborted
In[]:=
Length[FixedPointList[CombinatorStep[Automatic,#,{"Parallel","Innermost"}]&,s[s][s][s[s[s]]][k][s]]]
Out[]=
27
In[]:=
Length[FixedPointList[CombinatorStep[Automatic,#,{"Parallel","Innermost"}]&,s[s][s][s[s]][s][s][k]]]
Out[]=
$Aborted
In[]:=
ListStepPlot[LeafCount/@FixedPointList[CombinatorStep[Automatic,#,{"Parallel","Innermost"}]&,s[s][s][s[s[s]]][k][s]]]
Out[]=
In[]:=
Length[FixedPointList[CombinatorStep[Automatic,#,{"Parallel","Innermost"}]&,s[s][s][s[s[s]]][k][s]]]
Out[]=
27
In[]:=
Length@FixedPointList[#/.{s[x_][y_][z_]x[z][y[z]],k[x_][y_]x}&,s[s][s][s[s[s]]][k][s]]
Out[]=
26