{{1,2}}->{{2,2}}
{{1,2}}->{{2,2}}
allrules12=EnumerateWolframModelRules[{{1,2}}{{2,2}}];
In[]:=
Length[allrules12]
In[]:=
73
Out[]=
lens=ParallelMapMonitored[(Length[WeaklyConnectedComponents[Graph[Rule@@@#]]]&/@WolframModel[#,{{0,0}},8,"StatesList"])&,allrules12];
In[]:=
Counts[lens]
In[]:=
{1,1,1,1,1,1,1,1,1}33,{1,1}10,{1,1,2,4,8,16,32,64,128}20,{1,1,1,2,4,8,16,32,64}6,{1,1,3,7,15,31,63,127,255}4
Out[]=
Keys[%]
In[]:=
{{1,1,1,1,1,1,1,1,1},{1,1},{1,1,2,4,8,16,32,64,128},{1,1,1,2,4,8,16,32,64},{1,1,3,7,15,31,63,127,255}}
Out[]=
Counts[ParallelMapMonitored[(Length[WeaklyConnectedComponents[Graph[Rule@@@#]]]&/@WolframModel[#,{{1,2}},8,"StatesList"])&,allrules12]]
In[]:=
{1}15,{1,1,1,1,1,1,1,1,1}27,{1,2,2,2,2,2,2,2,2}1,{1,2,3,5,9,17,33,65,129}4,{1,1,2,4,8,16,32,64,128}16,{1,1,1,2,4,8,16,32,64}6,{1,2,4,8,16,32,64,128,256}4
Out[]=
27+15
In[]:=
42
Out[]=
xlens=ParallelMapMonitored[{#,(Length[WeaklyConnectedComponents[Graph[Rule@@@#]]]&/@WolframModel[#,{{0,0}},8,"StatesList"])}&,allrules12];
In[]:=
First/@GatherBy[xlens,Last]
In[]:=
Out[]=
First/@%124
In[]:=
{{{1,1}}{{1,1},{1,1}},{{1,1}}{{1,2},{1,2}},{{1,2}}{{1,1},{2,3}},{{1,2}}{{2,3},{2,3}},{{1,2}}{{1,3},{2,4}}}
Out[]=
EvolutionPicture2[#,{{0,0}},5]&/@%127
In[]:=
Out[]=
Counts[ParallelMapMonitored[((Sort[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[#,{{0,0}},8,"StatesList"])&,allrules12]]
In[]:=
Out[]=
xxlens=ParallelMapMonitored[{#,((Length/@WeaklyConnectedComponents[Graph[Rule@@@#]])&/@WolframModel[#,{{0,0}},8,"StatesList"])}&,allrules12];
In[]:=
First/@GatherBy[xxlens,Last]
In[]:=
Out[]=
First/@%
In[]:=
Out[]=
EvolutionPicture2[#,{{0,0}},5,ImageSizeTiny]&/@%134
In[]:=
Out[]=
Select[%133,Union[Length/@#[[2]]]=!={1}&]
In[]:=
Out[]=
First/@%
In[]:=
Out[]=
EvolutionPicture2[#,{{0,0}},5,{ImageSizeTiny,EdgeStyleArrowheads[Small]}]&/@%138
In[]:=
Out[]=
CountsBy[xxlens,Last]
In[]:=
Out[]=
WeaklyConnectedGraphComponents[Graph[Rule@@@#,ImageSize50]]&/@WolframModel[{{x,y}}{{y,y},{x,z}},{{0,0}},6,"StatesList"]
In[]:=
Out[]=
WeaklyConnectedGraphComponents[Graph[Rule@@@#,ImageSize50]]&/@WolframModel[{{x,y}}{{x,x},{y,z}},{{0,0}},6,"StatesList"]
In[]:=
Out[]=
First/@%156
In[]:=
Out[]=
EdgeList@*IndexGraph/@%173
In[]:=
Out[]=
Graph[Rule@@@#]&/@WolframModel[{{{1,1}}{{1,2},{1,1}},{{1,2}}{{1,1}}},{{1,1}},6,"StatesList"]
In[]:=
Out[]=
Length/@%
In[]:=
{1,1,2,4,8,16,32}
Out[]=
((Length/@WeaklyConnectedComponents[Graph[Rule@@@#]])&/@WolframModel[{{x,y}}{{y,y},{x,z}},{{0,0}},8,"StatesList"])
In[]:=
Out[]=
Counts/@%
In[]:=
Out[]=
Counts/@((Length/@WeaklyConnectedComponents[Graph[Rule@@@#]])&/@WolframModel[{{x,y}}{{x,x},{y,z}},{{0,0}},8,"StatesList"])
In[]:=
{11,21,22,31,22,11,41,25,12,61,211,14,91,31,222,18,141,41,32,244,116,221,61,42,34,288,132}
Out[]=
Max[Keys[#]]&/@%
In[]:=
{1,2,2,3,4,6,9,14,22}
Out[]=
FindSequenceFunction[%,n]
In[]:=
1
2
Out[]=
FindLinearRecurrence[%161]
In[]:=
{2,0,-1}
Out[]=
Table(2-Fibonacci[n]+LucasL[n]),
1
2
DiscreteAsymptotic(2-Fibonacci[n]+LucasL[n]),{n,Infinity,0}
1
2
In[]:=
1+-+
nπ+Log[2]-Log[4]+Log[1+
5
]
2
5
n-Log[2]+Log[1+
5
]
2
5
LucasL[n]
2
Out[]=
FullSimplify[%166,n>0]
In[]:=
1
10
5
n
1
2
5
)5
n
1
2
5
)nπ
Out[]=
DiscreteAsymptotic[Fibonacci[n],{n,Infinity,0}]
In[]:=
-+
nπ+Log[2]-Log[4]+Log[1+
5
]
5
n-Log[2]+Log[1+
5
]
5
Out[]=
Max[Keys[#]]&/@Counts/@((Length/@WeaklyConnectedComponents[Graph[Rule@@@#]])&/@WolframModel[{{x,y}}{{x,x},{y,z}},{{0,0}},14,"StatesList"])
In[]:=
{1,2,2,3,4,6,9,14,22,35,56,90,145,234,378}
Out[]=
Ratios[%]//N
In[]:=
{2.,1.,1.5,1.33333,1.5,1.5,1.55556,1.57143,1.59091,1.6,1.60714,1.61111,1.61379,1.61538}
Out[]=
LinearRecurrence[{2,0,-1},{1,2,2},10]
In[]:=
{1,2,2,3,4,6,9,14,22,35}
Out[]=
RecurrenceTable[{f[n]2f[n-1]-f[n-3],f[1]1,f[2]f[3]2},f,{n,15}]
In[]:=
{1,2,2,3,4,6,9,14,22,35,56,90,145,234,378}
Out[]=
Fu
{{1,2}}->{{3,2}}
{{1,2}}->{{3,2}}
Tracking largest component size
Tracking largest component size
((Max[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[{{x,y}}{{y,y},{x,z}},{{0,0}},8,"StatesList"])
In[]:=
{1,2,3,4,5,6,7,8,9}
Out[]=
allrules13=EnumerateWolframModelRules[{{1,2}}{{3,2}}];
In[]:=
Length[allrules13]
In[]:=
506
Out[]=
mllist=ParallelMapMonitored[((Max[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[#,{{0,0}},8,"StatesList"])&,allrules13];
In[]:=
Counts[mllist]
In[]:=
Out[]=
AnyTrue[Negative]@*Differences/@%
In[]:=
Out[]=
mllist2=ParallelMapMonitored[((Max[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[#,{{0,0},{0,0}},8,"StatesList"])&,allrules13];
In[]:=
Counts[mllist2]
In[]:=
Out[]=
Position[AnyTrue[Negative]@*Differences/@%,True]
In[]:=
{}
Out[]=
{{2,2}}->{{3,2}}
{{2,2}}->{{3,2}}
allrules=EnumerateWolframModelRules[{{2,2}}{{3,2}}];
In[]:=
Length[allrules]
In[]:=
4702
Out[]=
lens=ParallelMapMonitored[(Length[WeaklyConnectedComponents[Graph[Rule@@@#]]]&/@WolframModel[#,{{0,0},{0,0}},5,"StatesList"])&,allrules];
In[]:=
Counts[lens]
In[]:=
Out[]=
mlx=ParallelMapMonitored[((Max[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[#,{{0,0},{0,0}},8,"StatesList"])&,allrules];
In[]:=
Take[mlx,3]
In[]:=
{{1,1,1,1,1,1,1,1,1},{1,2,3,4,5,6,7,8,9},{1,2,3,4,5,6,7,8,9}}
Out[]=
Counts[%]
In[]:=
Out[]=
KeySelect[%,AnyTrue[Negative]@*Differences]
In[]:=
Out[]=
Position[mlx,{1,3,4,7,10,13,8,11,14}]
In[]:=
{{2290}}
Out[]=
allrules[[2290]]
In[]:=
{{1,2},{1,3}}{{2,1},{2,4},{1,5}}
Out[]=
EvolutionPicture2[{{1,2},{1,3}}{{2,1},{2,4},{1,5}},13]
In[]:=
Out[]=
EdgeCount/@%
In[]:=
{2,3,4,6,9,12}
Out[]=
((Max[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[allrules[[2290]],{{0,0},{0,0}},10,"StatesList"])
In[]:=
{1,3,4,7,10,13,8,11,14,14,18}
Out[]=
((Max[Length/@WeaklyConnectedComponents[UndirectedGraph[Rule@@@#]]])&/@WolframModel[allrules[[2290]],{{0,0},{0,0}},10,"StatesList"])
In[]:=
{1,3,4,7,10,13,8,11,14,14,18}
Out[]=
((Max[Length/@WeaklyConnectedComponents[UndirectedGraph[Rule@@@#]]])&/@WolframModel[allrules[[2290]],{{0,0},{0,0}},16,"StatesList"])
In[]:=
{1,3,4,7,10,13,8,11,14,14,18,21,21,19,25,33,36}
Out[]=
Position[mlx,{1,3,5,6,7,6,5,6,7}]
In[]:=
{{2437},{3614},{4582}}
Out[]=
EvolutionPicture2[allrules[[2437]],13]
In[]:=
Out[]=
EvolutionPicture2[allrules[[3614]],13]
In[]:=
Out[]=
Position[mlx,{1,3,4,7,9,7,9,7,9}]
In[]:=
{{2415},{2939},{3395},{3505},{3607},{3808}}
Out[]=
EvolutionPicture2[allrules[[2415]],13]
In[]:=
Out[]=
EvolutionPicture2[allrules[[3607]],10]
In[]:=
Out[]=
InteractiveListSelectorSW[ListLinePlot[#,PlotTheme"Minimal",ImageSizeTiny]#&/@Keys[%113]]
In[]:=
Out[]=
{{1,2,3,4,3,3,4,4,5},{1,2,3,4,5,5,6,5,6},{1,2,3,3,4,7,10,9,7}}
Position[mlx,#]&/@{{1,2,3,4,3,3,4,4,5},{1,2,3,4,5,5,6,5,6},{1,2,3,3,4,7,10,9,7}}
In[]:=
{{{1854},{4037}},{{2271},{2484}},{{2503}}}
Out[]=
Framed[EvolutionPicture2[allrules[[#]],8]]&/@Flatten[%133]
In[]:=
Out[]=
EvolutionPicture2[allrules[[2271]],12]
In[]:=
Out[]=
allrules[[2271]]
In[]:=
{{1,2},{2,3}}{{3,3},{3,4},{2,4}}
Out[]=
((Max[Length/@WeaklyConnectedComponents[UndirectedGraph[Rule@@@#]]])&/@WolframModel[allrules[[2271]],{{0,0},{0,0}},16,"StatesList"])
In[]:=
{1,2,3,4,5,5,6,5,6,5,6,5,6,5,6,5,6}
Out[]=
allrules[[1854]]
In[]:=
{{1,2},{1,3}}{{2,2},{3,1},{3,4}}
Out[]=
(First[WeaklyConnectedGraphComponents[Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]]])&/@WolframModel[allrules[[1854]],{{0,0},{0,0}},16,"StatesList"]
In[]:=
Out[]=
EdgeCount/@%
In[]:=
{2,3,4,5,5,2,7,8,10,12,13,16,20,20,27,29,35}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
Position[mlx,#]&/@{{1,2,3,4,3,3,4,3,4},{1,3,4,7,8,8,7,8,8},{1,3,4,7,9,5,4,5,5}}
In[]:=
{{{3148},{4485}},{{3406}},{{3393}}}
Out[]=
Framed[EvolutionPicture2[allrules[[#]],8]]&/@Flatten[%]
In[]:=
Out[]=
(First[WeaklyConnectedGraphComponents[Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]]])&/@WolframModel[allrules[[1854]],{{0,0},{0,0}},12,"StatesList"]&/@allrules[[{3148,4485,3406,3393}]]
In[]:=
Out[]=
Map[EdgeCount,%146,{2}]
In[]:=
{{2,3,4,5,5,2,7,8,10,12,13,16,20},{2,3,4,5,5,2,7,8,10,12,13,16,20},{2,3,4,5,5,2,7,8,10,12,13,16,20},{2,3,4,5,5,2,7,8,10,12,13,16,20}}
Out[]=
mlx=ParallelMapMonitored[((Max[Length/@WeaklyConnectedComponents[Graph[Rule@@@#]]])&/@WolframModel[#,{{0,0},{0,0}},11,"StatesList"])&,allrules];
In[]:=
KeySelect[Counts[%150],AnyTrue[Negative]@*Differences];
In[]:=
InteractiveListSelectorSW[ListLinePlot[#,PlotTheme"Minimal",ImageSizeTiny]#&/@Keys[%]]
In[]:=
Out[]=
Position[mlx,#]&/@{{1,2,3,2,3,2,3,5,3,6,7,7},{1,2,3,5,7,8,7,5,7,8,7,5},{1,3,5,5,6,7,5,6,7,7,6,7}}
In[]:=
{{{106},{544},{1867},{1870},{1875},{1876},{1886},{1890},{1903},{1907},{1912},{1915},{2070},{2073},{2077},{2080},{2082},{2087},{2101},{2109},{2115},{2118}},{{1863},{4059}},{{4665}}}
Out[]=
First/@%
In[]:=
{{106},{1863},{4665}}
Out[]=
Flatten[%]
In[]:=
{106,1863,4665}
Out[]=
(First[WeaklyConnectedGraphComponents[Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]]])&/@WolframModel[#,{{0,0},{0,0}},12,"StatesList"]&/@allrules[[{106,1863,4665}]]
In[]:=
Out[]=
Map[EdgeCount,%,{2}]
In[]:=
{{2,3,4,1,6,7,9,12,14,19,24,30,39},{2,3,4,6,8,9,8,6,8,9,8,6,8},{2,3,4,4,5,6,4,5,6,6,5,6,6}}
Out[]=
allrules[[1863]]
In[]:=
{{1,2},{1,3}}{{2,3},{3,2},{1,4}}
Out[]=
FindRepeat[{6,8,9,8,6,8,9,8,6,8}]
In[]:=
{6,8,9,8}
Out[]=
XYifyRule[{{1,2},{1,3}}{{2,3},{3,2},{1,4}}]
In[]:=
{{x,y},{x,z}}{{y,z},{z,y},{x,w}}
Out[]=
(First[WeaklyConnectedGraphComponents[Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding",ImageSize50]]])&/@WolframModel[{{x,y},{x,z}}{{y,z},{z,y},{x,w}},{{0,0},{0,0}},12,"StatesList"]
In[]:=
Out[]=
Length/@WolframModel[{{x,y},{x,z}}{{y,z},{z,y},{x,w}},{{0,0},{0,0}},25,"StatesList"]
In[]:=
{2,3,4,6,8,11,14,20,26,33,44,62,80,103,142,196,254,337,468,634,832,1127,1554,2084,2774,3789}
Out[]=
Ratios[%]//N
In[]:=
{1.5,1.33333,1.5,1.33333,1.375,1.27273,1.42857,1.3,1.26923,1.33333,1.40909,1.29032,1.2875,1.37864,1.38028,1.29592,1.32677,1.38872,1.3547,1.3123,1.35457,1.37888,1.34106,1.33109,1.3659}
Out[]=
FindLinearRecurrence[%180]
In[]:=