# Generate and graph the Recamán Sequence

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)

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.

• OEIS calls it "Recaman sequence", not "Recaman Sequence". – user64494 Jun 23 '19 at 18:29
• @user64494 No, it calls it Recamán ;-) – AccidentalFourierTransform Jun 23 '19 at 22:57
• @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. – halirutan Jun 24 '19 at 13:05
• @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? – user64494 Jun 24 '19 at 17:06
• @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? – halirutan Jun 24 '19 at 22:12

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]
]


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]


• 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! – CA Trevillian Jun 23 '19 at 16:51

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


With k = 100 we get

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]]


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:

... 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]


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


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}]]


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 && CompileGetElement[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}


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]


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]
`

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