Standard Sequence:

In[]:=
maxConnectedAtoms[{{1,3}}{{2,3}}]
Out[]=
7
In[]:=
rules=Select[EchoFunction[Length]@ResourceFunction["EnumerateWolframModelRules"][{{1,3}}{{2,3}},6],FullyConnectedRuleQ];
»
10581
In[]:=
Length[rules]
Out[]=
8341
In[]:=
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]
Out[]=
1935
In[]:=
res3=First/@GroupBy[res2,#FinalState&];
In[]:=
Length[res3]
Out[]=
1398
MakePictures2[Values[res3]]

{1,3}{2,3}

{2,2}{3,2}

In[]:=
maxConnectedAtoms[{{2,2}}{{3,2}}]
Out[]=
6
In[]:=
rules=Select[EchoFunction[Length]@ResourceFunction["EnumerateWolframModelRules"][{{2,2}}{{3,2}},6],FullyConnectedRuleQ];
»
11377
In[]:=
Length[rules]
Out[]=
3253
In[]:=
SetDirectory[NotebookDirectory[]]
Out[]=
/Users/sw/Dropbox/Physics/WorkingMaterial/2019
In[]:=
Export["../../Data/22to32connected.wxf",rules]
Out[]=
../../Data/22to32connected.wxf
In[]:=
FileByteCount[%]
Out[]=
175673
In[]:=
res=ParallelMapMonitored[WolframModelTest[#,Automatic]&,rules];
In[]:=
res2=DeleteDuplicates[Select[res,ConnectedGraphQ[UndirectedGraph[Rule@@@#FinalState]]&]];
In[]:=
Length[res2]
Out[]=
2421
In[]:=
res3=First/@GroupBy[res2,#FinalState&];
In[]:=
Length[res3]
Out[]=
580
In[]:=
MakePictures2[Values[res3]]
Out[]=
In[]:=
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]
Out[]=
In[]:=
SeedRandom[234245];#Rule&/@Values[RandomSample[res3,16*6]]
Out[]=
Notables:
In[]:=
{{{{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}}
Out[]=
In[]:=
RulePlot[WolframModel[First[#]]]&/@%
Out[]=
In[]:=
{{1,2},{2,3}}{{1,3},{3,4},{4,2}}/.{1x,2y,3z,4w}
Out[]=
{{x,y},{y,z}}{{x,z},{z,w},{w,y}}
In[]:=
First/@GroupBy[res,#Sizes&]
Out[]=
In[]:=
Keys[%]
Out[]=
In[]:=
FindLinearRecurrence/@%
Out[]=