HypergraphPlot[WolframModel[{{1,2,3},{4,2,5}}{{6,3,1},{3,6,4},{1,2,6}},{{0,0,0},{0,0,0}},800,"FinalState"]]
In[]:=
Out[]=
2^(rLog[r])
In[]:=
rLog[r]
2
Out[]=
Plot[{r^2,2^(rLog[r]),r^Sqrt[r],2^r},{r,0,5}]
In[]:=
Out[]=
AsymptoticLess[r^Sqrt[r],2^(rLog[r]),r->Infinity]
In[]:=
True
Out[]=
AsymptoticLess[r,2^(rLog[r]),r->Infinity]
In[]:=
True
Out[]=
AsymptoticLess[2^r,2^(rLog[r]),r->Infinity]
In[]:=
True
Out[]=
Asymptotic[r^Sqrt[r]/2^(rLog[r]),{r,Infinity,2}]
In[]:=
-rLog[r]
2
r
r
Out[]=
Plot[%,{r,0,10}]
In[]:=
Out[]=
Asymptotic[2^(rLog[r]),{r,Infinity,2}]
In[]:=
rLog[r]
2
Out[]=
NeighborhoodGraph[IndexGraph[TorusGraph[{20,20}]],{1},2]
In[]:=
Out[]=
gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]
In[]:=
Out[]=
With[{gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]},ReverseSortBy[(Graph[First[#],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]]
In[]:=
Out[]=
With[{gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},11,"FinalState"]]},ReverseSortBy[(Graph[First[#],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]]
In[]:=
Out[]=
With[{gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},12,"FinalState"]]},ReverseSortBy[(Graph[First[#],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]]
In[]:=
Out[]=
With[{gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},13,"FinalState"]]},ReverseSortBy[(Graph[CanonicalGraph[First[#]],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]]
In[]:=
Out[]=
With[{gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]},ReverseSortBy[(Graph[CanonicalGraph[First[#]],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]]
In[]:=
Out[]=
With[{gr=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]},ReverseSortBy[(Graph[CanonicalGraph[First[#]],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,2]&/@VertexList[gr],IsomorphicGraphQ],Last]]
In[]:=
Out[]=
HypergraphToGraph[WolframModel[{{1,2,3},{4,2,5}}{{6,3,1},{3,6,4},{1,2,6}},{{0,0,0},{0,0,0}},800,"FinalState"]]
In[]:=
Out[]=
gr=UndirectedGraph[%170];
In[]:=
ReverseSortBy[(Graph[CanonicalGraph[First[#]],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]
In[]:=
Out[]=
HypergraphPlot/@WolframModel[{{1,2,3}}{{1,4,6},{2,5,4},{3,6,5}},{{0,0,0}},6,"StatesList"]
In[]:=
Out[]=
WolframModel[{{1,2,3}}{{1,4,6},{2,5,4},{3,6,5}},{{0,0,0}},4]
In[]:=
Out[]=
%["FinalState"]
In[]:=
Out[]=
SimpleGraph[Flatten[Thread/@#]]&/@NestList[Flatten[#/.(x_<->{a_,b_,c_}):>Module[{ap,bp,cp},{ap{a,bp,cp},bp{ap,b,cp},cp{ap,bp,c}}]]&,{1{2,3,4},2{1,3,4},3{1,2,4},4{1,2,3}},3]
In[]:=
Out[]=
Withgr=
,ReverseSortBy[(Graph[CanonicalGraph[First[#]],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,ImageSize30]->Length[#])&/@Gather[NeighborhoodGraph[gr,#,1]&/@VertexList[gr],IsomorphicGraphQ],Last]
In[]:=
Out[]=
VertexOutDegree
In[]:=
{3,3,3,3,2,2,3,2,3,3,3,3,3,3,3,3,3,3,3,2,2,3,2,3,3,3,3,3,3,3,3,2,2,3,2,3,3,3,3,3,3,3,3,2,2,3,2,3,3,3,3,3}
Out[]=
oo={{0,40,41},{13,42,40},{14,41,42},{4,43,44},{15,45,43},{13,44,45},{5,46,47},{14,48,46},{15,47,48},{1,49,50},{16,51,49},{17,50,51},{6,52,53},{18,54,52},{16,53,54},{4,55,56},{17,57,55},{18,56,57},{2,58,59},{19,60,58},{20,59,60},{5,61,62},{21,63,61},{19,62,63},{6,64,65},{20,66,64},{21,65,66},{0,67,68},{22,69,67},{23,68,69},{7,70,71},{24,72,70},{22,71,72},{8,73,74},{23,75,73},{24,74,75},{3,76,77},{25,78,76},{26,77,78},{9,79,80},{27,81,79},{25,80,81},{7,82,83},{26,84,82},{27,83,84},{1,85,86},{28,87,85},{29,86,87},{8,88,89},{30,90,88},{28,89,90},{9,91,92},{29,93,91},{30,92,93},{0,94,95},{31,96,94},{32,95,96},{10,97,98},{33,99,97},{31,98,99},{11,100,101},{32,102,100},{33,101,102},{2,103,104},{34,105,103},{35,104,105},{12,106,107},{36,108,106},{34,107,108},{10,109,110},{35,111,109},{36,110,111},{3,112,113},{37,114,112},{38,113,114},{11,115,116},{39,117,115},{37,116,117},{12,118,119},{38,120,118},{39,119,120}};
In[]:=
Union[Flatten[oo]]
In[]:=
Out[]=
Flatten[(First/@Position[oo,#])]&/@Union[Flatten[oo]]
In[]:=
Out[]=
Graph[Rest[%]]
In[]:=
Out[]=