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
Numerical Ruliad...
Numerical Ruliad...
In[]:=
gg=Table[Last[ResourceFunction["GraphNeighborhoodVolumes"][With[{m=k},NestGraph[n|->Table[an,{a,m}],1,10]],{1}]],{k,2,13}]
Out[]=
{{1,2,3,4,5,6,7,8,9,10,11},{1,3,6,10,15,21,28,36,45,55,66},{1,4,9,16,25,36,49,64,81,100,121},{1,5,14,30,55,91,140,204,285,385,506},{1,6,18,40,75,126,196,288,405,550,726},{1,7,25,65,140,266,462,750,1155,1705,2431},{1,8,30,80,175,336,588,960,1485,2200,3146},{1,9,36,100,225,441,784,1296,2025,3025,4356},{1,10,42,120,275,546,980,1632,2565,3850,5566},{1,11,53,173,448,994,1974,3606,6171,10021,15587},{1,12,59,194,504,1120,2226,4068,6963,11308,17589},{1,13,72,266,770,1890,4116,8184,15147,26455,44044}}
In[]:=
ff=Table[LinearRecurrence[Table[(-1)^(k+1)Binomial[PrimePi[m]+1,k],{k,1,PrimePi[m]+1}],Prepend[Length/@NestList[Union[Times@@#&/@Tuples[{Range[m],#}]]&,Range[m],PrimePi[m]-1],1],11],{m,2,13}]
Out[]=
{{1,2,3,4,5,6,7,8,9,10,11},{1,3,6,10,15,21,28,36,45,55,66},{1,4,9,16,25,36,49,64,81,100,121},{1,5,14,30,55,91,140,204,285,385,506},{1,6,18,40,75,126,196,288,405,550,726},{1,7,25,65,140,266,462,750,1155,1705,2431},{1,8,30,80,175,336,588,960,1485,2200,3146},{1,9,36,100,225,441,784,1296,2025,3025,4356},{1,10,42,120,275,546,980,1632,2565,3850,5566},{1,11,53,173,448,994,1974,3606,6171,10021,15587},{1,12,59,194,504,1120,2226,4068,6963,11308,17589},{1,13,72,266,770,1890,4116,8184,15147,26455,44044}}
In[]:=
Table[Prepend[Length/@NestList[Union[Times@@#&/@Tuples[{Range[m],#}]]&,Range[m],PrimePi[m]-1],1],{m,6}]
Out[]=
{{1,1},{1,2},{1,3,6},{1,4,9},{1,5,14,30},{1,6,18,40}}
In[]:=
Table[FindSequenceFunction[LinearRecurrence[Table[(-1)^(k+1)Binomial[PrimePi[m]+1,k],{k,1,PrimePi[m]+1}],Prepend[Length/@NestList[Union[Times@@#&/@Tuples[{Range[m],#}]]&,Range[m],PrimePi[m]-1],1],15],t],{m,2,20}]
Out[]=
t,t(1+t),,(t+3+2),(+),(2t+9+10+3),(2+3+),(+2+),(+3+2),(2t+25+50+35+8),(-4t+20+55+40+9),(42+95+75+25+3),(-12t+104+285+245+87+11),(-6t+43+135+130+51+7),(-12t+32+135+140+57+8),,(-24t+70+287+315+154+35+3),,
1
2
2
t
1
6
2
t
3
t
1
2
2
t
3
t
1
24
2
t
3
t
4
t
1
6
2
t
3
t
4
t
1
4
2
t
3
t
4
t
1
6
2
t
3
t
4
t
1
120
2
t
3
t
4
t
5
t
1
120
2
t
3
t
4
t
5
t
1
240
2
t
3
t
4
t
5
t
6
t
1
720
2
t
3
t
4
t
5
t
6
t
1
360
2
t
3
t
4
t
5
t
6
t
1
360
2
t
3
t
4
t
5
t
6
t
-72t+546+1729+1785+847+189+16
2
t
3
t
4
t
5
t
6
t
7
t
5040
1
840
2
t
3
t
4
t
5
t
6
t
7
t
-240t+1972+6384+7021+3780+1078+156+9
2
t
3
t
4
t
5
t
6
t
7
t
8
t
20160
-240t+772+3164+3675+2030+588+86+5
2
t
3
t
4
t
5
t
6
t
7
t
8
t
10080
In[]:=
CoefficientList[#,t]&/@%168
Out[]=
{0,1},0,,,{0,0,1},0,,,,0,0,,,0,,,,,0,0,,,,0,0,,,,0,0,,,,0,,,,,,0,-,,,,,0,0,,,,,,0,-,,,,,,0,-,,,,,,0,-,,,,,,0,-,,,,,,,0,-,,,,,,,0,-,,,,,,,,0,-,,,,,,,
1
2
1
2
1
6
1
2
1
3
1
2
1
2
1
12
3
8
5
12
1
8
1
3
1
2
1
6
1
4
1
2
1
4
1
6
1
2
1
3
1
60
5
24
5
12
7
24
1
15
1
30
1
6
11
24
1
3
3
40
7
40
19
48
5
16
5
48
1
80
1
60
13
90
19
48
49
144
29
240
11
720
1
60
43
360
3
8
13
36
17
120
7
360
1
30
4
45
3
8
7
18
19
120
1
45
1
70
13
120
247
720
17
48
121
720
3
80
1
315
1
35
1
12
41
120
3
8
11
60
1
24
1
280
1
84
493
5040
19
60
1003
2880
3
16
77
1440
13
1680
1
2240
1
42
193
2520
113
360
35
96
29
144
7
120
43
5040
1
2016
In[]:=
Exponent[#,t]&/@%168
Out[]=
{1,2,2,3,3,4,4,4,4,5,5,6,6,6,6,7,7,8,8}
In[]:=
ListStepPlot[%]
Out[]=
[major slowdown around 29 ... }
In[]:=
Monitor[Table[Exponent[FindSequenceFunction[LinearRecurrence[Table[(-1)^(k+1)Binomial[PrimePi[m]+1,k],{k,1,PrimePi[m]+1}],Prepend[Length/@NestList[Union[Times@@#&/@Tuples[{Range[m],#}]]&,Range[m],PrimePi[m]-1],1],15],t],t],{m,2,30}],m]
Out[]=
{1,2,2,3,3,4,4,4,4,5,5,6,6,6,6,7,7,8,8,8,8,9,9,9,9,9,9,10,10}
In[]:=
Differences[%]
Out[]=
{1,0,1,0,1,0,0,0,1,0,1,0,0,0,1,0,1,0,0,0,1,0,0,0,0,0,1,0}
In[]:=
ListStepPlot[%175]
Out[]=
In[]:=
Position[%176,1]//Flatten
Out[]=
{1,3,5,9,11,15,17,21,27}
In[]:=
FindSequenceFunction[%,t]
Out[]=
FindSequenceFunction[{1,3,5,9,11,15,17,21,27},t]
Primes
Primes
In[]:=
Graph[ResourceFunction["NestGraphTagged"][n|->Select[Table[Prime[a]n,{a,10}],#<100&],1,10,"StateLabeling"->True,"RuleStyling"->None],GraphLayout"LayeredDigraphEmbedding",AspectRatio1/2]
Out[]=