[Nik’s code]

In[]:=
StringSubstitutionPathCausalGraph[rules_,path_]:=Module[{cg,eventDecompositions},​​cg=TransitiveClosureGraph@Graph[lineGraph[PathGraph[path,DirectedEdgesTrue]],VertexLabels->Automatic];​​eventDecompositions=AssociationThread[​​DirectedEdge@@@Partition[path,2,1],​​Fold[With[{key=FirstPosition[MultiStringReplace[#2[[1]],rules],#2[[2]]][[1,1]]},With[{​​destroyed=Range@@key[[2,1]],created=key[[2,1,1]]-1+Range@StringLength[rules[[key[[1]],2]]]},​​Append[With[{diff=Length[created]-Length[destroyed]},Map[ReplaceAll[x_Integer/;If[diff>0,x>Last[destroyed],x<First[destroyed]]:>x+diff]]/@#1],<|"Destroyed"->destroyed,"Created"->created|>]​​]]&,{},Partition[path,2,1]]​​];​​Graph[Delete[EdgeList[cg],Position[MapAt[eventDecompositions,EdgeList[cg][[All,;;2]],{{All,1},{All,2}}],KeyValuePattern["Created"created_]KeyValuePattern["Destroyed"destroyed_]/;!IntersectingQ[created,destroyed]]​​],​​ResourceFunction["WolframPhysicsProjectStyleData"]["CausalGraph"]["Options"],​​VertexLabelsAutomatic​​]​​]
In[]:=
rules={"A"->"BBB","BB"->"A"};​​path={"A","BBB","AB","BBBB","ABB","AA","ABBB","ABA"};
In[]:=
StringSubstitutionPathCausalGraph[{"A"->"BBB","BB"->"A"},{"A","BBB","AB","BBBB","ABB","AA","ABBB","ABA"}]
Out[]=
In[]:=
Graph[%,EdgeLabels"Name"]
Out[]=
In[]:=
With[{g=Graph[ResourceFunction["MultiwaySystem"][{"A"->"BBB","BB"->"A"},"A",8,"StatesGraph"],AspectRatio->1.5]},HighlightGraph[g,Style[PathGraph[Echo@FindShortestPath[g,"A","ABA"],DirectedEdgesTrue],Red,Thick]]]
»
{A,BBB,AB,BBBB,ABB,AA,ABBB,ABA}
Out[]=
In[]:=
ResourceFunction["MultiwaySystem"][{"A"->"BBB","BB"->"A"},"A",6,"CausalGraph",AspectRatio->1/2]
Out[]=
In[]:=
With[{g=Graph[ResourceFunction["MultiwaySystem"][{"A"->"BBB","BB"->"A"},"A",8,"StatesGraph"],AspectRatio->1.5]},FindPath[g,"A","ABA",All,All]]
Out[]=
{{A,BBB,BA,BBBB,BBA,BBBBB,BBBA,ABA},{A,BBB,BA,BBBB,BBA,BBBBB,ABBB,ABA},{A,BBB,BA,BBBB,BBA,AA,BBBA,ABA},{A,BBB,BA,BBBB,BBA,AA,ABBB,ABA},{A,BBB,BA,BBBB,BAB,BBBBB,BBBA,ABA},{A,BBB,BA,BBBB,BAB,BBBBB,ABBB,ABA},{A,BBB,BA,BBBB,ABB,BBBBB,BBBA,ABA},{A,BBB,BA,BBBB,ABB,BBBBB,ABBB,ABA},{A,BBB,BA,BBBB,ABB,AA,BBBA,ABA},{A,BBB,BA,BBBB,ABB,AA,ABBB,ABA},{A,BBB,AB,BBBB,BBA,BBBBB,BBBA,ABA},{A,BBB,AB,BBBB,BBA,BBBBB,ABBB,ABA},{A,BBB,AB,BBBB,BBA,AA,BBBA,ABA},{A,BBB,AB,BBBB,BBA,AA,ABBB,ABA},{A,BBB,AB,BBBB,BAB,BBBBB,BBBA,ABA},{A,BBB,AB,BBBB,BAB,BBBBB,ABBB,ABA},{A,BBB,AB,BBBB,ABB,BBBBB,BBBA,ABA},{A,BBB,AB,BBBB,ABB,BBBBB,ABBB,ABA},{A,BBB,AB,BBBB,ABB,AA,BBBA,ABA},{A,BBB,AB,BBBB,ABB,AA,ABBB,ABA}}
In[]:=
StringSubstitutionPathCausalGraph[{"A"->"BBB","BB"->"A"},#]&/@%
Out[]=

,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,


Visualization

Interpretation

Causal graph shows which events are timelike connected, and must be sequentialized

In making the entailment fabric from tiny light cones .... will not connect things which are “causally deeper”

Knitting reachable ... and causal reachable