In[]:=
RulePlot[CellularAutomaton[30],{{1},0},10]
Out[]=
In[]:=
{evolution10,evolution30,evolution50}=WolframModel[encodeCARule[30,0],encodeCAState[{1}],#]&/@{10,30,50};
In[]:=
colorRules=Join[{0Directive[Hue[0.5953666216824112`,0.9,0.6],EdgeForm[{Hue[0.5953666216824112`,0.9,0.6],Opacity[1]}]],1Directive[Hue[0.5953666216824112`,0.2,1],EdgeForm[{Black,Opacity[1]}]],2Directive[Hue[0.5953666216824112`,0.2,1],EdgeForm[{Black,Opacity[1]}]]},Thread[Range[3,10](Directive[#,EdgeForm[{Black,Opacity[1]}]]&/@(GrayLevel[1-#]&)/@{0,0,0,1,1,1,1,0})]];
In[]:=
{graph10,graph30,graph50}=#"LayeredCausalGraph","IncludeBoundaryEvents""Initial",VertexStyleThread[Range[0,#["EventsCount"]](#["AllEventsList","IncludeBoundaryEvents""Initial"]〚All,1〛/.colorRules)],EdgeStyleLighter,0.5,VertexSizeLarge&/@{evolution10,evolution30,evolution50};
In[]:=
graph10
Out[]=
In[]:=
VertexDelete[graph30,Position[evolution30["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize0.5]
Out[]=
In[]:=
With[{rule=30,steps=35},With[{evolution=WolframModel[encodeCARule[rule,0],encodeCAState[{1}],steps]},With[{graph=evolution["LayeredCausalGraph","IncludeBoundaryEvents""Initial",VertexStyleThread[Range[0,evolution["EventsCount"]](evolution["AllEventsList","IncludeBoundaryEvents""Initial"]〚All,1〛/.Join[{0Directive[White,EdgeForm[Black]]},Thread[Range[3,10](Directive[#,EdgeForm[{Black,Opacity[1]}]]&/@(GrayLevel[1-#]&)/@IntegerDigits[rule,2,8])]])]]},VertexDelete[graph,Position[evolution["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize1.15,VertexShapeFunction"Square"]]]]
Out[]=
In[]:=
VertexDelete[graph10,Position[evolution10["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize0.5]
Out[]=
In[]:=
centerColumn=FindShortestPath[graph10,0,With[{reducedGraph=VertexDelete[graph10,Position[evolution10["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize0.5]},With[{caEvents=Select[#〚2〛=!=Infinity&]@Thread[VertexList[reducedGraph]GraphDistance[reducedGraph,0]]},Select[#〚2〛==Max[Association[caEvents]]&][caEvents]〚1,1〛]]]
Out[]=
{0,5,14,27,44,65}
In[]:=
components=WeaklyConnectedComponents[VertexDelete[graph10,centerColumn]]
Out[]=
{{47,22,29,37,58,6,10,15,38,30,21,57,28,3,16,11,48,39,46,36,56,1,7,23,17,59,49,45,31,55},{32,24,51,40,61,41,18,33,62,50,52,12,25,42,60,63,8,19,34,53,4,13,26,43,64,2,9,20,35,54}}
In[]:=
leftRoots=Position[evolution10["AllEventsList"]〚All,1〛,1]〚All,1〛
Out[]=
{1,3,6,10,15,21,28,36,45,55}
In[]:=
{leftComponent,rightComponent}=components〚{FirstPosition[#,True]〚1〛,FirstPosition[#,False]〚1〛}&[#=!={}&/@(Intersection[#,VertexOutComponent[graph10,leftRoots,1]]&/@components)]〛
Out[]=
{{47,22,29,37,58,6,10,15,38,30,21,57,28,3,16,11,48,39,46,36,56,1,7,23,17,59,49,45,31,55},{32,24,51,40,61,41,18,33,62,50,52,12,25,42,60,63,8,19,34,53,4,13,26,43,64,2,9,20,35,54}}
In[]:=
{leftLayers,rightLayers}=Append[{}]/@({Reverse/@#〚1〛,#〚2〛}&[With[{eventLayers=evolution10["AllEventsGenerationsList"]},With[{simpleGraph=SimpleGraph[Subgraph[graph10,#]]},Most@NestWhileList[SortBy[Complement[VertexOutComponent[simpleGraph,#,1],#],eventLayers〚#〛&]&,SortBy[VertexList[simpleGraph]〚Position[VertexInDegree[simpleGraph],_?(#≤1&)]〚All,1〛〛,eventLayers〚#〛&],Length[#]≠0&]]&/@{leftComponent,rightComponent}]])
Out[]=
In[]:=
layers=Join@@@Transpose[{leftLayers,List/@centerColumn,rightLayers}]
Out[]=
{{55,45,36,28,21,15,10,6,3,1,0,2,4,8,12,18,24,32,40,50,60},{56,46,37,29,22,16,11,7,5,9,13,19,25,33,41,51,61},{57,47,38,30,23,17,14,20,26,34,42,52,62},{58,48,39,31,27,35,43,53,63},{59,49,44,54,64},{65}}
In[]:=
HighlightGraph[SimpleGraph[graph10,EdgeStyleLightGray,VertexStyleDirective[White,EdgeForm[LightGray]]],#]&/@layers
Out[]=
In[]:=
events=CenterArray[#,Length[layers〚1〛],-1]&/@layers
Out[]=
In[]:=
coordinates=With[{positions=Position[events,_?(#≥0&)]},Thread[Extract[events,#]&/@positionsWith[{halfWidth=(Length[events〚1〛]+1)/2,height=Length[events]},{#1-halfWidth,1-2#2+halfWidth-Abs[#1-halfWidth]}&@@@Reverse/@positions]]]
Out[]=
In[]:=
caCausalGraph[rule_,steps_?EvenQ,ruleColors_:Automatic,edgeStyle_:Automatic,opts___:OptionsPattern[]]:=Module{evolution,colorRules,graph,centerColumn,connectedComponents,leftBoundaryExtensionEvents,leftComponent,rightComponent,leftLayers,rightLayers,layers,eventsGrid,coordinates},evolution=WolframModel[encodeCARule[rule,0],encodeCAState[{1}],steps];colorRules=IfruleColors===Automatic,Join0Directive,EdgeForm,Opacity[1],12Directive,EdgeForm[{Black,Opacity[1]}],Thread[Range[3,10](Directive[#,EdgeForm[{Black,Opacity[1]}]]&/@(GrayLevel[1-#]&)/@IntegerDigits[rule,2,8])],ruleColors;graph=evolution["LayeredCausalGraph","IncludeBoundaryEvents""Initial",VertexStyleThread[Range[0,evolution["EventsCount"]](evolution["AllEventsList","IncludeBoundaryEvents""Initial"]〚All,1〛/.colorRules)]];centerColumn=FindShortestPath[graph,0,With[{reducedGraph=VertexDelete[graph,Position[evolution["AllEventsList"]〚All,1〛,1|2]〚All,1〛]},With[{caEvents=Select[#〚2〛=!=Infinity&]@Thread[VertexList[reducedGraph]GraphDistance[reducedGraph,0]]},Select[#〚2〛==Max[Association[caEvents]]&][caEvents]〚1,1〛]]];connectedComponents=WeaklyConnectedComponents[VertexDelete[graph,centerColumn]];leftBoundaryExtensionEvents=Position[evolution["AllEventsList"]〚All,1〛,1]All,1;{leftComponent,rightComponent}=connectedComponents{FirstPosition[#,True]〚1〛,FirstPosition[#,False]〚1〛}&[#=!={}&/@(Intersection[#,VertexOutComponent[graph,leftBoundaryExtensionEvents,1]]&/@connectedComponents)];{leftLayers,rightLayers}=Append[{}]/@({Reverse/@#〚1〛,#〚2〛}&[With[{eventLayers=evolution["AllEventsGenerationsList"]},With[{simpleGraph=SimpleGraph[Subgraph[graph,#]]},Most@NestWhileList[SortBy[Complement[VertexOutComponent[simpleGraph,#,1],#],eventLayers〚#〛&]&,SortBy[VertexList[simpleGraph]〚Position[VertexInDegree[simpleGraph],_?(#≤1&)]〚All,1〛〛,eventLayers〚#〛&],Length[#]≠0&]]&/@{leftComponent,rightComponent}]]);layers=Join@@@Transpose[{leftLayers,List/@centerColumn,rightLayers}];eventsGrid=CenterArray[#,Length[layers〚1〛],-1]&/@layers;coordinates=With[{positions=Position[eventsGrid,_?(#≥0&)]},Thread[Extract[eventsGrid,#]&/@positionsWith[{halfWidth=(Length[eventsGrid〚1〛]+1)/2,height=Length[eventsGrid]},{#1-halfWidth,1-2#2+halfWidth-Abs[#1-halfWidth]}&@@@Reverse/@positions]]];Graphgraph,opts,VertexCoordinatescoordinates,VertexSizeMedium,EdgeStyleReplaceedgeStyle,AutomaticLighter,0.5
Horizontal
Vertical