Standard Sequence:

maxConnectedAtoms[{{1,3}}{{2,3}}]
In[]:=
7
Out[]=
rules=Select[EchoFunction[Length]@ResourceFunction["EnumerateWolframModelRules"][{{1,3}}{{2,3}},6],FullyConnectedRuleQ];
In[]:=
10581
»
Length[rules]
In[]:=
8341
Out[]=
ParallelMapMonitored[WolframModelTest[#,Automatic]&,RandomSample[rules,100]];
In[]:=
res=ParallelMapMonitored[WolframModelTest[#,{{1,2},{2,3},{3,1}}]&,rules];
In[]:=
res2=DeleteDuplicates[Select[res,ConnectedGraphQ[UndirectedGraph[Rule@@@#FinalState]]&]];
In[]:=
Length[res2]
In[]:=
1935
Out[]=
res3=First/@GroupBy[res2,#FinalState&];
In[]:=
Length[res3]
In[]:=
1398
Out[]=
MakePictures2[Values[res3]]

{1,3}{2,3}

{2,2}{3,2}

maxConnectedAtoms[{{2,2}}{{3,2}}]
In[]:=
6
Out[]=
rules=Select[EchoFunction[Length]@ResourceFunction["EnumerateWolframModelRules"][{{2,2}}{{3,2}},6],FullyConnectedRuleQ];
In[]:=
11377
»
Length[rules]
In[]:=
3253
Out[]=
SetDirectory[NotebookDirectory[]]
In[]:=
/Users/sw/Dropbox/Physics/WorkingMaterial/2019
Out[]=
Export["../../Data/22to32connected.wxf",rules]
In[]:=
../../Data/22to32connected.wxf
Out[]=
FileByteCount[%]
In[]:=
175673
Out[]=
res=ParallelMapMonitored[WolframModelTest[#,Automatic]&,rules];
In[]:=
res2=DeleteDuplicates[Select[res,ConnectedGraphQ[UndirectedGraph[Rule@@@#FinalState]]&]];
In[]:=
Length[res2]
In[]:=
2421
Out[]=
res3=First/@GroupBy[res2,#FinalState&];
In[]:=
Length[res3]
In[]:=
580
Out[]=
MakePictures2[Values[res3]]
In[]:=
Out[]=
MakeDirectPictures2[{{{{1,2},{1,3}}{{1,2},{2,4},{3,2}},{{0,0},{0,0}},20},{{{1,2},{2,3}}{{1,3},{3,2},{2,4}},{{0,0},{0,0}},15},{{{1,2},{3,2}}{{1,3},{2,3},{4,3}},{{0,0},{0,0}},10},{{{1,2},{2,3}}{{1,3},{3,4},{4,2}},{{0,0},{0,0}},13},{{{1,2},{2,3}}{{1,3},{3,4},{2,4}},{{0,0},{0,0}},16},{{{1,2},{1,3}}{{1,4},{2,4},{3,4}},{{0,0},{0,0}},29},{{{1,2},{2,3}}{{1,4},{4,3},{3,1}},{{0,0},{0,0}},8},{{{1,2},{1,3}}{{2,1},{1,3},{3,4}},{{0,0},{0,0}},22}},4]
In[]:=
Out[]=
SeedRandom[234245];#Rule&/@Values[RandomSample[res3,16*6]]
In[]:=
Out[]=
Notables:
{{{{1,2},{1,3}}{{1,4},{2,4},{3,4}},{{0,0},{0,0}},33},{{{1,2},{2,3}}{{1,3},{3,4},{4,2}},{{0,0},{0,0}},17},{{{1,2},{1,3}}{{1,2},{2,4},{3,2}},{{0,0},{0,0}},24}}
In[]:=
Out[]=
RulePlot[WolframModel[First[#]]]&/@%
In[]:=
Out[]=
{{1,2},{2,3}}{{1,3},{3,4},{4,2}}/.{1x,2y,3z,4w}
In[]:=
{{x,y},{y,z}}{{x,z},{z,w},{w,y}}
Out[]=
First/@GroupBy[res,#Sizes&]
In[]:=
Out[]=
Keys[%]
In[]:=
Out[]=
FindLinearRecurrence/@%
In[]:=
Out[]=
Last[%98]
In[]:=
Out[]=
FindLinearRecurrence[{2,3,4,5,6,8,10,12,15,19,23,29,36,44,56,70,85,109,137}]
In[]:=
{1,0,2,-1,-1,0,-2,2}
Out[]=