22
$\begingroup$

I was surprised to see that we don't have any posts that mention the Recamán Sequence, so I figured I should post it as a challenge. By definition, $a_0=0$ and $a_n=a_{n-1}-n$ if the r.h.s. is positive and different from all previous elements, and $a_n=a_{n-1}+n$ otherwise. The first few terms are 0, 1, 3, 6, 2, 7, 13, 20, 12, 21, 11, 22, ....

How can we generate this sequence as concisely as possible? And how to represent it graphically? An example of a possible representation is (source: Numberphile)

enter image description here

where each half-circle represents the jump from $a_n$ to $a_{n+1}$. It could be interesting to add colour. Extra points if you come up with an alternative representation which is aesthetically pleasing.

Improve this question
$\endgroup$
5
  • $\begingroup$ OEIS calls it "Recaman sequence", not "Recaman Sequence". $\endgroup$
    – user64494
    Jun 23, 2019 at 18:29
  • 3
    $\begingroup$ @user64494 No, it calls it Recamán ;-) $\endgroup$
    – AccidentalFourierTransform
    Jun 23, 2019 at 22:57
  • 4
    $\begingroup$ @user64494 Please stop these micro-edits. They don't improve the quality of the question and I'm sure we can agree that everyone can interpret the title. $\endgroup$
    – halirutan ♦
    Jun 24, 2019 at 13:05
  • $\begingroup$ @hairutan: Of course, I must listen to the forum moderators and I will listen to them. Do you treat a correction of grammar mistakes (not in this case) as micro-edit? $\endgroup$
    – user64494
    Jun 24, 2019 at 17:06
  • 3
    $\begingroup$ @user64494 No, usually, I welcome even small edits that improve the grammar. However, in this case, you changed graph to Graph 2 times without knowing that it is a verb here: "to graph -- to draw (a curve) as representing a given function". Secondly, Recamán Sequence could be regarded as a proper noun like House of Representatives. Even when most sources write sequence in lower case, the readers would have no problem to understand it. The title of this question has 7 edits and this simply escalates things and isn't helpful at all. Why don't you use this time to answer some Qs? $\endgroup$
    – halirutan ♦
    Jun 24, 2019 at 22:12

4 Answers 4

Reset to default
18
$\begingroup$

My own take on this:

Clear[f]
f[0] = 0;
f[n_] := f[n] = If[Or[MemberQ[Last /@ Most[DownValues[f]], f[n - 1] - n], 
f[n - 1] < n], f[n - 1] + n, f[n - 1] - n]

f /@ Range[0, 11]
(* {0, 1, 3, 6, 2, 7, 13, 20, 12, 21, 11, 22} *)

We can draw the figure using

With[{list = Table[f[n], {n, 0, 30}]},
     Show[Graphics@*Circle @@@ Partition[Flatten[{
     MovingAverage[Transpose[{list, Table[0, Length[list]]}], 2],
     Abs[Differences[list]/2],
     Partition[Range[Length[list]] \[Pi], 2, 1]
     }, {2, 1}], 3], ImageSize -> Full]
]

enter image description here

We can even add some colour using

Show[With[{list = Table[f[n], {n, 0, 30}]},
     Show[Graphics[{Opacity[.2], ColorData["DarkRainbow"][#[[1, 1]]/50], #}] &@*Disk @@@ Partition[Flatten[{
     MovingAverage[Transpose[{list, Table[0, Length[list]]}], 2],
     Abs[Differences[list]/2],
     Partition[Range[Length[list]] \[Pi], 2, 1]
     }, {2, 1}], 3]]
], %, ImageSize -> Full]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ I haven’t looked too hard at this code yet, but any reason you did not let it populate to at least the OP’s example? I wonder if there are other ways to plot the integer steps!!!! And how we might automate this 🤔 looks like I know how I’ll be distracting myself tonight! $\endgroup$
    – CA Trevillian
    Jun 23, 2019 at 16:51
17
$\begingroup$

Just the visualization part using ParametricPlot:

