Legacy (ignore)
Legacy (ignore)
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[]=
WolframModelPlot[{{1,2},{2,3,4},{4,5},{5,6,7},{7,8},{8,9,10},{10,11},{11,12,1}}]
In[]:=
Out[]=
#/.Max[#]1&@Catenate[#+{{1,2},{2,3,4,5}}&/@Range[0,20,4]]
In[]:=
{{1,2},{2,3,4,5},{5,6},{6,7,8,9},{9,10},{10,11,12,13},{13,14},{14,15,16,17},{17,18},{18,19,20,21},{21,22},{22,23,24,1}}
Out[]=
Norm[{0.8675851446178168`,3.973369616111425`}]
In[]:=
4.06699
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〛&/@WolframModel[{{1,2},{2,3,4,5}}{{1,2,3,4},{4,5}},{{1,2},{2,3,4,5},{5,6},{6,7,8,9},{9,10},{10,11,12,13},{13,14},{14,15,16,17},{17,18},{18,19,20,21},{21,22},{22,23,24,25},{25,1}},20,"StatesList"];
In[]:=
evolution=WolframModel[{{1,2},{2,3,4,5}}{{1,2,3,4},{4,5}},{{1,2},{2,3,4,5},{5,6},{6,7,8,9},{9,10},{10,11,12,13},{13,14},{14,15,16,17},{17,18},{18,19,20,21},{21,22},{22,23,24,25},{25,1}},20]
In[]:=
Out[]=
MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[25]#2]]&,{evolution["StatesList"],coordinates}]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
#/.Max[#]1&@Catenate[#+{{1,2},{2,3,4,5}}&/@Range[0,100,4]]
In[]:=
Out[]=
evolution=WolframModel[{{1,2},{2,3,4,5}}{{1,2,3,4},{4,5}},{{1,2},{2,3,4,5},{5,6},{6,7,8,9},{9,10},{10,11,12,13},{13,14},{14,15,16,17},{17,18},{18,19,20,21},{21,22},{22,23,24,25},{25,26},{26,27,28,29},{29,30},{30,31,32,33},{33,34},{34,35,36,37},{37,38},{38,39,40,41},{41,42},{42,43,44,45},{45,46},{46,47,48,49},{49,50},{50,51,52,53},{53,54},{54,55,56,57},{57,58},{58,59,60,61},{61,62},{62,63,64,65},{65,66},{66,67,68,69},{69,70},{70,71,72,73},{73,74},{74,75,76,77},{77,78},{78,79,80,81},{81,82},{82,83,84,85},{85,86},{86,87,88,89},{89,90},{90,91,92,93},{93,94},{94,95,96,97},{97,98},{98,99,100,101},{101,102},{102,103,104,1},{1,2}},40]
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[]:=
MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2]]&,{evolution["StatesList"],coordinates}]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
RulePlot[WolframModel[{{1,2},{2,3,4,5}}{{1,2,3,4},{4,5}}]]
In[]:=
Out[]=
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,160,4]],{{1,165},{165,166,167,168},{168,2}}],60]
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[]:=
MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2],EdgeStyle<|{_,_}WolframPhysicsProjectStyleData["SpatialGraph","EdgeLineStyle"],{_,_,_,_}WolframPhysicsProjectStyleData["SpatialGraph","HighlightStyle"]|>]&,{evolution["StatesList"],coordinates}]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
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]],{}],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[]:=
MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2]]&,{evolution["StatesList"],coordinates}]
In[]:=
Out[]=
evolution["LayeredCausalGraph"]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
No particle
No particle
<<SetReplace`
In[]:=
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,30,4]],{}],30]
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[]:=
rotations=RotationMatrix[{#,{0,1}}]&/@Table[coordinates〚k,Mod[-k,Length[coordinates〚1〛],1]〛,{k,Length[coordinates]}];
In[]:=
rotatingCoordinates=MapThread[Function[{coords,matrix},matrix.#&/@coords],{coordinates,rotations}];
In[]:=
With[{plots=MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2],VertexLabelsAutomatic]&,{evolution["StatesList"],rotatingCoordinates}]},Manipulate[plots〚i〛,{i,1,31,1},SaveDefinitionsTrue]]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
Small example
Small example
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,30,4]],{{1,35},{35,36,37,38},{38,2}}],30]
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[]:=
rotatingCoordinates=MapThread[Function[{coords,matrix},matrix.#&/@coords],{coordinates,rotations}];
In[]:=
With[{plots=MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2]]&,{evolution["StatesList"],rotatingCoordinates}]},Manipulate[plots〚i〛,{i,1,31,1},SaveDefinitionsTrue]]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
Large example
Large example
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,160,4]],{{1,165},{165,166,167,168},{168,2}}],60]
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=ResourceFunction["ParallelMapMonitored"][Rasterize,MapThread[WolframModelPlot[#,VertexCoordinateRulesThread[Range[evolution["AtomsCountTotal"]]#2],EdgeStyle<|{_,_}WolframPhysicsProjectStyleData["SpatialGraph","EdgeLineStyle"],{_,_,_,_}WolframPhysicsProjectStyleData["SpatialGraph","HighlightStyle"]|>]&,{evolution["StatesList"],coordinates}]]},Manipulate[plots〚i〛,{i,1,61,1},SaveDefinitionsTrue]]
In[]:=
Out[]=
Graph3D@evolution["CausalGraph"]
In[]:=
Out[]=
Bigger case
Bigger case
With[{cogs=100},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}}],200,"CausalGraph"]]
In[]:=
Out[]=
With[{cogs=200},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}}],300,"CausalGraph"]]
In[]:=
Out[]=
GraphPlot[%]
In[]:=
Out[]=
GraphPlot[With[{cogs=200},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}}],200,"CausalGraph"]]]
In[]:=
Out[]=
Graph3D[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,160,4]],{{1,165},{165,166,167,168},{168,2}}],60,"CausalGraph"]]
In[]:=
Out[]=
GraphPlot[%]