I have Conway's Challenge sequence at hand i.e. $a_n=a_{a_{n-1}}+a_{n-a_{n-1}}$ for $\ n \geq 3$ and $a_1=a_2=1$. I have basically no idea how to define this in Mathematica.
There are two ways to go about this problem. The heads on approach is to simply run a function which does what you ask for;
conwayschallenge[n_] :=
If[n == 1 || n == 2, 1,
conwayschallenge[conwayschallenge[n - 1]] +
conwayschallenge[n - conwayschallenge[n - 1]]]
However, you will find that this is very slow.
conwayschallenge[25]//Timing --> {102.552,15}
The reason for this is that it is repeating calculations over and over. A common way around this is memoization. I have done my memoization using a new feature in version 10, called associations. These are pretty much dictionaries.
conwayschallenge2[n_] :=
Module[{i = 2, cc = <|1 -> 1, 2 -> 1|>},
While[i++ < n,
cc = Join[
cc, <|i ->
cc[[Key[cc[[Key[i - 1]]]]]] +
cc[[Key[i - cc[[Key[i - 1]]]]]]|>]]; cc]
And this results in much faster calculations;
conwayschallenge2[25]//Timing --> {0., <|1 -> 1, 2 -> 1,...,24 -> 14, 25 -> 15|>}
-
$\begingroup$ Thanks, but when i change the initial values it doesnt work?? $\endgroup$ – user40510 May 26 '16 at 8:22
-
$\begingroup$ My guess is that you are trying to access a negative number or zero for a(n-a(n-1)), i.e. n-a(n-1)<=0 $\endgroup$ – Squigglyteeth May 27 '16 at 1:14
When recursion is involved I'm always tempted to use Fold
. It pretty much imitates memoization, since it stores all previous values.
conw[n_] := Module[{},
fc[x_List, m_] :=
Append[x, (x[[x[[m - 1]]]] + x[[m - x[[m - 1]]]])];
If[0 < n <= 2, ConstantArray[1, n], Fold[fc, {1, 1}, Range[3, n]]]
];
conw[10]
(* {1, 1, 2, 2, 3, 4, 4, 4, 5, 6} *)
This method seems to be faster than conwayschallenge2
from @Squigglyteeth for small n
, but with large n
appending to a list becomes too expensive.
bench[f_, arg_List] := {#, (f[#] // Timing // First)} & /@ arg;
bk = bench[conw, Round@10^Range[1, 5, 0.2]];
sq = bench[conwayschallenge2, Round@10^Range[1, 5, 0.2]];
ListLogLogPlot[{bk, sq}, Joined -> True, Frame -> True,
GridLines -> Automatic, PlotLegends -> LineLegend[{"bk", "sq"}],
FrameLabel -> {"n", "Time (s)"}]
ClearAll@a; a[1] = a[2] = 1; a[n_Integer] := a[n] = a[a[n - 1]] + a[n - a[n - 1]]; ListPlot[a /@ Range[1, 100]]
produces this plot $\endgroup$ – Jason B. May 25 '16 at 11:37