# [Numberphile] - Amazing Graphs III

Posted 2 years ago
5211 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-pMIR8ukThe 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] 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: 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] 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: Perhaps someone can provide a faster implementation? Hope you enjoyed these codes, perhaps you can modify them and make them more intricate/faster/better! Answer
5 Replies
Sort By:
Posted 2 years ago
 I worked on one interesting problem on AOPS: https://artofproblemsolving.com/community/c4h1878869p12775512And 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 is the link between this problem and Fibonacci[n]. The fraction parts of Out forms Farey Sequence  Attachments: Answer
Posted 2 years ago
 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 Answer
Posted 2 years ago
 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:  Answer
Posted 2 years ago
 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. Answer
Posted 2 years ago - 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! Answer