Plotting recursive from a for loop

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.

• just do b[n_] := If ..  so you dont need to clear b each time you change b[1] – george2079 Sep 24 '14 at 10:40
• – xzczd Sep 24 '14 at 10:43
• Really? Someone is teaching you Mathematica using For loops and AppendTo? That's just depressing. See here: mathematica.stackexchange.com/a/18396/8 – Verbeia Sep 24 '14 at 11:16
• Hopefully the use of For and AppendTo is the student's interpretation of the task (and not the preferred approach). – bill s Sep 24 '14 at 12:15
• should have put "in principle" in my first comment.. :) – george2079 Sep 24 '14 at 15:59

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


• Simon -- this is very clever! – bill s Sep 26 '14 at 1:59
• @SimonWoods very instructive, thank you – ubpdqn Sep 26 '14 at 6:32

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

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}*)


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