In[]:=
findCausalSequence[rules_,allinit_,init_,t_,final_]:=With[{path=FindShortestPath[MultiwayTuringMachine[rules,allinit,t,"StatesGraphStructure"],ToString[init],final]},IndexGraph[SimpleGraph[Subgraph[MultiwayTuringMachine[rules,allinit,t,"CausalGraphStructure"],Catenate[FindShortestPath[MultiwayTuringMachine[rules,allinit,t,"EvolutionCausalGraphStructure"],path[[#]],path[[#+1]]]&/@(Range[Length[path]-1])]]]]]
In[]:=
findBranchPairs[gr_Graph]:=Module[{events=VertexList[gr][[Position[VertexOutDegree[gr],_?(#≥2&)][[All,1]]]]},​​Sort/@DeleteDuplicates[Subsets[Rest[VertexOutComponent[gr,{#},1]],{2}]&/@events]​​]
In[]:=
MTMCausalInvariantQ[rules_,init_,t_]/;t>0:=Module[{branchPairsList,newBranchPairsList,combinedBranchPairsList,gr,grinit,terminalEvents,pairs},​​gr=CausalMultiwayTuringMachine[rules,init,t,"StatesGraphStructure"];​​grinit=CausalMultiwayTuringMachine[rules,init,t-1,"StatesGraphStructure"];​​branchPairsList=findBranchPairs[grinit];​​newBranchPairsList=Complement[findBranchPairs[gr],findBranchPairs[grinit]];​​combinedBranchPairsList=Union[branchPairsList,newBranchPairsList];​​terminalEvents=VertexList[gr][[Position[VertexOutDegree[gr],0][[All,1]]]];​​With[{terminalEvent=#},​​(branchPairsList=Select[branchPairsList,!SubsetQ[VertexOutComponent[ReverseGraph[gr],terminalEvent],#]&])]&/@terminalEvents;​​pairs=<|"Resolved"​​Complement[combinedBranchPairsList,Union[branchPairsList,newBranchPairsList]],"Unresolved"Union[branchPairsList,newBranchPairsList]|>;​​pairs=Reverse[Flatten/@pairs["Unresolved"]];​​If[Length[pairs]===0,True,​​If[Counts[VertexOutDegree[gr]][0]>1,False,Module[{val=True},Catch[Do[val=Length[Intersection[VertexOutComponent[gr,Last[pairs[[n]]]],VertexOutComponent[gr,First[pairs[[n]]]]]]>0;​​If[valFalse,Throw[val]],​​{n,Length[pairs]}];Throw[val]]]]]]
In[]:=
MTMConfluentQ[rules_,init_,t_]/;t>0:=Module[{branchPairsList,newBranchPairsList,combinedBranchPairsList,gr,grinit,terminalEvents,pairs},​​gr=MultiwayTuringMachine[rules,init,t,"StatesGraphStructure"];​​grinit=MultiwayTuringMachine[rules,init,t-1,"StatesGraphStructure"];​​branchPairsList=findBranchPairs[grinit];​​newBranchPairsList=Complement[findBranchPairs[gr],findBranchPairs[grinit]];​​combinedBranchPairsList=Union[branchPairsList,newBranchPairsList];​​terminalEvents=VertexList[gr][[Position[VertexOutDegree[gr],0][[All,1]]]];​​With[{terminalEvent=#},​​(branchPairsList=Select[branchPairsList,!SubsetQ[VertexOutComponent[ReverseGraph[gr],terminalEvent],#]&])]&/@terminalEvents;​​pairs=<|"Resolved"​​Complement[combinedBranchPairsList,Union[branchPairsList,newBranchPairsList]],"Unresolved"Union[branchPairsList,newBranchPairsList]|>;​​pairs=Reverse[Flatten/@pairs["Unresolved"]];​​If[Length[pairs]===0,True,​​If[Counts[VertexOutDegree[gr]][0]>1,False,Module[{val=True},Catch[Do[val=Length[Intersection[VertexOutComponent[gr,Last[pairs[[n]]]],VertexOutComponent[gr,First[pairs[[n]]]]]]>0;​​If[valFalse,Throw[val]],​​{n,Length[pairs]}];Throw[val]]]]]]
In[]:=
CausalMultiwayTuringMachine[rules_List,initialConditions_List,stepCount_Integer,rest___]:=Module[{prop,rulespecs,opts,original,init,steps,merging},​​{rulespecs,prop}=With[{restlist=DeleteCases[List@rest,_Rule]},​​Switch[Length[restlist],​​0,{calculateRuleSpecs[First[rules]],"AllStatesList"},​​1,Switch[Head[restlist[[1]]],List,{restlist[[1]],"AllStatesList"},String,{calculateRuleSpecs[First[rules]],restlist[[1]]}],​​2,restlist]];​​opts=Select[List@rest,Head[#]===Rule&];​​original=MultiwayTuringMachine[rules,initialConditions,stepCount,"StatesGraphStructure"];​​init=If[Length[initialConditions]1,First[initialConditions],​​ToExpression[First[SortBy[Select[ToString/@initialConditions,ContainsAll[VertexOutComponent[original,#],VertexList[original]]&],VertexEccentricity[original,#]&]]]];​​steps=If[Length[initialConditions]1,stepCount,VertexEccentricity[original,ToString[init]]];​​Which[prop"StatesGraph"||prop"StatesGraphStructure",​​merging=KeySortBy[GroupBy[VertexList[original],findCausalSequence[rules,initialConditions,init,steps,#]&],VertexCount];SimpleGraph[DirectedEdge[First[Flatten[Position[Values[merging],First[#]]]],First[Flatten[Position[Values[merging],Last[#]]]]]&/@EdgeList[original],opts,VertexShapeFunctionIf[prop==="StatesGraph",(Style[Inset[Framed@Show[Keys[merging][[#2]]],#1,Center,#3],ImageSizeMultipliers{1,1}]&),Automatic],VertexSize0.75,GraphLayout{"LayeredDigraphEmbedding","RootVertex"1}],prop"CausalInvariantQ",MTMCausalInvariantQ[rules,{init},steps],True,MultiwayTuringMachine[rules,initialConditions,stepCount,prop]]​​]
In[]:=
CausalMultiwayTuringMachine[List/@{{1,0}{1,1,-1},{1,0}{1,0,-1}},{First[TMAllStates[1,2,2]]},3,"StatesGraph"]
Out[]=
In[]:=
CausalMultiwayTuringMachine[List/@{{1,0}{1,1,-1},{1,0}{1,0,-1}},{First[TMAllStates[1,2,2]]},3,"StatesGraphStructure"]
Out[]=
In[]:=
CausalMultiwayTuringMachine[List/@{{1,0}{1,1,-1},{1,0}{1,0,-1}},{First[TMAllStates[1,2,2]]},3,"CausalInvariantQ"]
Out[]=
True
In[]:=
CausalMultiwayTuringMachine[List/@{{1,0}{1,1,-1},{1,0}{1,0,-1}},TMAllStates[1,2,3],1,"StatesGraph"]

Causal Invariance

Finite Tapes