WOLFRAM NOTEBOOK

In[]:=
CloudGet["https://wolfr.am/KXgcRNRJ"];ArrayPlot[CellularAutomaton[30,{{1},0},15],ColorRules{0White,1Black},FrameNone,Epilog{Lighter[Red,.3],Thick,Table[Line[arrayPlotFoliationLine[k,15]],{k,1,47,3}]}]
Out[]=
For every foliation slice (“proper time”) which list of blocks should be used
In[]:=
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,{1verticalCoordinates[[1]]+1,-1verticalCoordinates[[-1]]+1}]}]]
In[]:=
arrayPlotFoliationLine[3,5]
Out[]=
{{3,7},{3,5},{5,5},{5,4},{6,4},{6,5},{8,5},{8,7}}
In[]:=
ListLinePlot[%]
Out[]=
3
4
5
6
7
8
4.0
4.5
5.0
5.5
6.0
6.5
7.0
In[]:=
ListLinePlot[arrayPlotFoliationLine[10,30]]
Out[]=
25
30
35
40
26
27
28
29
30
31
32
This is just a pruning of the true foliation ... because the true foliation

Multiway CA

In[]:=
RulePlot[CellularAutomaton[30]]
Out[]=
Make this a non-deterministic block CA...
In[]:=
(Take[#,{2,-2}]Take[CellularAutomaton[30][#],{2,-2}])&/@Tuples[{1,0},5]
Out[]=
In[]:=
Union[(Take[#,{2,-2}]Take[CellularAutomaton[30][#],{2,-2}])&/@Tuples[{1,0},5]]
Out[]=
In[]:=
RulePlot[SubstitutionSystem[%]]
Out[]=
In[]:=
mwca30=Union[(Take[#,{2,-2}]Take[CellularAutomaton[30][#],{2,-2}])&/@Tuples[{1,0},5]];
In[]:=
ResourceFunction["MultiwaySystem"][mwca30,{{0,0,0,1,0,0,0}},3]
Out[]=
In[]:=
CellularAutomaton[30,{0,0,0,1,0,0,0},3]
Out[]=
{{0,0,0,1,0,0,0},{0,0,1,1,1,0,0},{0,1,1,0,0,1,0},{1,1,0,1,1,1,1}}
In[]:=
Position[%141,#]&/@%
Out[]=
{{{1,1},{2,3},{3,9},{4,9}},{{2,9},{3,25},{4,29}},{{4,51}},{}}
In[]:=
Map[First,%,{2}]
Out[]=
{{1,2,3,4},{2,3,4},{4},{}}
In[]:=
mwevol[t_]:=ResourceFunction["MultiwaySystem"][mwca30,{CenterArray[{1},2t+1]},t]
In[]:=
swevol[t_]:=CellularAutomaton[30,CenterArray[{1},2t+1],t]
In[]:=
mv4=mwevol[4];
In[]:=
Length/@%
Out[]=
{1,18,121,349,502}
In[]:=
sv4=swevol[4];
In[]:=
(First/@Position[mv4,#])&/@sv4
Out[]=
{{1,2,3,4,5},{2,3,4,5},{4,5},{5},{4,5}}
In[]:=
With[{t=3},ResourceFunction["MultiwaySystem"][mwca30,{CenterArray[{1},2t+1]},t,"StatesGraphStructure"]]//LayeredGraphPlot
Out[]=
In[]:=
With[{t=3},ResourceFunction["MultiwaySystem"][mwca30,{CenterArray[{1},2t+1]},t,"CausalGraphStructure"]]//LayeredGraphPlot
Wolfram Cloud

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 »

You are using a browser not supported by the Wolfram Cloud. Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.