You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
In[]:=
StringOverlaps[strings_List]:=ResourceFunction["StringOverlaps"][{First[strings],First[strings]}]/;Length[strings]1
In[]:=
StringOverlaps[strings_List]:=ResourceFunction["StringOverlaps"][strings]/;Length[strings]2
In[]:=
StringOverlaps[strings_List]:=DeleteDuplicates[Catenate[ResourceFunction["StringOverlaps"][#]&/@Tuples[strings,2]]]/;Length[strings]>2
In[]:=
findCanonicalCriticalPairs[rules_List]:=Module[{leftHandSides,overlaps,criticalPairs},leftHandSides=First[#]&/@rules;overlaps=StringOverlaps[leftHandSides];criticalPairs=Union[Sort[#]&/@Catenate[(Tuples[StringReplaceList[#,rules],2]&/@overlaps)]];criticalPairs]
In[]:=
criticalPairConvergesQ[rules_List,criticalPair_List,stepCount_Integer]:=Module[{undirectedStatesGraph},undirectedStatesGraph=UndirectedGraph[MultiwaySystem[rules,criticalPair,stepCount,"StatesGraph"]];ConnectedGraphQ[Graph[Union[VertexList[undirectedStatesGraph],criticalPair],EdgeList[undirectedStatesGraph]]]]
In[]:=
TotalCausalInvariantQ[rules_List,stepCount_Integer]:=Module[{canonicalCriticalPairs},canonicalCriticalPairs=findCanonicalCriticalPairs[rules];AllTrue[canonicalCriticalPairs,criticalPairConvergesQ[rules,#,stepCount]&]]
In[]:=
TotalCausalInvariantQ[{"AB""AA","BA""A"},6]
Out[]=
False
In[]:=
TotalCausalInvariantQ[{"A""AA","A""A"},5]
Out[]=
True
In[]:=
TotalCausalInvariantQ[{"A""AB","B""A"},5]
Out[]=
True
In[]:=
TotalCausalInvariantQ[{"A""AB","B""A"},7]
Out[]=
True
In[]:=
TotalCausalInvariantQ[{"A""AA","A""B"},5]
Out[]=
False
In[]:=
findCanonicalCriticalPairs[{"A""AA","A""B"}]
Out[]=
{{AA,AA},{AA,B},{B,B}}
In[]:=
criticalPairConvergesQ[{"A""AA","A""B"},#,3]&/@%
Out[]=
{True,False,True}
In[]:=
MultiwaySystem[{"A""AA","A""B"},"A",5,"CriticalPairsList"]
Out[]=
In[]:=
Map[Length,%,{2}]
Out[]=
{Resolved0,Unresolved1,Resolved0,Unresolved4,Resolved3,Unresolved9,Resolved9,Unresolved24,Resolved28,Unresolved53}
In[]:=
MultiwaySystem[{"A""AB","B""A"},"A",5,"CriticalPairsList"]
Out[]=
In[]:=
Map[Length,%,{2}]
Out[]=
{Resolved0,Unresolved0,Resolved0,Unresolved1,Resolved1,Unresolved3,Resolved4,Unresolved9,Resolved13,Unresolved23}
In[]:=
#Unresolved/#Resolved&/@Map[Length,#,{2}]&[MultiwaySystem[{"A""AB","B""A"},"A",7,"CriticalPairsList"]]
1
0
1
0
Out[]=
Indeterminate,ComplexInfinity,3,,,,
9
4
23
13
55
36
124
91
In[]:=
N[%]
Out[]=
{Indeterminate,ComplexInfinity,3.,2.25,1.76923,1.52778,1.36264}
In[]:=
#Unresolved/#Resolved&/@Map[Length,#,{2}]&[MultiwaySystem[{"A""AA","A""B"},"A",7,"CriticalPairsList"]]//N
1
0
1
0
Out[]=
{ComplexInfinity,ComplexInfinity,3.,2.66667,1.89286,1.58904,1.36994}
In[]:=
Map[Length,#,{2}]&[MultiwaySystem[{"A""AA","A""B"},"A",6,"CriticalPairsList"]]
Out[]=
{Resolved0,Unresolved1,Resolved0,Unresolved4,Resolved3,Unresolved9,Resolved9,Unresolved24,Resolved28,Unresolved53,Resolved73,Unresolved116}
In[]:=
Map[Length,#,{2}]&[MultiwaySystem[{"A""AB","B""A"},"A",6,"CriticalPairsList"]]
Out[]=
{Resolved0,Unresolved0,Resolved0,Unresolved1,Resolved1,Unresolved3,Resolved4,Unresolved9,Resolved13,Unresolved23,Resolved36,Unresolved55}
In[]:=
MultiwaySystem[{"AB""AA","AB""BA"},"ABAB",4,"CriticalPairsList"]
Out[]=
In[]:=
MultiwaySystem[{"AB""AA","BA""AB"},"ABA",5,"CriticalPairsList"]
Out[]=
{Resolved{},Unresolved{{AAA,AAB}},Resolved{{AAA,AAB}},Unresolved{},Resolved{{AAA,AAB}},Unresolved{},Resolved{{AAA,AAB}},Unresolved{},Resolved{{AAA,AAB}},Unresolved{}}
In[]:=
MultiwaySystem[{"A""BB","B""A"},"A",5,"CriticalPairsList"]
Out[]=
In[]:=
TotalCausalInvariantQ[{"A""AB","AA""B"},4]
Out[]=
False