Find the list of unreachable events from a given event
Find the list of unreachable events from a given event
(i.e. events not in the future light cone of a given event)
getCausallyDisconnectedRegions[{"AB""BAAB","A""BA"},"AB",4]
In[]:=
Out[]=
HighlightGraph[ResourceFunction["SubstitutionSystemCausalGraph"][{"AB""BAAB","A""BA"},"AB",4],{26,27,28,29,38,39,40,41,42,43,44,45}]
In[]:=
Out[]=
An event A is causally disconnected from B if the future light cones of A and B do not intersect
An event A is causally disconnected from B if the future light cones of A and B do not intersect
“A is causally connected to B” means there is a path from A to B in the causal graph
ImageReflect
,TopBottom
In[]:=
Out[]=
Black hole test: does every “final event” lie in the future light cone of all events
Black hole test: does every “final event” lie in the future light cone of all events
getCausallyDisconnectedRegions[{"AB""BAAB","A""BA"},"AB",4]
In[]:=
Out[]=
getCausallyDisconnectedRegions[{"AB""BAB","A""BA"},"AB",4]
In[]:=
{}
Out[]=
If there no black holes in evidence, there would be no unreachable elements, i.e. this list of disconnected regions would be empty
{ node list of final nodes unreachable from this node , ... }
Currently looking at nodes at step t, and at what nodes at step 2 t are unreachable.
Code
Code
Black hole finding
Black hole finding
getCausallyDisconnectedRegions[{"AB""BAAB","A""BA"},"AB",1,4]
In[]:=
{2{26,27,28,29,38,39,40,41,42,43,44,45}}
Out[]=
getCausallyDisconnectedRegions[{"AB""BAAB","A""BA"},"AB",1,4]
In[]:=
{2{26,27,28,29,38,39,40,41,42,43,44,45}}
Out[]=
Graph[ResourceFunction["SubstitutionSystemCausalGraph"][{"AB""BAAB","A""BA"},"AB",4],VertexLabelsAutomatic]
In[]:=
Out[]=
getCausallyDisconnectedRegions[{"AB""BAAB","A""BA"},"AB",2,5]
In[]:=
Out[]=
First/@%
In[]:=
{2,4,5,6,7,8,9}
Out[]=
The LHS events are ones whose future light cones are not “complete”
What is the “causal connection graph” of nodes 2, 4, 5, 6, 8?
Case 1: “final null set” of A and B are identical
Case 2: “final null set” of A contains final null set of B
Case 3: intersect (A X and B X)
Case 4: disjoint
Clear[IntersectionRule]
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;!IntersectingQ[list1,list2]:={}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;(SubsetQ[list1,list2]&&!SubsetQ[list2,list1]):={DirectedEdge[s1,s2]}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;(SubsetQ[list2,list1]&&!SubsetQ[list1,list2]):={DirectedEdge[s2,s1]}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;Sort[list1]===Sort[list2]:={DirectedEdge[s1,s2],DirectedEdge[s2,s1]}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;(IntersectingQ[list1,list2]&&!SubsetQ[list1,list2]&&!SubsetQ[list2,list1]):={UndirectedEdge[s1,s2]}
In[]:=
getCausallyConnectedRegions[{"AB""BAAB","A""BA"},"AB",2,5]
In[]:=
Out[]=
CausalConnectionGraph[rule_,init_,ti_,tf_]:=With[{u=getCausallyConnectedRegions[rule,init,ti,tf]},SimpleGraph[Flatten[Outer[IntersectionRule,u,u,1]]]]
In[]:=
CausalConnectionGraphAt[rule_,init_,ti_,tf_]:=With[{u=getCausallyConnectedRegionsAt[rule,init,ti,tf]},SimpleGraph[Flatten[Outer[IntersectionRule,u,u,1]]]]
In[]:=
CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",2,5]
In[]:=
Out[]=
CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",2,6]
In[]:=
Out[]=
CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,6]
In[]:=
Out[]=
CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,7]
In[]:=
Out[]=
Graph3D[%]
In[]:=
Out[]=
Graph[CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,7],VertexLabelsAutomatic]
In[]:=
Out[]=
CausalConnectionSummary[rule_,init_,ti_,tf_]:=With[{g=CausalConnectionGraph[rule,init,ti,tf]},Fold[VertexContract[#1,#2]&,g,ConnectedComponents[g]]]
In[]:=
CausalConnectionSummaryAt[rule_,init_,ti_,tf_]:=With[{g=CausalConnectionGraphAt[rule,init,ti,tf]},Fold[VertexContract[#1,#2]&,g,ConnectedComponents[g]]]
In[]:=
ConnectedComponents[CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,7]]
In[]:=
{{14},{6,10,15},{16},{11,17},{2,4,7},{18},{8,12,19},{20},{13,21},{5,9},{1,3}}
Out[]=
Fold[VertexContract[#1,#2]&,CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,7],ConnectedComponents[CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,7]]]
In[]:=
Out[]=
CausalConnectionSummary[{"AB""BAAB","A""BA"},"AB",2,7]
In[]:=
Out[]=
CausalConnectionSummary[{"AB""BAAB","A""BA"},"AB",3,7]
In[]:=
Out[]=
CausalConnectionSummary[{"AB""BAAB","A""BA"},"AB",4,7]
In[]:=
Out[]=
CausalConnectionSummary[{"AB""BAAB","A""BA"},"AB",4,8]
In[]:=
Out[]=
CausalConnectionSummaryAt[{"AB""BAAB","A""BA"},"AB",4,8]
In[]:=
Out[]=
All rules
All rules
ResourceFunction["ParallelMapMonitored"][TimeConstrained[{ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABA",5],CausalConnectionSummary[#,"AABA",3,7]},5]&,ResourceFunction["EnumerateSubstitutionSystemRules"][{23,22},2]]
In[]:=
Out[]=
ResourceFunction["ParallelMapMonitored"][TimeConstrained[{With[{g=ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABA",5]},HighlightGraph[g,Complement[VertexOutComponent[g,1,3],VertexOutComponent[g,1,2]],VertexLabelsAutomatic]],Graph[CausalConnectionSummary[#,"AABA",3,7],VertexLabelsAutomatic]},5]&,Take[ResourceFunction["EnumerateSubstitutionSystemRules"][{23,22},2],10]]
In[]:=
Out[]=
With[{g=ResourceFunction["SubstitutionSystemCausalGraph"][{"AB""BAAB","A""BA"},"AB",5]},HighlightGraph[g,Complement[VertexOutComponent[g,1,3],VertexOutComponent[g,1,2]],VertexLabelsAutomatic]]
In[]:=
Out[]=
Graph[CausalConnectionGraph[{"AB""BAAB","A""BA"},"AB",3,7],VertexLabelsAutomatic]
In[]:=
Out[]=
Graph[CausalConnectionSummary[{"AB""BAAB","A""BA"},"AB",3,7],VertexLabelsAutomatic]
In[]:=
Out[]=
With[{g=ResourceFunction["SubstitutionSystemCausalGraph"][{"AB""BAAB","A""BA"},"AB",5]},Complement[VertexOutComponent[g,1,3],VertexOutComponent[g,1,2]]]
In[]:=
{6,7,11,12,20,21,29}
Out[]=
Subgraph[%64,%]
In[]:=
Out[]=
ResourceFunction["ParallelMapMonitored"][TimeConstrained[With[{g=ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABA",7],gs=CausalConnectionSummaryAt[#,"AABA",4,7]},{HighlightGraph[g,First/@gs,VertexLabelsAutomatic,GraphLayout"LayeredDigraphEmbedding",AspectRatio1/2],Graph[gs,VertexLabelsAutomatic]}],5]&,Take[ResourceFunction["EnumerateSubstitutionSystemRules"][{23,22},2],10]]
In[]:=
Out[]=
ResourceFunction["ParallelMapMonitored"][TimeConstrained[With[{g=ResourceFunction["SubstitutionSystemCausalGraph"][#,"AABA",7],gs=CausalConnectionSummaryAt[#,"AABA",4,7]},{HighlightGraph[g,First/@gs,VertexLabelsAutomatic,GraphLayout"LayeredDigraphEmbedding",AspectRatio1/2],Graph[gs,VertexLabelsAutomatic]}],5]&,ResourceFunction["EnumerateSubstitutionSystemRules"][{23,22},2]]
In[]:=
Out[]=
Failure of global hyperbolicity:
Failure of global hyperbolicity:
,
WolframModel case
WolframModel case
IntersectionRule[s1_->list1_,s2_->list2_]/;!IntersectingQ[list1,list2]:={}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;(SubsetQ[list1,list2]&&!SubsetQ[list2,list1]):={DirectedEdge[s1,s2]}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;(SubsetQ[list2,list1]&&!SubsetQ[list1,list2]):={DirectedEdge[s2,s1]}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;Sort[list1]===Sort[list2]:={DirectedEdge[s1,s2],DirectedEdge[s2,s1]}
In[]:=
IntersectionRule[s1_->list1_,s2_->list2_]/;(IntersectingQ[list1,list2]&&!SubsetQ[list1,list2]&&!SubsetQ[list2,list1]):={UndirectedEdge[s1,s2]}
In[]:=
getWolframModelCausallyConnectedRegionsAt[rules_,initialCondition_,initialTime_Integer,finalTime_Integer]:=Module[{newEventsInitialCausalGraph,newEventsFinalCausalGraph,causalGraph,initialEventsList,previousEventsList,newEventsList},newEventsInitialCausalGraph=ResourceFunction["WolframModel"][rules,initialCondition,finalTime-1,"CausalGraph"];newEventsFinalCausalGraph=ResourceFunction["WolframModel"][rules,initialCondition,finalTime,"CausalGraph"];initialEventsList=VertexList[ResourceFunction["WolframModel"][rules,initialCondition,initialTime,"CausalGraph"]];previousEventsList=VertexList[ResourceFunction["WolframModel"][rules,initialCondition,initialTime-1,"CausalGraph"]];newEventsList=Complement[VertexList[newEventsFinalCausalGraph],VertexList[newEventsInitialCausalGraph]];#->Intersection[newEventsList,VertexOutComponent[newEventsFinalCausalGraph,#]]&/@Complement[initialEventsList,previousEventsList]]
In[]:=
WMCausalConnectionGraphAt[rule_,init_,ti_,tf_]:=With[{u=getWolframModelCausallyConnectedRegionsAt[rule,init,ti,tf]},SimpleGraph[Flatten[Outer[IntersectionRule,u,u,1]]]]
In[]:=
WMCausalConnectionSummaryAt[rule_,init_,ti_,tf_]:=With[{g=WMCausalConnectionGraphAt[rule,init,ti,tf]},Fold[VertexContract[#1,#2]&,g,ConnectedComponents[g]]]
In[]:=
allrules32=;
In[]:=
RandomSample[allrules32,6]
In[]:=
Out[]=
ResourceFunction["ParallelMapMonitored"][TimeConstrained[With[{g=ResourceFunction["WolframModel"][#,Automatic,7,"LayeredCausalGraph"],gs=WMCausalConnectionSummaryAt[#,Automatic,4,7]},{HighlightGraph[g,First/@gs,VertexLabelsAutomatic,AspectRatio1/2],Graph[gs,VertexLabelsAutomatic]}],5]&,%87]
In[]:=
Out[]=
ResourceFunction["ParallelMapMonitored"][TimeConstrained[With[{g=ResourceFunction["WolframModel"][#,Automatic,7,"LayeredCausalGraph"],gs=WMCausalConnectionSummaryAt[#,Automatic,4,7]},{HighlightGraph[g,First/@gs,VertexLabelsAutomatic,AspectRatio1/2],Graph[gs,VertexLabelsAutomatic]}],5]&,allrules32]
In[]:=
Out[]=
Counts[ResourceFunction["ParallelMapMonitored"][Framed[TimeConstrained[With[{g=ResourceFunction["WolframModel"][#,Automatic,7,"LayeredCausalGraph"],gs=WMCausalConnectionSummaryAt[#,Automatic,4,7]},IndexGraph[gs]],5]]&,allrules32]]
In[]:=
Out[]=
Counts[ResourceFunction["ParallelMapMonitored"][Framed[TimeConstrained[With[{gs=WMCausalConnectionSummaryAt[#,Automatic,5,10]},IndexGraph[gs]],5]]&,allrules32]]
In[]:=
Out[]=
Counts[ResourceFunction["ParallelMapMonitored"][Framed[TimeConstrained[With[{gs=WMCausalConnectionSummaryAt[#,Automatic,5,10]},IndexGraph[gs]],5]]&,allrules32]]
In[]:=
Out[]=
ResourceFunction["ParallelMapMonitored"][TimeConstrained[With[{gs=WMCausalConnectionSummaryAt[#,Automatic,5,10]},{#,Framed[IndexGraph[gs]]}],5]&,allrules32];
In[]:=
ResourceFunction["InteractiveListSelector"][Last[#]->Take[#,UpTo[3]]&/@GatherBy[%,Last]]
In[]:=
Out[]=
ResourceFunction["WolframModel"][{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,10,"LayeredCausalGraph"]
In[]:=
Out[]=
ResourceFunction["WolframModel"][{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,15,"LayeredCausalGraph"]
In[]:=
Out[]=
ResourceFunction["WolframModel"][{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,15,"StatesPlotsList"]
In[]:=
Out[]=
ResourceFunction["WolframModel"][{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,25,"LayeredCausalGraph"]
In[]:=
Out[]=
WMCausalConnectionSummaryAt[{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,7,20]
In[]:=
Out[]=
Table[WMCausalConnectionSummaryAt[{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,t,20],{t,10}]
In[]:=
Out[]=
Graph[Rule@@@ResourceFunction["WolframModel"][{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,15,"FinalState"]]
In[]:=
Out[]=
Graph3D[%]
In[]:=
Out[]=
ResourceFunction["WolframModel"][{{1,2},{3,2}}{{4,1},{4,3},{1,2}},Automatic,10,"EventsStatesPlotsList"]
In[]:=
Out[]=