Plotting recursive from a for loop

Question

our assignment is that we have make a plot for the possition of 1's From the recursive function if a[n-1] is even then a[n]=a[n-1]/2 and if a[n-1] is odd then a[n]=3*a[n-1]+1 where we have to find at which possition the first 1 occures for 10000<=a[n]<=2.

So for this we have to do a for loop with if statment

list = {};

b[n_] := b[n] = If[EvenQ[b[n - 1]], b[n - 1]/2, 3*b[n - 1] + 1];

For[b[1] = 10000, b[1] =2, b[1]--, 

  AppendTo[list, Min [Position[Table[b[n], {n, 1, 30}], 1]]]];

list

ListPlot[list]

The problem we get is that every outprint will be for b[1]=10000 that is 30. And this is not what we were expecting. We know that the problem is that we can not use Clear[b] in a good way inside the loop, but is there any other way that this problem can be solved. ? For this the lector has adviced us to use ListPlot.

Answer 1

Here is a method using recursion with memoization. The trick is to create a recursive function which returns the length of the chain to 1, rather than just the next value. So for example when starting with 10000 the next value you get is 5000 and you have already memoized that it is 29 steps from 5000 to 1, so it must be 1+29 = 30 from 10000 to 1.

This is quite a bit faster - the results for 1 to 10000 are obtained in a fraction of a second.

ClearAll[steps]

mem : steps[x_?EvenQ] := mem = 1 + steps[x/2];
mem : steps[x_] := mem = 1 + steps[3 x + 1];
steps[1] = 1;

steps /@ Range[10]
(* {1, 2, 8, 3, 6, 9, 17, 4, 20, 7} *)

ListPlot[steps /@ Range[10000]]

Answer 2

The subtlety here is that the recursion is memoized, so you cannot just change the value of b[1] and run the recursion again (and if you remove the memoization, it runs impossibly slowly). One approach is to clear the stored b[ ] values inside the loop and redefine the recursion each pass. Here it is for the first few terms:

startVals = Range[2, 10]; 
thisB = ConstantArray[0, Length[startVals]];
Do[Clear[b]; 
 b[n_] := b[n] = If[EvenQ[b[n - 1]], b[n - 1]/2, 3*b[n - 1] + 1]; 
 b[1] = startVals[[j]]; allB = b[#] & /@ Range[1000];
 thisB[[j]] = Min[Position[allB, 1]];, {j, 1, Length[startVals]}];
thisB

{2, 8, 3, 6, 9, 17, 4, 20, 7}

This can also be done without clearing the recursion definition each time by defining the recursion to be a function of two variables: the recursive variable and the starting value. For example:

b[m_, n_] := b[m, n] = If[EvenQ[b[m, n - 1]], b[m, n - 1]/2, 3*b[m, n - 1] + 1];
startVals = Range[2, 10];
Do[b[j, 1] = j, {j, 1, Length[startVals]}];
Table[allB = b[j, #] & /@ Range[1000]; 
      Min[Position[allB, 1]], {j, 2, Length[startVals]}]

Answer 3

f[u_] := Boole[EvenQ@u] u/2 + Boole[OddQ@u] (3 u + 1)
g[u_] := Last@NestWhile[{f@#[[1]], #[[2]] + 1} &, {u, 1}, First@# != 1 &]
res = {#, g[#]} & /@ Range[2, 10000];

Visualizing:

ListPlot[res, Frame -> True, FrameLabel -> {"a[1]", "a[n]=1"}, 
 BaseStyle -> 16]

Or testing:

g[#] & /@ Range[10]

yields:

(*{1, 2, 8, 3, 6, 9, 17, 4, 20, 7}*)

Answer 4

This seems not a terribly good use of recursion..if you need all the values you may as well just march it out:

 p[i0_] :=
   First@NestWhile[
      {#[[1]] + 1, If[EvenQ[ Last@# ], Last@#/2 , 3 Last@# + 1 ]} & ,
         {1, i0}, Last@# != 1 &]
 p /@ Range[10]

{1, 2, 8, 3, 6, 9, 17, 4, 20, 7}

 p /@ Range[2, 10000] // Timing // First

3.447622