There are many graph and hypergraph properties that can be studied for the output of our models. Here we primarily give examples for the rule {{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}} discussed above.
A basic question is how the numbers of vertices and edges (elements and relations) grow with successive steps. Plotting on a logarithmic scale suggests eventually roughly exponential growth in this case:
glist = ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y, w}, {z,
w}}, {{1, 2}, {1, 3}}, 15, "StatesList"];
gglist = UndirectedGraph[Rule @@@ #] & /@ glist;
ListLogPlot[{Callout[VertexCount /@ gglist,
Text["vertices",
BaseStyle -> {GrayLevel[.25], FontSize -> 10,
FontFamily -> "Source Serif Pro"}]],
Callout[EdgeCount /@ gglist,
Text["edges",
BaseStyle -> {GrayLevel[.25], FontSize -> 10,
FontFamily -> "Source Serif Pro"}]]}, Frame -> True,
Joined -> True, Mesh -> All,
PlotStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"GenericLinePlot", "PlotStyles"]]
We can also compute the growth of the graph diameter (greatest distance between vertices) and graph radius:
glist = ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y, w}, {z,
w}}, {{1, 2}, {1, 3}}, 15, "StatesList"];
gglist = UndirectedGraph[Rule @@@ #] & /@
glist; ListLogPlot[{Callout[GraphDiameter /@ gglist,
Text["diameter",
BaseStyle -> {GrayLevel[.25], FontSize -> 10,
FontFamily -> "Source Serif Pro"}]],
Callout[GraphRadius /@ gglist,
Text["radius",
BaseStyle -> {GrayLevel[.25], FontSize -> 10,
FontFamily -> "Source Serif Pro"}]]}, Frame -> True,
PlotStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"GenericLinePlot", "PlotStyles"], Joined -> True, Mesh -> All]
If one assumes that the total vertex count V is related to diameter D by V = Dd, then plotting d gives (to be compared to dimension approaching ≈2.68 computed from the growth of Vr):
glist = ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y, w}, {z,
w}}, {{1, 2}, {1, 3}}, 15, "StatesList"];
gglist = UndirectedGraph[Rule @@@ #] & /@ glist;
ListLogPlot[Log[GraphDiameter /@ gglist, VertexCount /@ gglist],
Joined -> True, Mesh -> All, Frame -> True,
PlotStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"GenericLinePlot", "PlotStyles"], Filling -> Axis]
There are many measures of graph structure which basically support the expectation that after many steps, the outputs from the model somehow converge to a kind of statistically invariant “equilibrium” state:
glist = ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y, w}, {z,
w}}, {{1, 2}, {1, 3}}, 15, "StatesList"];
gglist = UndirectedGraph[Rule @@@ #] & /@ glist;
Labeled[ListPlot[#1 /@ gglist, Joined -> True, Mesh -> All,
Frame -> True, Filling -> Axis,
PlotStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"GenericLinePlot", "PlotStyles"]],
Text[#2]] & @@@ {{MeanClusteringCoefficient,
Text["mean clustering coefficient",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily ->
"Source Serif Pro"}]}, {GlobalClusteringCoefficient,
Text["global clustering coefficient",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}]}, {GraphAssortativity,
Text["assortativity",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}]}}
Some centrality measures [32][33] start (here at step 10) somewhat concentrated, but rapidly diffuse to be much more broadly distributed:
cent[f_, gtest_, mult_ : 12] :=
With[{cc = f[gtest]},
Graph[gtest, VertexStyle -> Red,
VertexSize -> Thread[VertexList[gtest] -> (mult cc)/Max[cc]],
VertexStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"SpatialGraph", "VertexStyle"],
EdgeStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"SpatialGraph", "EdgeLineStyle"]]];
gtest = ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y, w}, {z,
w}}, {{1, 2}, {1, 3}}, 10, "FinalState"];
Labeled[cent[#, gtest], Text[#2]] & @@@ {{DegreeCentrality,
Text[ "degree centrality",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}]}, {BetweennessCentrality,
Text["betweenness centrality",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}]}, {EigenvectorCentrality,
Text["eigenvector centrality",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}]}}
There are local features of the graph that are closely related to V1(X) and V2(X):
cent[f_, gtest_, mult_ : 12] :=
With[{cc = f[gtest]},
Graph[gtest, Sequence[
VertexStyle -> Red,
VertexSize -> Thread[VertexList[gtest] -> mult (cc/Max[cc])],
VertexStyle -> ResourceFunction["WolframPhysicsProjectStyleData"][
"SpatialGraph", "VertexStyle"],
EdgeStyle -> ResourceFunction["WolframPhysicsProjectStyleData"][
"SpatialGraph", "EdgeLineStyle"]]]]; gtest =
ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y, w}, {z,
w}}, {{1, 2}, {1, 3}}, 10, "FinalState"];
Labeled[cent[#, gtest], Text[#2]] & @@@ {{VertexDegree,
Text[ "vertex degree",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily ->
"Source Serif Pro"}]}, {LocalClusteringCoefficient,
Text[ "local clustering coefficient",
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}] }}
Another feature of our graphs to study is their cycle structure. At the outset, our graphs give us only connectivity information. But one way to imagine identifying “faces” that could be used to infer emergent topology is to look at the fundamental cycles in the graph:
With[{gtest =
UndirectedGraph[
Rule @@@
ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y,
w}, {z, w}}, {{1, 2}, {1, 3}}, 10, "FinalState"],
VertexStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"SpatialGraph", "VertexStyle"],
EdgeStyle ->
ResourceFunction["WolframPhysicsProjectStyleData"][
"SpatialGraph", "EdgeLineStyle"]]},
With[{gtestcycs = FindFundamentalCycles[UndirectedGraph[gtest]]},
Table[Labeled[
HighlightGraph[UndirectedGraph[gtest, ImageSize -> Small],
Style[#, Red, Thickness[.02]] & /@
Flatten[Select[gtestcycs, Length[#] == c &]]],
Text[StringTemplate["cycle length ``"][c],
BaseStyle -> {GrayLevel[.25], FontSize -> .75 Inherited,
FontFamily -> "Source Serif Pro"}]], {c, 3, 8}]]]
In this particular graph, there are altogether 320 fundamental cycles, with the longest one being of length 24. The distribution of cycle lengths on successive steps once again seems to approach an “equilibrium” form:
Table[With[{gtest =
UndirectedGraph[
Rule @@@
ResourceFunction[
"WolframModel"][{{x, y}, {x, z}} -> {{x, z}, {x, w}, {y,
w}, {z, w}}, {{1, 2}, {1, 3}}, t, "FinalState"]]},
With[{gtestcycs = FindFundamentalCycles[UndirectedGraph[gtest]]},
Histogram[Length /@ gtestcycs, {1},
Epilog ->
Text[Style[Row[{Style["t", Italic], StringTemplate[" = ``"][t]}],
Directive[FontSize -> 12, GrayLevel[0.2],
FontFamily -> "Source Serif Pro"]],
Scaled[{0.8, 1}], {-1.0, 1.6}], Frame -> True,
FrameTicks -> {Automatic, None}, AspectRatio -> 1/2]]], {t, 10,
15}]
One way to probe overall properties of a graph is to consider the evolution of some dynamical process on the graph. For example, one could run a totalistic cellular automaton with values at nodes of the graph. Another possibility is to solve a discretized PDE. For example, having computed a graph Laplacian [34] (or its higher order analogs) one can determine the distribution of eigenvalues, or the eigenmodes, for a particular graph [35]. The density of eigenvalues is then closely related to Vr and our estimates of dimension and curvature.