SetReplace & Fundamental Physics

Maksim Piskunov, Wolfram Research
Jonathan Gorard, Wolfram Research

Idea

Hypothesis: the Universe is produced as an evolution of a simple system.

Idea: Let’s consider a system with the least amount of structure and see what it does.

Set Substitution System

The system is a Set Substitution System.

https://github.com/maxitg/SetReplace

<<SetReplace`

Similar to Sequential Substitution System, but operates on unordered sets.

SetReplace[{1,2,3,4},{3,1}->{a,b}]

We can use patterns as well:

SetReplace[{1,2,3,4,5},{a_?OddQ,b_?OddQ}:>{a+b}]

The fun starts when the set elements are related to each other

Graph[{{1,2},{2,3},{3,4}},]

SetReplace[{{1,2},{2,3},{3,4}},{{a_,b_},{b_,c_}}:>{{a,c}},2]

We can even create new “vertices” with a Module, which is essentially if we want the Universe to grow:

SetReplace[{{1,2}},{{a_,b_}}:>Module[{new},{{a,new},{new,b}}],2]

There is a simpler way to specify such rules:

ToPatternRules[{{1,3}}->{{1,2},{2,3}}]

WolframModel

There is also a more general function: WolframModel.

rule={{0,1},{0,2},{0,3}}->{{4,5},{5,4},{4,6},{6,4},{5,6},{6,5},{4,1},{5,2},{6,3},{1,6},{3,4}};

evolution=WolframModel[rule,{{0,0},{0,0},{0,0}},6]

In this case each step corresponds to replacing all non-overlapping subgraphs

Rasterize/@HypergraphPlot/@evolution/@Range[0,6]

evolution["Properties"]

We can also get a graph demonstrating causal relationships between events:

GraphPlot[evolution["CausalGraph"]]//Rasterize

BraneElectricalEmbedding

Edges can have more than 2 vertices

triangulatedPolygon[n_,opts___]:=TriangulateMesh[RegularPolygon[n],opts]

ClearAll[flatPolygonGraph];
flatPolygonGraph[ns_List,opts___]:=With[{separateGraphs=If[#>2,Graph[UndirectedEdge@@@Flatten[List@@@MeshCells[triangulatedPolygon[#,opts],1],1]],If[#==2,Graph[{1->3,3->4,4->5,5->6,6->7,7->8,8->9,9->10,10->2},DirectedEdges->False],Graph[{1},{}]]]&/@ns},Reap[FoldList[With[{indexGraph=Sow[VertexReplace[#2,n_:>n+#1-1]]},Max@VertexList[indexGraph]+1]&,1,separateGraphs]][[2,1]]]

ClearAll[polygonFaces];
polygonFaces[n_,opts___]/;n>2:=Flatten[List@@@MeshCells[triangulatedPolygon[n,opts],2],1]
polygonFaces[1|2,opts___]:={}

ClearAll[origamiCoordinates];
origamiCoordinates[shapes:{{__}..},opts___]:=With[{graphs=flatPolygonGraph[Length/@shapes,opts]},With[{identifications=Catenate@MapIndexed[Sort[VertexList[graphs[[#2[[1]]]]]][[#2[[2]]]]->With[{firstPosition=FirstPosition[shapes,#]},Sort[VertexList[graphs[[firstPosition[[1]]]]]][[firstPosition[[2]]]]]&,shapes,{2}]},Join[#,identifications/.(a_->b_):>(a->(b/.#))]&@Thread[VertexList[#]->GraphEmbedding[#,"SpringElectricalEmbedding"]&@VertexReplace[Graph[Catenate[EdgeList/@{##}]]&@@graphs,identifications]]]]

ClearAll[hypergraphPlotBranes];
hypergraphPlotBranes[shapes:{{__}..}]:=Module[{graphs,coordinates,polygonGraphics,edgeGraphics,vertexGraphics,vertexSequences},
graphs=flatPolygonGraph[Length/@shapes];
coordinates=origamiCoordinates[shapes];
polygonGraphics=Graphics[Style[Polygon[#],Opacity[.3],Lighter[Hue[0.6, 0.7, 0.5], 0.7]]&/@(Catenate[#[[1]]+Min[VertexList[#[[2]]]]-1&/@Transpose[{polygonFaces[Length[#]]&/@shapes,graphs}]]/.coordinates)];
vertexSequences=Function[{graph,shape},FindShortestPath[EdgeList[graph]//Graph,##]&@@@Partition[Range[Length[shape]]+Min[VertexList[graph]]-1,2,1]]@@@Transpose[{graphs,shapes}];
edgeGraphics=Graphics[Style[Arrow[#],Hue[0.6,0.7,0.5],Opacity[0.7]]&/@(vertexSequences/.coordinates)];
vertexGraphics=Graphics[Style[Disk[#/.coordinates,0.5],Hue[0.6`,0.2`,0.8`],EdgeForm[{GrayLevel[0],Opacity[0.7`]}]]&/@Catenate[(Range[Length[#2]]+Min[VertexList[#1]]-1&)@@@Transpose[{graphs,shapes}]]];
Show[polygonGraphics,edgeGraphics,vertexGraphics]]

hypergraphPlotBranes[{{1,2,3},{3,4,5},{5,6,1}}]

Self-loops

hypergraphPlotBranes[{{1,1,1},{1,1,1}}]

hypergraphPlotBranes[{{1,3,3},{3,5,5},{5,1,1}}]

Multi-hyperedges

hypergraphPlotBranes[{{1,2,3},{1,2,3}}]

hypergraphPlotBranes/@(rule={{1,2,3},{4,5,6},{1,4},{4,1}}->{{3,7,8},{2,9,10},{6,11,12},{5,13,14},{7,14},{8,9},{9,8},{10,11},{11,10},{12,13},{13,12},{14,7}})

hypergraphPlotBranes[{{1,2,3},{4,5,6},{1,4},{4,1},{2,5},{5,2},{3,6},{6,3}}]

Rasterize@hypergraphPlotBranes[WolframModel[{{1,2,3},{4,5,6},{1,4},{4,1}}->{{3,7,8},{2,9,10},{6,11,12},{5,13,14},{7,14},{8,9},{9,8},{10,11},{11,10},{12,13},{13,12},{14,7}},{{1,2,3},{4,5,6},{1,4},{4,1},{2,5},{5,2},{3,6},{6,3}},4,"FinalState"]]

Hypergraph Isomorphism

To evolve and analyze multiway set replacement systems (in which there exist many possible distinct rewrite paths) efficiently, we need a very fast way of detecting hypergraph isomorphisms.

We use a direct generalization of Gorard’s pseudopolynomial time algorithm for standard graph isomorphism.

(J. Gorard, “Uniqueness Trees: A Possible Polynomial Time Approach to the Graph Isomorphism Problem, Journal of Discrete Algorithms, 2016, https://arxiv.org/abs/1606.06399)

IsomorphicHypergraphQ[{{a,e,d},{d,c},{c,b},{b,a}},{{2,4},{4,5,1},{1,3},{3,2}}]

IsomorphicHypergraphQ[{{a,e,d},{d,c},{c,b},{b,a}},{{2,4},{4,3,1},{1,3},{5,2}}]

IsomorphicHypergraphQ[{{1,2},{2,3},{3,4},{4,5}},{{1,2},{2,3},{3,4},{1,5}}]

IsomorphicOrderedHypergraphQ[{{1,2},{2,3},{3,4},{4,5}},{{1,2},{2,3},{3,4},{1,5}}]

FindHypergraphIsomorphism[{{a,e,d},{d,c},{c,b},{b,a}},{{2,4},{4,5,1},{1,3},{3,2}}]

FindOrderedHypergraphIsomorphism[{{a,d},{d,c},{c,b},{b,a}},{{2,4},{4,1},{1,3},{3,2}}]

Multiway Systems and Causal Invariance

With efficient hypergraph isomorphism testing, we now have a way of evolving multiway set replacement systems and determing various combinatorial properties (including, most notably, causal invariance, which implies relativistic invariance).

LayeredGraphPlot[findMultiwayEvolutionGraph[{{{a_,b_},{a_,c_},{a_,d_}}->{{a,b},{a,c},{a,d},{b,c}}},{{1,2},{1,3},{1,4}},6]]

CausallyInvariantQ[{{{a_,b_},{a_,c_},{a_,d_}}->{{a,b},{a,c},{a,d},{b,c}}},{{1,2},{1,3},{1,4}},6]

FindCriticalPairs[{{{a_,b_},{a_,c_},{a_,d_}}->{{a,b},{a,c},{a,d},{b,c}}},{{1,2},{1,3},{1,4}},6]

FindUnresolvedCriticalPairs[{{{a_,b_},{a_,c_},{a_,d_}}->{{a,b},{a,c},{a,d},{b,c}}},{{1,2},{1,3},{1,4}},6]

LayeredGraphPlot[findMultiwayEvolutionGraph[{{{a_},{a_,b_}}->{{b},{a,b}}},{{v0},{v0,v1},{v1,v2},{v2,v3},{v3,v4},{v2,v5},{v5,v6}},6]]

CausallyInvariantQ[{{{a_},{a_,b_}}->{{b},{a,b}}},{{v0},{v0,v1},{v1,v2},{v2,v3},{v3,v4},{v2,v5},{v5,v6}},6]

FindUnresolvedCriticalPairs[{{{a_},{a_,b_}}->{{b},{a,b}}},{{v0},{v0,v1},{v1,v2},{v2,v3},{v3,v4},{v2,v5},{v5,v6}},6]

newRules1=FindKnuthBendixCompletion[{{{a_},{a_,b_}}->{{b},{a,b}}},{{v0},{v0,v1},{v1,v2},{v2,v3},{v3,v4},{v2,v5},{v5,v6}},6]

LayeredGraphPlot[findMultiwayEvolutionGraph[{{{b_,b_,a_},{b_,b_,b_}}->{{a,a,c},{a,a,a},{b,a,b},{c,c,b}}},{{0,0,0},{0,0,0},{0,0,0}},4]]

CausallyInvariantQ[{{{b_,b_,a_},{b_,b_,b_}}->{{a,a,c},{a,a,a},{b,a,b},{c,c,b}}},{{0,0,0},{0,0,0},{0,0,0}},4]

FindCriticalPairs[{{{b_,b_,a_},{b_,b_,b_}}->{{a,a,c},{a,a,a},{b,a,b},{c,c,b}}},{{0,0,0},{0,0,0},{0,0,0}},4]

FindUnresolvedCriticalPairs[{{{b_,b_,a_},{b_,b_,b_}}->{{a,a,c},{a,a,a},{b,a,b},{c,c,b}}},{{0,0,0},{0,0,0},{0,0,0}},4]

ATP and “Filtering” Universes

As a generalization of these methods, we use specialized automated theorem-proving algorithms for hypergraph substitution systems (as opposed to heuristics) as a means of discarding “hopeless” universes.

We have ways of determining (on the basis of purely combinatorial data) whether a candidate universe satisfies the postulates of special relativity and general relativity, whether it supports nontrivial interactions, whether the network limits to a finite number of spacetime dimensions, etc.

Simple "provably boring" universes include those in which the causal network is always a tree, those in which the spatial hypergraphs could also have been generated by a neighborhood - independent substitution system, etc.

rule=(Graph[{a<->d,b<->d,c<->d}]->Graph[{a<->d,b<->e,c<->f,d<->e,e<->f,f<->d}])

theorem=(Graph[{a<->b,b<->c,c<->a,a<->d,b<->d,c<->d}]->Graph[{a<->b,b<->c,c<->d,d<->e,e<->f,f<->a,a<->g,b<->g,c<->h,d<->h,e<->i,f<->i,g<->j,h<->k,i<->l,j<->k,k<->l,l<->j}])

proof=FindNetworkProof[theorem,rule]

proof["ProofGraph"]