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 »
WOLFRAM NOTEBOOK
k=2, r=3/2
k=2, r=3/2
In[]:=
Clear[LifetimeFunction]
In[]:=
allrules=ParallelTable[ru->LifetimeFunctionX[{ru,2,3/2},{1,1,1,0,1,1},{20,50,100,200}],{ru,0,2^16-1,2}];
In[]:=
KeySort[CountsBy[allrules,Last]]
Out[]=
164,2596,3555,4360,5160,679,728,85,95,111,131,∞30914
In[]:=
allrules=ParallelTable[ru->LifetimeFunctionX[{ru,2,3/2},{1,1,1,0,1,1},{20,50,100,200,1000}],{ru,0,2^16-1,2}];
In[]:=
KeySort[CountsBy[allrules,Last]]
Out[]=
164,2596,3555,4360,5160,679,728,85,95,111,131,∞30914
In[]:=
allrules=ParallelTable[ru->LifetimeFunctionX[{ru,2,3/2},{1,1,1,0,1,1},{20,50,100,200,1000,10000}],{ru,0,2^16-1,2}];
$Aborted[]
KeySort[CountsBy[allrules,Last]]
k=3, r=1
k=3, r=1
In[]:=
nogrowbits[{k_,r_}]:=nogrowbits[{k,r}]=Complement[Range[k^(2r+1)],Flatten[Position[Tuples[Reverse[Range[0,k-1]],2r+1],{1,0,0}|{0,0,1}]]]
In[]:=
nogrowbits[{2,1}]
Out[]=
{1,2,3,5,6}
In[]:=
nogrowbits[{3,1}]
Out[]=
{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,19,20,21,22,23,24,25,27}
In[]:=
ParallelMap[Function[ru,ru->LifetimeFunctionX[{ru,3,1},{1},{20,50,100,200}]],SeedRandom[23424];3RandomInteger[{0,3^3^3/3-1},10000]];
In[]:=
KeySort[CountsBy[%,Last]]
Out[]=
1384,281,332,44,54,61,71,∞9493
In[]:=
ParallelMap[Function[ru,ru->LifetimeFunctionX[{ru,3,1},{1},{20,50,100,200,2000}]],SeedRandom[23424];3RandomInteger[{0,3^3^3/3-1},10000]];
In[]:=
KeySort[CountsBy[%,Last]]
Out[]=
1384,281,332,44,54,61,71,∞9493
In[]:=
ru=236403443817;ArrayPlot@CellularAutomaton[{ru,3,1},{{1},0},{100,All}]Extract[IntegerDigits[ru,3,3^3],Position[Tuples[{2,1,0},3],{_,0,0}|{0,0,_}]]
Out[]=
Out[]=
{1,0,1,0,0}
In[]:=
ru=5608186322640;ArrayPlot@CellularAutomaton[{ru,3,1},{{1},0},{100,All}]Extract[IntegerDigits[ru,3,3^3],Position[Tuples[{2,1,0},3],{_,0,0}|{0,0,_}]]
Out[]=
Out[]=
{0,2,0,2,0}
In[]:=
specifical=<|10->{1389166931571,2687258870214,1687890447222,4835462860734,6720702628245,4641271783035,1578972682311,7321697561097,2897102490837,6555191031249},20->{5771927843997,1256588991117,98221885776,3241744615239,5631865111368,4644873946212,4335848215170,1263537929355,6439487971479,4297245909873},30->{5637280653432,2941740569562,2924739021048,4644829954248,3202093101984,4308565728156,5950860197427,727024936803,7227166413381,5151159515634},40->{382686580386,3610610221128,1335787340814,4927042225539,4494958160199,6765804465180,2959209925854,1409856334593,123434792196,6185625188595},50->{467400347574,7227226341960,4494965954586,5922425575350,6849931540272,4316963027397,4495125858630,939429007143,7227024748677,4412048141184},60->{2363076671946,1821680612889,3402022147593,396462650550,1660896189987,5259304393962,7227299045565,6159190973649,2042593728261,6567019026927},70->{892964116761,3473500985124,5197727919858,7564319486439,6379761652692,3230366494452,494637541254,2253913780596,1170650014494,4309119029220},80->{939472420092,7227039223404,1040506132914,5858386515807,7302648457185,6335749485078,3899563953558,6176332973385,396511543503,4928609292930},90->{892632864048,1072992827922,1720345832727,7321532934912,6389635555152,7227017612601,3335852784246,2959291295052,6189067393296,6439232379060},100->{620742979230,939470872506,1389124351005,620741384907,2660960579505,1389256677222,3512714628636,506866868844,4325136108621,6027525979062}|>;
In[]:=
KeyValueMap[Function[{key,vals},ArrayPlot[CellularAutomaton[{#,3,1},{{1},0},100],ImageSize->{Automatic,150}]&/@vals],specifical]
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
Can we find a path to reach a particular rule? [possibly reduce the search space by going in two directions ]
[[ want to find rules that achieve these objectives with e.g. minimum number of bits set ]]
[[ want to find rules that achieve these objectives with e.g. minimum number of bits set ]]