ResourceFunction["EnumerateSubstitutionSystemRules"][{22},2]
In[]:=
{{AAAA},{AAAB},{AABB},{ABAA},{ABAB},{ABBA}}
Out[]=
ResourceFunction["SubstitutionSystemCausalGraph"][{"AB""BAAAB"},"AB",8]
In[]:=
Out[]=
LayeredGraphPlot[ResourceFunction["SubstitutionSystemCausalGraph"][{"AB""BAAAB"},"AB",8],AspectRatio1/2]
In[]:=
Out[]=

This case involves superluminal expansion

ResourceFunction["SubstitutionSystemCausalGraph"][{"BA""AB"},"BBBAAA",8]
In[]:=
Out[]=
TimeConstrained[LayeredGraphPlot[ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABB",15],AspectRatio1/2],3]&/@ResourceFunction["EnumerateSubstitutionSystemRules"][{22},2]
In[]:=

,
,
,
,
,

Out[]=
TimeConstrained[LayeredGraphPlot[ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABB",15],AspectRatio1/2],3]&/@ResourceFunction["EnumerateSubstitutionSystemRules"][{23},2]
In[]:=

,
,
,
,
,
,
,
,
,

Out[]=
​
TimeConstrained[ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABB",15],3]&/@Take[ResourceFunction["EnumerateSubstitutionSystemRules"][{23},2],1]
In[]:=


Out[]=
ggg=Graph[TimeConstrained[ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABB",15],3]&@Part[ResourceFunction["EnumerateSubstitutionSystemRules"][{23},2],1],GraphLayout"LayeredDigraphEmbedding",AspectRatio1/2]
In[]:=
In[]:=
NeighborhoodGraph[ggg,1,4]
In[]:=
Out[]=
Complement[VertexOutComponent[ggg,1,4],VertexOutComponent[ggg,1,3]]
In[]:=
{8,13,14,15,16,17,60,61}
Out[]=
HighlightGraph[ggg,{8,13,14,15,16,17,60,61},VertexSize5]
In[]:=
Out[]=
HighlightGraph[ggg,Complement[VertexOutComponent[ggg,1,3],VertexOutComponent[ggg,1,2]],VertexSize5]
In[]:=
Out[]=
Part[ResourceFunction["EnumerateSubstitutionSystemRules"][{23},2],1]
In[]:=
{AAAAA}
Out[]=
HighlightGraph[ggg,Complement[VertexOutComponent[ggg,1,3],VertexOutComponent[ggg,1,2]],VertexSize5]
In[]:=
HighlightGraph[ggg,Style[Subgraph[ggg,VertexOutComponent[ggg,#]],RandomColor]&/@Complement[VertexOutComponent[ggg,1,3],VertexOutComponent[ggg,1,2]]]
In[]:=
Out[]=

The mass of a black hole is equal to the number of causal edges that go into the BH ??

GraphDiameter[UndirectedGraph[ggg]]
In[]:=
25
Out[]=
Complement[VertexOutComponent[ggg,1,4],VertexOutComponent[ggg,1,3]]
In[]:=
{8,13,14,15,16,17,60,61}
Out[]=
Length/@Table[Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]],{t,10}]
In[]:=
{2,3,5,8,13,19,29,40,589,0}
Out[]=
nth cousin for nodes?
CommunityGraphPlot[HighlightGraph[ggg,Style[Subgraph[ggg,VertexOutComponent[ggg,#]],RandomColor]&/@Complement[VertexOutComponent[ggg,1,3],VertexOutComponent[ggg,1,2]]]]
In[]:=
Out[]=
cggg=HighlightGraph[ggg,Style[Subgraph[ggg,VertexOutComponent[ggg,#]],RandomColor]&/@Complement[VertexOutComponent[ggg,1,3],VertexOutComponent[ggg,1,2]]];
In[]:=
llev=With[{t=9},Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]];
In[]:=
GraphDistanceMatrix[UndirectedGraph[cggg]]
In[]:=
{
⋯1⋯
}
large output
show less
show more
show all
set size limit...
Out[]=
MatrixPlot[%]
In[]:=
Out[]=
MatrixPlot[GraphDistanceMatrix[UndirectedGraph[cggg]][[llev,llev]]]
In[]:=
Out[]=
Histogram[Flatten[GraphDistanceMatrix[UndirectedGraph[cggg]][[llev,llev]]]]
In[]:=
Out[]=
dm=GraphDistanceMatrix[UndirectedGraph[cggg]];
In[]:=
Dendrogram[VertexList[UndirectedGraph[cggg]],DistanceFunction(dm[[#1,#2]]&)]
In[]:=
Out[]=
Dendrogram[RandomSample[VertexList[UndirectedGraph[cggg]],40],DistanceFunction(dm[[#1,#2]]&)]
In[]:=
Out[]=
Dendrogram[llev,DistanceFunction(dm[[#1,#2]]&)]
In[]:=
Out[]=
With[{t=5},Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]]
In[]:=
{12,19,20,21,22,23,24,25,26,90,91,92,139}
Out[]=
Dendrogram[%,DistanceFunction(dm[[#1,#2]]&)]
In[]:=
Out[]=
Subgraph[ggg,VertexOutComponent[ggg,1,5],VertexLabels->Automatic]
In[]:=
Out[]=
CommonAncestorDistance[g_,i_,j_]:=NestWhile[#+1&,0,!IntersectingQ[VertexInComponent[g,i,#],VertexInComponent[g,j,#]]&]
In[]:=
Dendrogram[{12,19,20,21,22,23,24,25,26,90,91,92,139},DistanceFunction(CommonAncestorDistance[ggg,#1,#2]&)]
In[]:=
Out[]=
Note: the distance function is not symmetric; [[ “removedness is not symmetric in cousin relations” ]]
Dendrogram[With[{t=6},Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]],DistanceFunction(CommonAncestorDistance[ggg,#1,#2]&)]
In[]:=
Out[]=
DistanceMatrix[VertexList[ggg],DistanceFunction(CommonAncestorDistance[ggg,#1,#2]&)];
In[]:=
Histogram[Flatten[%72]]
In[]:=
Out[]=
Position[%72,14]
In[]:=
{{1,473},{473,1}}
Out[]=
GraphDistance[ggg,1,#]&/@VertexList[ggg];
In[]:=
Max[%]
In[]:=
14
Out[]=
Histogram[%77]
In[]:=
Out[]=
Lowest layer distance matrix:
DistanceMatrix[With[{t=9},Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]],DistanceFunction(CommonAncestorDistance[ggg,#1,#2]&)];
In[]:=
Histogram[Flatten[%]]
In[]:=
Out[]=
lev9=With[{t=9},Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]];
In[]:=
Length[lev9]
In[]:=
589
Out[]=
Map[lev9[[#]]&,Position[%82,13],{2}]
In[]:=
{{62,683},{93,683},{134,473},{140,683},{202,473},{210,683},{303,473},{315,683},{455,473},{456,473},{457,473},{458,473},{459,473},{460,473},{461,473},{462,473},{463,473},{464,473},{465,473},{466,473},{467,473},{468,473},{473,134},{473,202},{473,303},{473,455},{473,456},{473,457},{473,458},{473,459},{473,460},{473,461},{473,462},{473,463},{473,464},{473,465},{473,466},{473,467},{473,468},{473,683},{473,684},{473,685},{473,686},{473,687},{473,688},{473,689},{473,690},{473,691},{473,692},{473,693},{473,694},{473,695},{473,696},{473,697},{473,698},{473,699},{473,700},{473,701},{473,702},{473,703},{473,704},{473,705},{473,706},{473,707},{683,62},{683,93},{683,140},{683,210},{683,315},{683,473},{684,473},{685,473},{686,473},{687,473},{688,473},{689,473},{690,473},{691,473},{692,473},{693,473},{694,473},{695,473},{696,473},{697,473},{698,473},{699,473},{700,473},{701,473},{702,473},{703,473},{704,473},{705,473},{706,473},{707,473}}
Out[]=
HighlightGraph[ggg,Style[#,RandomColor[]]&/@Transpose[%89],VertexSize4]
In[]:=
Out[]=

Claim: for BH horizon, the distance function is asymmetric; for cosmic horizon it’s symmetric

Intersection[%89,Reverse/@%89]
In[]:=
{{62,683},{93,683},{134,473},{140,683},{202,473},{210,683},{303,473},{315,683},{455,473},{456,473},{457,473},{458,473},{459,473},{460,473},{461,473},{462,473},{463,473},{464,473},{465,473},{466,473},{467,473},{468,473},{473,134},{473,202},{473,303},{473,455},{473,456},{473,457},{473,458},{473,459},{473,460},{473,461},{473,462},{473,463},{473,464},{473,465},{473,466},{473,467},{473,468},{473,683},{473,684},{473,685},{473,686},{473,687},{473,688},{473,689},{473,690},{473,691},{473,692},{473,693},{473,694},{473,695},{473,696},{473,697},{473,698},{473,699},{473,700},{473,701},{473,702},{473,703},{473,704},{473,705},{473,706},{473,707},{683,62},{683,93},{683,140},{683,210},{683,315},{683,473},{684,473},{685,473},{686,473},{687,473},{688,473},{689,473},{690,473},{691,473},{692,473},{693,473},{694,473},{695,473},{696,473},{697,473},{698,473},{699,473},{700,473},{701,473},{702,473},{703,473},{704,473},{705,473},{706,473},{707,473}}
Out[]=

True existence of an event horizon involves intersection of future propagation of causal edges to infinity, and will in general be undecidable.

But the existence of event horizons is basically a failure of confluence-like merging for the causal graph.

In general, there is a transition graph of what vertices can reach what other vertices.

What we are currently doing is approximating null infinity by whatever level we’ve currently reached.
lev3=With[{t=3},Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]]
In[]:=
{5,9,10,11,40}
Out[]=
AdjacencyGraph[Outer[Boole[IntersectingQ[VertexOutComponent[ggg,#1],VertexOutComponent[ggg,#2]]]&,lev3,lev3],DirectedEdgesTrue]
In[]:=
Out[]=
Table[With[{lev=Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]},AdjacencyGraph[Outer[Boole[IntersectingQ[VertexOutComponent[ggg,#1],VertexOutComponent[ggg,#2]]]&,lev,lev],DirectedEdgesTrue]],{t,6}]
In[]:=

,
,
,
,
,

Out[]=
Table[With[{lev=Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]},SimpleGraph[AdjacencyGraph[Outer[Boole[IntersectingQ[VertexOutComponent[ggg,#1],VertexOutComponent[ggg,#2]]]&,lev,lev],DirectedEdgesTrue]]],{t,6}]
In[]:=

,
,
,
,
,

Out[]=
CausalConnectionGraph[ggg_,t_]:=With[{lev=Complement[VertexOutComponent[ggg,1,t],VertexOutComponent[ggg,1,t-1]]},SimpleGraph[AdjacencyGraph[Outer[Boole[IntersectingQ[VertexOutComponent[ggg,#1],VertexOutComponent[ggg,#2]]]&,lev,lev],DirectedEdgesTrue]]]
In[]:=
Time step evolution:
Table[CausalConnectionGraph[ResourceFunction["SubstitutionSystemCausalGraph"][{"AA""AAA"},"AABB",t],3],{t,4,17}]
In[]:=

,
,
,
,
,
,
,
,
,
,
,
,
,

Out[]=
Table[CausalConnectionGraph[ResourceFunction["SubstitutionSystemCausalGraph"][{"AA""AAA"},"AABB",t],4],{t,4,17}]
In[]:=

,
,
,
,
,
,
,
,
,
,
,
,
,

Out[]=
ResourceFunction["ParallelMapMonitored"][Labeled[TimeConstrained[CausalConnectionGraph[ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABB",10],3],3],#]&,ResourceFunction["EnumerateSubstitutionSystemRules"][{23},2]]
In[]:=

{AAAAA}
,
{AAAAB}
,
{AAABA}
,
{AAABB}
,
{AABAB}
,
{AABBB}
,
{ABAAA}
,
{ABAAB}
,
{ABABA}
,
{ABBAA}

Out[]=
ResourceFunction["ParallelMapMonitored"][Labeled[TimeConstrained[CausalConnectionGraph[ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABB",10],3],12],#]&,ResourceFunction["EnumerateSubstitutionSystemRules"][{23,22},2]]
In[]:=
Out[]=

Hypergraph case

allrules32=
;
In[]:=
RandomSample[allrules32,4]
In[]:=
{{{1,2},{1,2}}{{1,1},{3,2},{2,4}},{{1,2},{1,2}}{{2,2},{2,2},{2,2}},{{1,2},{1,3}}{{2,1},{2,1},{1,3}},{{1,2},{1,3}}{{2,1},{3,1},{4,1}}}
Out[]=
ResourceFunction["WolframModel"][#,Automatic,6,"CausalGraph"]&/@%
In[]:=

,
,
,

Out[]=
srules=RandomSample[allrules32,20];
In[]:=
ResourceFunction["ParallelMapMonitored"][ResourceFunction["WolframModel"][#,Automatic,10,"CausalGraph",TimeConstraint10]&,srules]
In[]:=

,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,

Out[]=
pmm=ResourceFunction["ParallelMapMonitored"];
In[]:=
pmm[{#,CausalConnectionGraph[#,3]}&,%117]
In[]:=

,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,

Out[]=
srules[[8]]
In[]:=
{{1,2},{2,3}}{{3,4},{3,4},{4,1}}
Out[]=
ResourceFunction["WolframModel"][{{1,2},{2,3}}{{3,4},{3,4},{4,1}},Automatic,20,"CausalGraph",TimeConstraint10]
In[]:=
Out[]=
LayeredGraphPlot[%,AspectRatio1/2]
In[]:=
Out[]=
Table[CausalConnectionGraph[%122,u],{u,12}]
In[]:=

,
,
,
,
,
,
,
,
,
,
,

Out[]=
bhc=Graph[Join[Table[ii+1,{i,10}],Table[ii+1,{i,20,30}],Table[ii+20,{i,10}]]]
In[]:=
Out[]=
Table[CausalConnectionGraph[bhc,u],{u,5}]
In[]:=

,