recamanSequencePlot1 = ParametricPlot[
   Evaluate[Map[RotationTransform[Pi/4] @ 
      {Mean @ # + (#[[2]] - #[[1]])/2 Cos[t], (#[[2]] - #[[1]])/2 Sin[t]} &,
     Partition[#, 2, 1]]], 
   {t, 0, -Pi}, 
   AspectRatio -> Automatic, Axes -> False, ImageSize -> Large] &;

Using AccidentalFourierTransform's f to generate a sequence of length k: 

k = 30;
list = Table[f[n], {n, 0, k}]; 
recamanSequencePlot1 @ list

enter image description here

With k = 100 we get

enter image description here

To get the fillings we can use two-parameter form of ParametricPlot:

recamanSequencePlot2 = ParametricPlot[ 
   Evaluate[Map[RotationTransform[Pi/4] @ 
      {Mean @ # + (#[[2]] - #[[1]])/2 Cos[t] r, (#[[2]] - #[[1]])/2 Sin[t] r} &,
     Partition[#, 2, 1]]], 
   {t, 0, -Pi}, {r, 0, 1},
   AspectRatio -> Automatic, Axes -> False, Mesh -> None,  PlotStyle -> 
  Opacity[.2], BoundaryStyle -> None] &;

Show[recamanSequencePlot1[list], recamanSequencePlot2[list]]

enter image description here

In the pictures above the increases in the sequence are shown below the diagonal and decreases above the diagonal to distinguish them visually. Change the first argument of ParametricPlot to

Evaluate[Module[{k = 1}, Map[RotationTransform[Pi/4] @ 
  {Mean @ # +(k=-k)Abs[#[[2]] - #[[1]]]/2 Cos[  t],k   Abs[#[[2]] - #[[1]]]/2 Sin[ t]} &,
     Partition[#, 2, 1]]]]

to replicate the picture in OP:

enter image description here

... and variations using BSplineCurve:

 Graphics[{ColorData[97][RandomInteger[{1, Length@list}]], AbsoluteThickness[4],
   BSplineCurve[#]} &@{{#, 0}, {#, Subtract@##}, {#2, Subtract @ ##}, {#2, 0}} & @@@ 
      Partition[list, 2, 1], ImageSize -> Large]

enter image description here

Graphics[{ColorData[97][RandomInteger[{1, Length @ list}]], AbsoluteThickness[4], 
  BSplineCurve[#, SplineDegree -> 1]} & @
     {{#, 0}, {Mean@{##}, 1/2 Subtract@##}, {#2, 0}} & @@@ Partition[list, 2, 1]]

enter image description here

ListAnimate[Table[
  Graphics[{Hue[#[[2, 2]]/100], Opacity[.75], AbsoluteThickness[1], 
   BSplineCurve[#, SplineDegree -> 1]} &@{{#, 0}, {Mean@{##}, 1/2 Subtract@##}, {#2, 0}} & 
    @@@ Partition[list[[;; t]], 2, 1], 
  ImageSize -> Large, 
  PlotRange -> {{0, 250}, {-50, 50}}], {t, 2, 100}]]

enter image description here

Improve this answer
$\endgroup$
13
$\begingroup$

If you don't care about extra space, we can employ a reverse lookup table:

seenQ[0] = True;
a[0] = 0;
a[n_] := a[n] = With[{prev = a[n - 1]},
  (seenQ[#] = True; #) &[
    If[prev > n && ! TrueQ[seenQ[prev - n]], prev - n, prev + n]
  ]
]

Block[{$RecursionLimit = ∞},
  Do[a[k], {k, 10^6}] // AbsoluteTiming
]

{8.55911, Null}

a /@ Range[0, 20]

{0, 1, 3, 6, 2, 7, 13, 20, 12, 21, 11, 22, 10, 23, 9, 24, 8, 25, 43, 62, 42}

If you know the largest value of the sequence you'd like to compute, we can pre allocate the tables and therefore also compile. This gives us more than a 100 times speedup:

RecamanTable = Compile[{{n, _Integer}},
  Module[{seenQ = Table[0, {8n}], as = Table[0, {n+1}], prev = 0},
    seenQ[[1]] = 1;
    Do[
      If[prev > k && Compile`GetElement[seenQ, prev-k+1] == 0,
        prev -= k,
        prev += k
      ];
      seenQ[[prev+1]] = 1;
      as[[k+1]] = prev;, 
      {k, 1, n}
    ];
    as
  ],
  CompilationTarget -> "C",
  RuntimeOptions -> "Speed"
];

RecamanTable[10^8]; // AbsoluteTiming

{3.97308, Null}
Improve this answer
$\endgroup$
9
$\begingroup$

I have a few experiments to contribute:

  1. I tried to fill the gaps and use up all the "unused" integers in a Recamán series truncated to N entries, so whenever a member of the series is bigger than N, it just jumps to the first integer that is not part of the series yet. Also, I added a final semicircle that connects the last and the first entry to close the loop:
f[0] = 0;
f[n_] := f[n] = If[Or[MemberQ[Last /@ Most[DownValues[f]], f[n - 1] - n], 
    f[n - 1] < n], f[n - 1] + n, f[n - 1] - n]
n = 15;
(*generate series*)
rec = (f /@ Range[0, n]);
(*look for unused Integers*)
unu =  If[Position[rec, #] == {}, #, Nothing] & /@ Range[n];
(*look for entries > N*)
upo = Flatten[Position[If[# > n, NaN, #] & /@ rec, NaN]]; 
red = rec;
(*replace entries > N with unused Integers*)
(red = ReplacePart[red, upo[[#]] ->(*Reverse[*)unu(*]*)[[#]]]) &/@
Range[Min[Length[unu],Length[upo]]];
red = Append[red, 0];

lpt = Range[n + 1];
crc = Circle[{(lpt[[red[[# + 1]] + 1]] - lpt[[red[[#]] + 1]])/2 + 
       lpt[[red[[#]] + 1]], 0}, 
     Abs[(lpt[[red[[# + 1]] + 1]] - lpt[[red[[#]] + 1]])/2], 
     If[EvenQ[#], {0, Pi}, {Pi, 2*Pi}]] & /@ Range[n + 1];
g2 = Graphics[Flatten[{RGBColor[0, 0, 0, 1], crc}], 
   ImageSize -> Large]

N=15

N=105

  1. I mapped all the points onto a cricle and connected them with straight lines instead of semicircles (this also makes use of 1.)
p = 2*Pi/n;
pts = If[p*# < Pi/2 || p*# > 3/2*Pi, {Cos[p*#], 
      Sin[p*#]}, {-Cos[Pi - p*#], Sin[Pi - p*#]}] & /@ Range[0, n];
lns = {pts[[red[[#]] + 1]], pts[[red[[# + 1]] + 1]]} & /@ Range[n - 1];
g1 = Graphics[{RGBColor[0, 0, 0, 1], Line[Flatten[lns, 1]]}, 
   ImageSize -> Large]

N=15

N=105

N=1005

  1. There's a pattern that emerges when you just ListPlot the Series:

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.