Message Boards Message Boards

GROUPS:

[Numberphile] - Amazing Graphs III

Posted 11 months ago
2512 Views
|
5 Replies
|
14 Total Likes
|

This is part of a series where I explore some of the videos of Numberphile, see also the other ones:

Today we are gonna look at another video on graphs: https://www.youtube.com/watch?v=j0o-pMIR8uk

The first sequence (https://oeis.org/A002487) can, conveniently be recreated by using Riffle:

data = NestList[Riffle[#, Total /@ Partition[#, 2, 1]] &, {1, 1}, 13];
data = Join @@ data[[All, ;; -2]];
ListPlot[data]

enter image description here

The second sequence (https://oeis.org/A005185) can be recreated like this:

Dynamic[i]
n = 100000;
x = ConstantArray[1, n];
Do[
 os = {x[[i - 2]], x[[i - 1]]};
 tot = x[[i - os]];
 x[[i]] = Total[tot];
 ,
 {i, 3, n}
 ]

giving:

enter image description here

An alternative view would be to plot it logarithmically in the horizontal direction, and to divide the sequence by the index of each number:

tmp = N[x];
tmp /= Range[Length[tmp]];
ListLogLinearPlot[tmp, PlotRange -> All]

enter image description here

The last sequence (https://oeis.org/A279125) can be recreated like this:

n=1000;
x=ConstantArray[0,n];
Dynamic[i]
Do[
 k=-1;
 ok=False;
 While[!ok,
  k++;
  good=True;
  Do[
   If[x[[j]]==k,
    If[BitAnd[i,j]>0,
     good=False;
     Break[];
    ]
   ]
  ,
  {j,1,i-1}
  ];
  If[good==True,
   x[[i]]=k;
   Break[];
  ]
 ]
,
 {i,2,n}
]
ListPlot[x]

giving:

enter image description here

Perhaps someone can provide a faster implementation? Hope you enjoyed these codes, perhaps you can modify them and make them more intricate/faster/better!

5 Replies

I worked on one interesting problem on AOPS: https://artofproblemsolving.com/community/c4h1878869p12775512

And the result turns to be Stern's sequence (A049455, also A002487) after I have played around with Wolfram Language. This is also a strong example to show why it is necessary to do experiments in mathematics. Some simple-looking problem has connection to something rather deep and intriguing.

  • Out[9] is the link between this problem and Fibonacci[n].
  • The fraction parts of Out[8] forms Farey Sequence

stern

Attachments:

That's quite remarkable that you got the sequence 'by accident'. I can't seem to speed up the generation of the last sequence, maybe I think about this problem the wrong way…

cf = Compile[{},
          Module[{k, ok, good, n, x},
           n = 1000;
           x = Table[0, {k,n}];
           Do[k = -1;
            ok = False;
            While[! ok, k++;
             good = True;
             Do[If[x[[j]] == k, If[BitAnd[i, j] > 0, good = False;
                Break[];]], {j, 1, i - 1}];
             If[good == True, x[[i]] = k;
              Break[];]], {i, 2, n}]; Return[x]], CompilationTarget -> "C"
          ]

This code generates the first 1000 points in less than 0.1 seconds:

enter image description here

Thanks for your efforts!

Impressive speedup! I think both our algorithm have similar issues when it comes to scaling. Trying 4000 takes 50x longer as compared to 1000. So it seems worse than quadratic.

enter image description here - Congratulations! This post is now featured in our Staff Pick column as distinguished by a badge on your profile of a Featured Contributor! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract