# [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-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 11 months 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 11 months 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 11 months 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 11 months 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 11 months 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