Message Boards Message Boards

[Numberphile] - Amazing Graphs III

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!

POSTED BY: Sander Huisman
5 Replies

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!

POSTED BY: EDITORIAL BOARD
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

POSTED BY: Shenghui Yang

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.

POSTED BY: Sander Huisman

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:
POSTED BY: Shenghui Yang

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…

POSTED BY: Sander Huisman
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