WolframModel[{{{1},{1,2}}{{1,2},{2}},{{1,2},{2,2,2},{2,3}}{{1,2},{3,3,3,3},{2,3}},{{1,2},{2,2,2,2},{2,3}}{{1,2},{1,1,1},{2,3}}},Append[Catenate[Table[{{i,i+1},{1,1,1}+i,{i+1,i+2}},{i,1,19,2}]],{2}],20,"CausalGraph"]
In[]:=
Out[]=
WolframModel[{{{1},{1,2}}{{1,2},{2}},{{1,2},{2,2,2},{2,3}}{{1,2},{3,3,3,3},{2,3}},{{1,2},{2,2,2,2},{2,3}}{{1,2},{1,1,1},{2,3}}},Append[Catenate[Table[{{i,i+1},{1,1,1}+i,{i+1,i+2}},{i,1,19,2}]],{2}],20,"StatesPlotsList"]
In[]:=
Out[]=
Newer Particle
Newer Particle
evolution=WolframModel[{{1,2},{2,3,4,5}}{{1,2,3,4},{4,5}},Join[#/.Max[#]1&@Catenate[#+{{1,2},{2,3,4,5}}&/@Range[0,20,4]],{{1,25},{25,26,27,28},{28,2}}],20]
In[]:=
Out[]=
coordinates=With[{center=Mean/@Transpose[#]},With[{matrix=RotationMatrix[{#〚1〛-center,{0,Norm[#〚1〛-center]}}]},With[{firstVertexFixedCoordinates=matrix.(#-center)&/@#},If[firstVertexFixedCoordinates〚2,1〛<0,{-#1,#2}&@@@firstVertexFixedCoordinates,firstVertexFixedCoordinates]]]]&@SetReplace`PackageScope`hypergraphEmbedding["Ordered","Polygons",{}][#]〚1,All,2,1,1〛&/@evolution["StatesList"];
In[]:=
With[{plots=MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2]]&,{evolution["StatesList"],coordinates}]},Table[plots〚i〛,{i,1,21}]]
In[]:=
Out[]=
evolution=With[{cogs=30},WolframModel[{{1,2},{2,3,4,5}}{{1,2,3,4},{4,5}},Join[#/.Max[#]1&@Catenate[#+{{1,2},{2,3,4,5}}&/@Range[0,cogs,4]],{{1,cogs+5},cogs+Range[5,8],{cogs+8,2}}],cogs]]
In[]:=
Out[]=
coordinates=With[{center=Mean/@Transpose[#]},With[{matrix=RotationMatrix[{#〚1〛-center,{0,Norm[#〚1〛-center]}}]},With[{firstVertexFixedCoordinates=matrix.(#-center)&/@#},If[firstVertexFixedCoordinates〚2,1〛<0,{-#1,#2}&@@@firstVertexFixedCoordinates,firstVertexFixedCoordinates]]]]&@SetReplace`PackageScope`hypergraphEmbedding["Ordered","Polygons",{}][#]〚1,All,2,1,1〛&/@evolution["StatesList"];
In[]:=
With[{plots=MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2]]&,{evolution["StatesList"],coordinates}]},Table[plots〚i〛,{i,1,21}]]
In[]:=
Out[]=