RulePlot[CellularAutomaton[30],{{1},0},10]
In[]:=
Out[]=
{evolution10,evolution30,evolution50}=WolframModel[encodeCARule[30,0],encodeCAState[{1}],#]&/@{10,30,50};
In[]:=
colorRules=Join[{​​0Directive[Hue[0.5953666216824112`,0.9,0.6],EdgeForm[{Hue[0.5953666216824112`,0.9,0.6],Opacity[1]}]],​​1Directive[Hue[0.5953666216824112`,0.2,1],EdgeForm[{Black,Opacity[1]}]],​​2Directive[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",VertexStyleThread[Range[0,#["EventsCount"]](#["AllEventsList","IncludeBoundaryEvents""Initial"]〚All,1〛/.colorRules)],EdgeStyleLighter
,0.5,VertexSizeLarge&/@{evolution10,evolution30,evolution50};
In[]:=
graph10
In[]:=
Out[]=
VertexDelete[graph30,Position[evolution30["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize0.5]
In[]:=
Out[]=
With[{rule=30,steps=35},With[{evolution=WolframModel[encodeCARule[rule,0],encodeCAState[{1}],steps]},With[{graph=evolution["LayeredCausalGraph","IncludeBoundaryEvents""Initial",VertexStyleThread[Range[0,evolution["EventsCount"]](evolution["AllEventsList","IncludeBoundaryEvents""Initial"]〚All,1〛/.Join[{​​0Directive[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〛,VertexSize1.15,VertexShapeFunction"Square"]]]]
In[]:=
Out[]=
VertexDelete[graph10,Position[evolution10["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize0.5]
In[]:=
Out[]=
centerColumn=FindShortestPath[graph10,0,With[{reducedGraph=VertexDelete[graph10,Position[evolution10["AllEventsList"]〚All,1〛,1|2]〚All,1〛,VertexSize0.5]},With[{caEvents=Select[#〚2〛=!=Infinity&]@Thread[VertexList[reducedGraph]GraphDistance[reducedGraph,0]]},Select[#〚2〛==Max[Association[caEvents]]&][caEvents]〚1,1〛]]]
In[]:=
{0,5,14,27,44,65}
Out[]=
components=WeaklyConnectedComponents[VertexDelete[graph10,centerColumn]]
In[]:=
{{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}}
Out[]=
leftRoots=Position[evolution10["AllEventsList"]〚All,1〛,1]〚All,1〛
In[]:=
{1,3,6,10,15,21,28,36,45,55}
Out[]=
{leftComponent,rightComponent}=components〚{FirstPosition[#,True]〚1〛,FirstPosition[#,False]〚1〛}&[#=!={}&/@(Intersection[#,VertexOutComponent[graph10,leftRoots,1]]&/@components)]〛
In[]:=
{{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}}
Out[]=
{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}]])
In[]:=
Out[]=
layers=Join@@@Transpose[{leftLayers,List/@centerColumn,rightLayers}]
In[]:=
{{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}}
Out[]=
HighlightGraph[SimpleGraph[graph10,EdgeStyleLightGray,VertexStyleDirective[White,EdgeForm[LightGray]]],#]&/@layers
In[]:=
Out[]=
events=CenterArray[#,Length[layers〚1〛],-1]&/@layers
In[]:=
Out[]=
coordinates=With[{positions=Position[events,_?(#≥0&)]},Thread[Extract[events,#]&/@positionsWith[{halfWidth=(Length[events〚1〛]+1)/2,height=Length[events]},{#1-halfWidth,1-2#2+halfWidth-Abs[#1-halfWidth]}&@@@Reverse/@positions]]]
In[]:=
Out[]=
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=IfruleColors===Automatic,Join​​0Directive
,EdgeForm
,Opacity[1],​​12Directive
,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",VertexStyleThread[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,#]&/@positionsWith[{halfWidth=(Length[eventsGrid〚1〛]+1)/2,height=Length[eventsGrid]},{#1-halfWidth,1-2#2+halfWidth-Abs[#1-halfWidth]}&@@@Reverse/@positions]]];​​Graphgraph,opts,VertexCoordinatescoordinates,VertexSizeMedium,EdgeStyleReplaceedgeStyle,AutomaticLighter
,0.5​​
In[]:=
VertexCount[caCausalGraph[110,50,Automatic,LightGray,VertexSize100]]
In[]:=
1326
Out[]=
caCausalGraph[110,50,Automatic,LightGray,VertexSize1,VertexShapeFunction"Circle"]
In[]:=
Out[]=
caFoliationLines[steps_,style_:Directive[Thick,Red]]:=Tablestyle,Line[{{-k,-1},{-0.5,k-1.5}}],Circle{0,k-2},
2
2,{π/4,3π/4},Line[{{0.5,k-1.5},{k,-1}}],{k,2,steps,2}
In[]:=
caCausalGraph[30,10,Automatic,Automatic,EpilogcaFoliationLines[10]]
In[]:=
Out[]=
Graph[caCausalGraph[30,10],VertexSize1.25,VertexShapeFunction"Diamond"]
In[]:=
Out[]=
SimpleGraph[caCausalGraph[30,10],VertexLabelsAutomatic,VertexSizeMedium,EpilogcaFoliationLines[10]]
In[]:=
Out[]=
Horizontal
{15.5,15.5,16.5,16.5}
{14.5,14.5,17.5,17.5}
{13.5,13.5,15.5,15.5,16.5,16.5,18.5,18.5}
{12.5,12.5,14.5,14.5,17.5,17.5,19.5,19.5}
{11.5,11.5,13.5,13.5,15.5,15.5,16.5,16.5,18.5,18.5,20.5,20.5}
Vertical
{0.5,1.5,1.5,0.5}
{0.5,1.5,1.5,0.5}
{0.5,1.5,1.5,2.5,2.5,1.5,1.5,0.5}
arrayPlotFoliationLine[layer_,totalSteps_]:=Module[{horizontalCoordinates,verticalCoordinates},horizontalCoordinates=Catenate[ConstantArray[#,2]&/@Join[Range[totalSteps+1-layer,totalSteps,2],Reverse@Range[totalSteps+layer,totalSteps+1,-2]]];​​verticalCoordinates=Join[#,Reverse[#]]&@Rest@Most@Catenate[ConstantArray[#,2]&/@Range[totalSteps+1,totalSteps-Ceiling[layer/2]+1,-1]];​​Transpose[{horizontalCoordinates,ReplacePart[verticalCoordinates,{1verticalCoordinates〚1〛+1,-1verticalCoordinates〚-1〛+1}]}]]
In[]:=
arrayPlotFoliationLine[3,15]
In[]:=
{{13,17},{13,15},{15,15},{15,14},{16,14},{16,15},{18,15},{18,17}}
Out[]=
arrayPlotFoliationLine[4,15]
In[]:=
{{12,17},{12,15},{14,15},{14,14},{17,14},{17,15},{19,15},{19,17}}
Out[]=
arrayPlotFoliationLine[33,15]
In[]:=
Out[]=
ArrayPlot[CellularAutomaton[30,{{1},0},15],MeshAll,Epilog{Red,Thick,Table[Line[arrayPlotFoliationLine[k,15]],{k,1,47,3}]}]
In[]:=
Out[]=
caCausalGraph[30,10,Automatic,Automatic,Epilog{Thick,Red,straightFoliationLines[{1/3,0},{0,0},(#&),{0,-1}]}]
In[]:=
Out[]=