GetRules[{n1_,k1_}{n2_,k2_}]:=Import[StringJoin["/Users/sw/Dropbox/Physics/Data/RuleEnumerations/",ToString[n1],ToString[k1],"-",ToString[n2],ToString[k2],"c.wxf"]]
In[]:=
ci23=Pick[GetRules[{2,2}{3,2}],ParallelMapMonitored[TotalCausalInvariantQ[{#},2]&,GetRules[{2,2}{3,2}]]];
In[]:=
Length[ci23]
In[]:=
2791
Out[]=
Take[ci23,4]
In[]:=
Out[]=
First[%]
In[]:=
{{1,1},{1,1}}{{1,1},{1,1},{1,1}}
Out[]=
MakeImageCollection[ci23,{{0,0},{0,0}}];
In[]:=
Take[%176,10]
In[]:=
Out[]=
ParallelMapMonitored[WolframModelTest[#,{{0,0},{0,0}}]&,ci23];
In[]:=
First[%]
In[]:=
Out[]=
PicturesFromRules[ci23,{{0,0},{0,0}}]
In[]:=
One rule, one hyperedge
One rule, one hyperedge
ParallelMapMonitored[TotalCausalInvariantQ[{#},1]&,GetRules[{1,2}{2,2}]]
In[]:=
{True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True}
Out[]=
ParallelMapMonitored[TotalCausalInvariantQ[{#},2]&,GetRules[{1,2}{2,2}]]
In[]:=
{True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True}
Out[]=
ParallelMapMonitored[TotalCausalInvariantQ[{#},1]&,GetRules[{1,3}{2,3}]]
In[]:=
Out[]=
Two hyperedges
Two hyperedges
cx[{2,2}{2,3}]=ParallelMapMonitored[TotalCausalInvariantQ[{#},1]&,GetRules[{2,2}{3,2}]];
In[]:=
Counts[cx[{2,2}{2,3}]]
In[]:=
True2669,False2033
Out[]=
cxwm[sig_,t_:1]:=cxcache[sig,t]=ParallelMapMonitored[TotalCausalInvariantQ[{#},t]&,GetRules[sig]]
In[]:=
cxwm[{2,2}{3,2},2]//Counts
In[]:=
True2791,False1911
Out[]=
cxwm[{2,2}{3,2},3]//Counts
In[]:=
True2817,False1885
Out[]=
“Interesting rules”
“Interesting rules”
allint=NotebookImport["/Users/sw/Dropbox/Physics/UniverseRegistry/CanonicalInterestingRules.nb","Input""Expression"];
In[]:=
allrules=First/@allint;
In[]:=
allrules=If[Head[#]===Rule,{#},#]&/@allrules;
In[]:=
ParallelMapMonitored[TotalCausalInvariantQ[#,1]&,Take[allrules,20]]
In[]:=
{True,True,True,True,True,True,True,False,False,True,True,True,True,True,True,True,True,True,True,True}
Out[]=
FinalPicture/@Take[allrules,20]
In[]:=
Out[]=
ParallelMapMonitored[WolframModelTest[#,Automatic]&,Take[allrules,20]];
In[]:=
MakePictures[%]
In[]:=
HypergraphPlot::invalidEdges:First argument of HypergraphPlot must be list of lists, where elements represent vertices.
(kernel 56)
FinalPicture@@@{{{{{1,2,3}}{{4,3,4},{4,1,3},{4,2,3}}},{{0,0,0}},4},{{{{1,2,3}}{{3,4,5},{4,2,5},{1,5,2}}},{{0,0,0}},5}}
In[]:=
Out[]=
WolframModel[#1,#2,#3,"CausalGraph"]&@@@{{{{{1,2,3}}{{4,3,4},{4,1,3},{4,2,3}}},{{0,0,0}},4},{{{{1,2,3}}{{3,4,5},{4,2,5},{1,5,2}}},{{0,0,0}},5}}
In[]:=
Out[]=
ParallelMapMonitored[WolframModelTest[#,Automatic]&,RandomSample[allrules,40]]
In[]:=
Out[]=
rs1=RandomSample[allrules,40];
In[]:=
ParallelMapMonitored[TotalCausalInvariantQ[#,1]&,rs1]
In[]:=
$Aborted
Out[]=
rs1
In[]:=
Out[]=
ParallelMapMonitored[Echo[TimeConstrained[TotalCausalInvariantQ[#,1],30]]&,rs1]
In[]:=
>> True
(kernel 61)
>> True
(kernel 56)
>> True
(kernel 51)
>> True
(kernel 50)
>> True
(kernel 48)
>> False
(kernel 45)
>> False
(kernel 43)
>> True
(kernel 42)
>> True
(kernel 41)
>> True
(kernel 40)
>> True
(kernel 39)
>> True
(kernel 38)
>> False
(kernel 36)
>> True
(kernel 35)
>> True
(kernel 34)
>> True
(kernel 33)
>> False
(kernel 32)
>> False
(kernel 31)
>> True
(kernel 30)
>> True
(kernel 29)
>> True
(kernel 28)
>> True
(kernel 27)
>> False
(kernel 26)
>> True
(kernel 25)
>> False
(kernel 64)
>> False
(kernel 63)
>> False
(kernel 62)
>> False
(kernel 60)
>> False
(kernel 59)
>> False
(kernel 58)
>> False
(kernel 57)
>> True
(kernel 55)
>> False
(kernel 54)
>> False
(kernel 53)
>> False
(kernel 52)
>> True
(kernel 49)
>> True
(kernel 46)
>> True
(kernel 37)
>> True
(kernel 47)
>> $Aborted
(kernel 44)
{False,False,False,True,False,False,False,False,True,True,False,False,False,True,True,True,True,True,True,False,$Aborted,False,True,True,True,True,True,True,False,True,True,True,False,False,True,True,True,True,False,True}
Out[]=
Position[%,$Aborted]
In[]:=
{{21}}
Out[]=
rs1[[21]]
In[]:=
{{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,11},{11,7},{8,10},{10,8},{9,13},{13,9},{12,14},{14,12}}}
Out[]=
Pick[rs1,%214]
In[]:=
Out[]=
MakePictures[ParallelMapMonitored[WolframModelTest[#,Automatic]&,%217]]
In[]:=
Out[]=
ParallelMapMonitored[WolframModel[##,"CausalGraph"]&@@#&,{{{{{1,2},{1,3}}{{1,2},{1,4},{2,4},{4,3}}},{{0,0},{0,0}},10},{{{{1,2},{1,3}}{{4,1},{1,2},{2,4},{4,3}}},{{0,0},{0,0}},7},{{{{1,2},{3,2}}{{4,5},{4,1},{5,1},{4,2},{5,2},{5,3}}},{{0,0},{0,0}},5},{{{{1,2,3},{2,4}}{{5,6,4},{4,1,6},{2,1},{3,6}}},{{0,0,0},{0,0}},25},{{{{1,2},{3,2}}{{4,1},{4,2},{1,2},{3,4}}},{{0,0},{0,0}},10},{{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}},{{0,0},{0,0}},8}}]
In[]:=
Out[]=
ParallelMapMonitored[WolframModel[##,"CausalGraph"]&@@#&,{{{{{1,2},{1,3}}{{1,2},{1,4},{2,4},{4,3}}},{{0,0},{0,0}},10},{{{{1,2},{1,3}}{{4,1},{1,2},{2,4},{4,3}}},{{0,0},{0,0}},7},{{{{1,2},{3,2}}{{4,5},{4,1},{5,1},{4,2},{5,2},{5,3}}},{{0,0},{0,0}},5},{{{{1,2,3},{2,4}}{{5,6,4},{4,1,6},{2,1},{3,6}}},{{0,0,0},{0,0}},25},{{{{1,2},{3,2}}{{4,1},{4,2},{1,2},{3,4}}},{{0,0},{0,0}},10},{{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}},{{0,0},{0,0}},8}}]
Graph[Rule@@@WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}},{{0,0},{0,0}},12,"FinalState"]]
In[]:=
Out[]=
WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}},{{0,0},{0,0}},12,"CausalGraph"]
In[]:=
Out[]=
cg223=%223;
In[]:=
LayeredGraphPlot[%]
In[]:=
Out[]=
HypergraphDimensionEstimateList[WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}},{{0,0},{0,0}},10,"FinalState"]]
In[]:=
{2.302±0.018,2.63±0.04,2.75±0.05,2.93±0.07,3.02±0.09,3.01±0.10,2.90±0.10,2.62±0.10,2.24±0.09,1.71±0.07,1.03±0.05}
Out[]=
HypergraphDimensionEstimateList[WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}},{{0,0},{0,0}},12,"FinalState"]]
In[]:=
{2.309±0.010,2.629±0.022,2.753±0.029,2.95±0.04,3.05±0.05,3.15±0.06,3.23±0.06,3.28±0.07,3.26±0.08,3.17±0.08,3.00±0.08,2.76±0.07,2.43±0.07,1.97±0.05,1.39±0.04}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
sss14=WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}},{{0,0},{0,0}},14,"FinalState"];
In[]:=
HypergraphDimensionEstimateList[sss14]
In[]:=
{2.308±0.005,2.632±0.012,2.747±0.016,2.926±0.021,3.007±0.026,3.098±0.032,3.18±0.04,3.25±0.04,3.30±0.05,3.34±0.05,3.39±0.06,3.43±0.06,3.43±0.06,3.40±0.06,3.33±0.07,3.21±0.07,3.03±0.06,2.80±0.06,2.49±0.05,2.11±0.04,1.67±0.04}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
GraphPlot[Rule@@@sss14]
In[]:=
Out[]=
GraphPlot3D[Rule@@@sss14]
In[]:=
Out[]=
RulePlot[WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}]]
In[]:=
Out[]=
WolframModel[{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}},{{0,0},{0,0}},16]
In[]:=
Out[]=
HypergraphDimensionEstimateList[%%["FinalState"]]
In[]:=
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
MatrixPlot[AdjacencyMatrix[Graph[Rule@@@sss14]]]
In[]:=
Out[]=
CanonicalCriticalPairs[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}}]
In[]:=
{}
Out[]=
CanonicalCriticalPairs[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}},"IncludeSelfPairs"True]
In[]:=
Out[]=
MultiwaySystem[WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}}],{{0,0},{0,0}},1,"StatesGraph"]
In[]:=
Out[]=
MultiwaySystem[WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}}],{{0,0},{0,0}},2,"StatesGraph"]
In[]:=
Out[]=
MultiwaySystem[WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}}],{{0,0},{0,0}},4,"StatesGraph"]
In[]:=
Out[]=
MultiwaySystem[WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}}],{{0,0},{0,0}},5,"StatesGraph"]
In[]:=
Out[]=
GraphNeighborhoodVolumes[Graph[{12,23}]]
In[]:=
1{1,2,3},2{1,2},3{1}
Out[]=
GraphNeighborhoodVolumes[cg223]
In[]:=
Out[]=
Take[%345,100]
In[]:=
Out[]=
Take[%345,6]
In[]:=
1{1,3,7,16,35,76,164,349,760,1497,1924,1963},2{1,4,11,27,65,149,326,717,1453,1918,1958},3{1,4,12,31,72,160,345,756,1493,1920,1959},4{1,4,12,34,88,205,471,1035,1614,1771},5{1,4,13,36,94,226,534,1164,1715,1794},6{1,4,13,36,96,237,565,1195,1668,1724}
Out[]=
MeanAround/@Transpose[N[First[Values[%]]]]
In[]:=
Transpose[566.±225.]
Out[]=
ResourceFunction["LogDifferences"][{1,3,7,16,35,76,164,349,760,1497,1924,1963}]//N
In[]:=
{1.58496,2.08969,2.87358,3.50787,4.25284,4.98949,5.65564,6.60746,6.4341,2.63291,0.230631}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
Length/@WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}},{{0,0},{0,0}},12,"StatesList"]
In[]:=
{2,4,8,16,30,54,98,180,332,618,1142,2104,3928}
Out[]=
Length/@WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}},{{0,0},{0,0}},14,"StatesList"]
In[]:=
{2,4,8,16,30,54,98,180,332,618,1142,2104,3928,7304,13608}
Out[]=
Ratios[%]//N
In[]:=
{2.,2.,2.,1.875,1.8,1.81481,1.83673,1.84444,1.86145,1.8479,1.84238,1.86692,1.85947,1.86309}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
WolframModel[{{{1,2},{1,3}}{{2,3},{2,4},{3,4},{1,4}}},{{0,0},{0,0}},18]
In[]:=
Out[]=
Length/@%["StatesList"]
In[]:=
{2,4,8,16,30,54,98,180,332,618,1142,2104,3928,7304,13608,25308,47044,87518,162862}
Out[]=
Ratios[%]//N
In[]:=
{2.,2.,2.,1.875,1.8,1.81481,1.83673,1.84444,1.86145,1.8479,1.84238,1.86692,1.85947,1.86309,1.85979,1.85886,1.86034,1.8609}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
fs=Graph[Rule@@@%356["FinalState"]];
In[]:=
GraphDiameter[fs]
In[]:=
$Aborted
Out[]=
VertexCount[fs]
In[]:=
81431
Out[]=
GraphRadius[fs]
In[]:=
$Aborted
Out[]=
GraphDiameter[UndirectedGraph[fs]]
In[]:=
64
Out[]=