Faster alternative to AppendTo?

[Dem_z]

Hey, sorry I'm really new. I only started using mathematica recently, so I'm not that savvy.

Anyways, I wrote some code to calculate (and store) the orbits around numbers in the Collatz conjecture.

"Take any whole number n greater than 0. If n is even, we halve it (n/2), else we do "triple plus one" and get 3n+1. The conjecture is that for all numbers this process converges to 1. "
http://en.wikipedia.org/wiki/Collatz_conjecture

(*If there's no remainder, divides by 2, else multiply by 3 add 1*)
g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]

(*creates an empty list a. Loops and appends the k's orbit into variable "orbit", which then appends to variable "a" after the While loop is completed. New m, sets new k, which restarts the While loop again.*)
a = {};
Do[
k = m;
orbit = {k};
While[k > 1, AppendTo[orbit, k = g[k]]];
AppendTo[a, orbit];
, {m, 2,1000000}];

Anyways it seems that the AppendTo function gets exponentially slower, as you throw more data into it. Is there a way to make this more efficient? To calculate a million points takes days with this method.

[Tomas Garza]

It seems to me you are wasting Mathematica in trying to replicate old programming paradigms. Mathematica has a very powerful programming language, functional programming, which is ideally suited to handle problems like the one you have. So, for example, I obtain the answer for 1,000,000 points in less than three minutes:

In[1]:= AbsoluteTiming[Table[NestWhileList[g, m, #>1&],{m, 1, 1000000}];]
Out[1]= {211.9884000,Null}

Check the result for m = 10:

In[2]:= Table[NestWhileList[g,m,#>1&],{m,1,10}]

Out[2]= {{1},{2,1},{3,10,5,16,8,4,2,1},{4,2,1},{5,16,8,4,2,1},{6,3,10,5,16,8,4,2,1},{7,22,11,34,17,52,26,13,40,20,10,5,16,8,4,2,1},{8,4,2,1},{9,28,14,7,22,11,34,17,52,26,13,40,20,10,5,16,8,4,2,1},{10,5,16,8,4,2,1}}

You'll find it worthile spending a few hours studying this approach.

Tomas

> Date: Tue, 1 Sep 2009 03:53:33 -0400
> From: de...@hotmail.com
> Subject: Faster alternative to AppendTo?
> To: math...@smc.vnet.net

[Emu]

Always try to avoid using Append and AppendTo. Here's one way

In[186]:= Table[NestWhileList[If[EvenQ[#],#/2,3 #+1]&,m,#=!=1&],{m,
2,10}]
Out[186]= {{2,1},{3,10,5,16,8,4,2,1},{4,2,1},{5,16,8,4,2,1},

{6,3,10,5,16,8,4,2,1},{7,22,11,34,17,52,26,13,40,20,10,5,16,8,4,2,1},
{8,4,2,1},{9,28,14,7,22,11,34,17,52,26,13,40,20,10,5,16,8,4,2,1},
{10,5,16,8,4,2,1}}

You can see that it's fairly fast.

In[187]:= Table[Table[NestWhileList[If[EvenQ[#],#/2,3 #+1]&,m,#=!=1&],
{m,2,upper}]//Timing//First,{upper,1000,10000,1000}]
Out[187]=
{0.231005,0.514937,0.826265,1.1636,1.48742,1.85433,2.1733,2.5272,2.8803,3.27888}

Sam

[Murray Eisenberg]

There's a package Collatz.m that's long been distributed with
Mathematica. For Mathematica 7, it's in:

$InstallationDirectory\Documentation\English\System\ExampleData

You can copy the definitions from that .m file and try it directly
without having to load the package:

Collatz[1] := {1}
Collatz[n_Integer]:= Prepend[Collatz[3 n + 1], n] /; OddQ[n] && n > 0
Collatz[n_Integer] := Prepend[Collatz[n/2], n] /; EvenQ[n] && n > 0

Collatz[1000000];//Timing
{1.0842*10^-19, Null} (* on my PC *)

Dem_z wrote:
> Hey, sorry I'm really new. I only started using mathematica recently, so I'm not that savvy.
>
> Anyways, I wrote some code to calculate (and store) the orbits around numbers in the Collatz conjecture.
>
> "Take any whole number n greater than 0. If n is even, we halve it (n/2), else we do "triple plus one" and get 3n+1. The conjecture is that for all numbers this process converges to 1. "
> http://en.wikipedia.org/wiki/Collatz_conjecture
>
>
> (*If there's no remainder, divides by 2, else multiply by 3 add 1*)
> g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]
>
> (*creates an empty list a. Loops and appends the k's orbit into variable "orbit", which then appends to variable "a" after the While loop is completed. New m, sets new k, which restarts the While loop again.*)
> a = {};
> Do[
> k = m;
> orbit = {k};
> While[k > 1, AppendTo[orbit, k = g[k]]];
> AppendTo[a, orbit];
> , {m, 2,1000000}];
>
> Anyways it seems that the AppendTo function gets exponentially slower, as you throw more data into it. Is there a way to make this more efficient? To calculate a million points takes days with this method.
>

--
Murray Eisenberg mur...@math.umass.edu
Mathematics & Statistics Dept.
Lederle Graduate Research Tower phone 413 549-1020 (H)
University of Massachusetts 413 545-2859 (W)
710 North Pleasant Street fax 413 545-1801
Amherst, MA 01003-9305

[Jaebum Jung]

You could rewrite it using NestWhileList and Map; For example,

In[170]:= (a={};
Do[k=m;
orbit={k};
While[k>1,AppendTo[orbit,k=g[k]]];
AppendTo[a,orbit];,{m,2,20000}])//AbsoluteTiming
Out[170]= {15.247986,Null}

In[169]:= (aN=NestWhileList[g,#,#>1&]&/@Range[2,20000];)//AbsoluteTiming
Out[169]= {5.852271,Null}

If you have multi cores, ParallelMap can speed up the computation,

LaunchKernels[]
DistributeDefinitions[g]
In[175]:= Kernels[]//Length
Out[175]= 4

In[168]:= (aP=ParallelMap[NestWhileList[g,#,#>1&]&,Range[2,20000],Method
-> "CoarsestGrained"];)//AbsoluteTiming
Out[168]= {2.184031,Null}

Check the result:

In[173]:= a===aN===aP
Out[173]= True

- Jaebum

[Leonid Shifrin]

Hi,

avoid Prepend, Append, PrependTo and AppendTo inside loops like a plague.

Take a look at

http://www.mathprogramming-intro.org/book/node515.html

and

http://www.mathprogramming-intro.org/book/node240.html

where I specifically discuss this problem and show a couple of faster
implementations
It is probably possible to solve this with Mathematica much more
efficiently yet.

Regards,
Leonid

[Ray Koopman]

g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]

Timing[a = {}; Do[k = m; orbit = {k};

While[k > 1, AppendTo[orbit, k = g[k]]];

AppendTo[a, orbit], {m,2,10^4}]]

{25.11 Second, Null}

InputForm[ gc = Compile[{{m,_Integer}}, NestWhileList[If[EvenQ
[#],Quotient[#,2],3#+1]&, m, #>1&]] ]

CompiledFunction[{_Integer}, {{2, 0, 0}, {2, 1, 0}},
{2, 7, 2, 0, 1}, {{1, 5}, {92, 2, 1}, {4, 0, 2},
{93, 2, 1, 0, 0, 2}, {9, 0, 2}, {9, 2, 3}, {4, 1, 4},
{48, 4, 3, 0}, {41, 0, 20}, {9, 2, 3}, {4, 2, 4},
{89, 271, 2, 0, 3, 2, 0, 4, 2, 0, 5}, {4, 0, 4}, {44, 5, 4, 1},
{41, 1, 5}, {4, 2, 5}, {89, 262, 2, 0, 3, 2, 0, 5, 2, 0, 4},
{9, 4, 6}, {42, 6}, {4, 3, 5}, {28, 5, 3, 5}, {4, 1, 6},
{24, 5, 6, 5}, {9, 5, 6}, {9, 6, 2}, {4, 0, 6},
{93, 2, 1, 0, 2, 6}, {42, -22}, {94, 2, 1, 2, -1, 0}, {2}},
Function[{m}, NestWhileList[If[EvenQ[#1], Quotient[#1, 2],
3*#1 + 1] & , m, #1 > 1 & ]], Evaluate]

Timing[a == Table[ gc[m], {m,2,10^4}]]

{1.03 Second, True}

Note on compiling: It's a good idea to always look at the InputForm
of a compiled function, to make sure that there are only numbers in
the body of the function, before the final Function[...],Evaluate].
If there are any words then the compiled code will usually be slower
than the uncompiled code.

[Sjoerd]

AppendTo is not very efficient for long lists, because it has to make
a complete copy of the list involved. Try a construction like orbit
= {orbit,k = g[k]} and orbit = Flatten[orbit] at the end when you're
finished.

This is more efficient because lists that are element of a list are
stored in this list as a pointer only. So copying the list that
contains them involves copying the pointer only, not all the stuff
that is in the sublist.

The code would loook like:

a = {};
Do[
k = m;
orbit = {k};

While[k > 1, orbit = {orbit, k = g[k]}];
a = {a, Flatten[orbit]},
{m, 2, 1000000}
];
a = Flatten[a];

Cheers--Sjoerd

[Bob Hanlon]

g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]

fpl[n_] := FixedPointList[If[EvenQ[#], #/2, 3 # + 1] &, n,
SameTest -> (#2 == 1 &)]

Timing[a = {};

Do[k = m;
orbit = {k};
While[k > 1, AppendTo[orbit, k = g[k]]];

AppendTo[a, orbit];, {m, 2, 25000}]]

{33.9348,Null}

Timing[b = fpl /@ Range[2, 25000];]

{7.86831,Null}

a == b

True

Bob Hanlon

---- Dem_z <de...@hotmail.com> wrote:

=============

[pfalloon]

On Sep 1, 5:53 pm, Dem_z <de...@hotmail.com> wrote:

Yes, AppendTo doesn't work very well at all for this kind of thing,
because the process of growing the list dynamically is very
inefficient (see the documentation for more details). A more efficient
alternative in general when you don't know how long the list will be
is to use the functions Reap and Sow.

However, for this problem there are better solutions which make use of
some Mathematica-esque programming style (there many more, perhaps
much nicer than these...).

1. You can set it up as "fixed-point" type of process, whereby it
keeps iterating until it reaches 1:

collatzOrbit[n_Integer] := FixedPointList[Which[#===1, 1, EvenQ[#], #/
2, True, 3#+1]&, n, 1000]

This is pretty efficient, but it has no "memory", in the sense that it
forgets values that it has previously encountered.

2. A way to save previous results is to use "dynamic programming" to
save the values computed recursively. Here I define a function to
calculate the number of steps in the orbit:

Clear[collatzOrbitLength];
collatzOrbitLength[1] = 1;
collatzOrbitLength[n_Integer] := collatzOrbitLength[n] = 1 +
collatzOrbitLength[If[EvenQ[n], n/2, 3n+1]]

You should look up the documentation and possibly other sources online
to understand how this works.

Using this definition I am able to compute the orbit lengths up to
n=10^6 in about 22 seconds on a reasonably fast Windows machine
(though there is a technical subtlety: you need to temporarily
increase the value of $RecursionLimit or else an automatic error-check
will kick in):

Block[{$RecursionLimit=10000}, pts = collatzOrbitLength /@ Range
[1000000]]; // Timing

{21.86, Null}

The maximum number of steps in this range is:

{Max[pts], Flatten@Position[pts, Max[pts]]}

One downside to this approach is that it starts to consume a lot of
memory as you compute more values. However, you can easily Clear the
stored definitions.

Hope this helps and happy programming!

Cheers,
Peter.

[Bill Rowe]

On 9/1/09 at 3:53 AM, de...@hotmail.com (Dem_z) wrote:

>Hey, sorry I'm really new. I only started using mathematica
>recently, so I'm not that savvy.

>Anyways, I wrote some code to calculate (and store) the orbits
>around numbers in the Collatz conjecture.

>"Take any whole number n greater than 0. If n is even, we halve it
>(n/2), else we do "triple plus one" and get 3n+1. The conjecture is
>that for all numbers this process converges to 1. "
>http://en.wikipedia.org/wiki/Collatz_conjecture

>(*If there's no remainder, divides by 2, else multiply by 3 add 1*)

>g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]

>(*creates an empty list a. Loops and appends the k's orbit into variable "=
orbit", which then appends to variable "a" after the While loop is complete=

d. New m, sets new k, which restarts the While loop again.*)

>a = {};
>Do[
>k = m;
>orbit = {k};
>While[k > 1, AppendTo[orbit, k = g[k]]];
>AppendTo[a, orbit];
>, {m, 2,1000000}];
>AppendTo[a, orbit]; , {m, 2,1000000}];

>Anyways it seems that the AppendTo function gets exponentially
>slower, as you throw more data into it. Is there a way to make this
>more efficient?

It is usually significantly faster to build a nested list than
flatten it. That is instead of

AppendTo[orbit, k = g[k]]

do

orbit = {orbit {k=g[k]}}

and flatten it later.

But even better is to use NestWhileList

That is

Table[NestWhileList[g[#] &, m, # > 1 &], {m, 2, 1000000}]

will generate the same list as your but faster.

[Patrick Scheibe]

Hi,

yes there are better ways. First it is in most cases better to use
things like Nest, NestList, Table, Fold, Thread, Map, MapThread instead
of the imperative loops like Do, While. Here is your approach:

AbsoluteTiming[a = {};

Do[k = m;
orbit = {k};
While[k > 1, AppendTo[orbit, k = g[k]]];

AppendTo[a, orbit];, {m, 2, 30000}];]

Needs 36.375672 seconds on my system. If you just put the function g
into a pure function expression and use Table and NestWhileList you get

AbsoluteTiming[
Table[NestWhileList[(If[EvenQ[#], #/2, 3 # + 1] &),
i, (# > 1 &)], {i, 2, 30000}];]

and this call needs 6.970204 sec here. In this case and on my system
with 4 cpu cores it is better to use all power, so I start 4 Kernels

LaunchKernels[4]

and evaluate it parallel

AbsoluteTiming[
ParallelTable[
NestWhileList[(If[EvenQ[#], #/2, 3 # + 1] &), i, (# > 1 &)], {i, 2,
30000}];]

This needs only 3.684756 sec. Your original question with an upper limit
of 1000000 needs parallelized 133 seconds here.

Cheers
Patrick

On Tue, 2009-09-01 at 03:53 -0400, Dem_z wrote:
> Hey, sorry I'm really new. I only started using mathematica recently, so I'm not that savvy.
>
> Anyways, I wrote some code to calculate (and store) the orbits around numbers in the Collatz conjecture.
>
> "Take any whole number n greater than 0. If n is even, we halve it (n/2), else we do "triple plus one" and get 3n+1. The conjecture is that for all numbers this process converges to 1. "
> http://en.wikipedia.org/wiki/Collatz_conjecture
>
>
> (*If there's no remainder, divides by 2, else multiply by 3 add 1*)
> g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]
>

> (*creates an empty list a. Loops and appends the k's orbit into variable "orbit", which then appends to variable "a" after the While loop is completed. New m, sets new k, which restarts the While loop again.*)

> a = {};
> Do[
> k = m;
> orbit = {k};
> While[k > 1, AppendTo[orbit, k = g[k]]];
> AppendTo[a, orbit];
> , {m, 2,1000000}];
>

[Kurt]

Try this (you're on your own for timing long runs)

collatz[x_Integer/;EvenQ[x]]:=x/2
collatz[x_Integer]:=3 x +1

Then the orbit of an integer n is given by

FixedPointList[collatz,n]

If you'd like to be cautious and put a limit on the calculation, you may
with

FixedPointList[collatz, n, limit]

Of course you can restart the investigation by using the last entry in
the list for n as n in a new calculation.

Kurt

On Tue, 01 Sep 2009 03:53 -0400, "Dem_z" <de...@hotmail.com> wrote:
> Hey, sorry I'm really new. I only started using mathematica recently, so
> I'm not that savvy.
>
> Anyways, I wrote some code to calculate (and store) the orbits around
> numbers in the Collatz conjecture.
>
> "Take any whole number n greater than 0. If n is even, we halve it (n/2),
> else we do "triple plus one" and get 3n+1. The conjecture is that for all
> numbers this process converges to 1. "
> http://en.wikipedia.org/wiki/Collatz_conjecture
>
>
> (*If there's no remainder, divides by 2, else multiply by 3 add 1*)
> g[n_] := If[Mod[n, 2] == 0, n/2, 3 n + 1]
>
> (*creates an empty list a. Loops and appends the k's orbit into variable
> "orbit", which then appends to variable "a" after the While loop is
> completed. New m, sets new k, which restarts the While loop again.*)
> a = {};
> Do[
> k = m;
> orbit = {k};
> While[k > 1, AppendTo[orbit, k = g[k]]];
> AppendTo[a, orbit];
> , {m, 2,1000000}];
>
> Anyways it seems that the AppendTo function gets exponentially slower, as
> you throw more data into it. Is there a way to make this more efficient?
> To calculate a million points takes days with this method.
>

--
Love,
Kurt
e...@fastmail.net

[DrMajorBob]

211.9884000 seconds is MORE than 3 minutes, but anyway...

I think this is a faster algorithm:

Clear[g, h]
g[1] = 1;
g[n_] := Which[
ListQ@n, n,
ListQ@h@n, Rest@h@n,
EvenQ@n, n/2,
True, 3 n + 1
]
AbsoluteTiming[
Table[h[m] = Flatten@Most@FixedPointList[g, m], {m, 1, 1000000}];]

{54.366878, Null}

Bobby

On Wed, 02 Sep 2009 03:00:51 -0500, Tomas Garza <tgar...@msn.com> wrote:

> It seems to me you are wasting Mathematica in trying to replicate old
> programming paradigms. Mathematica has a very powerful programming
> language, functional programming, which is ideally suited to handle
> problems like the one you have. So, for example, I obtain the answer for
> 1,000,000 points in less than three minutes:
>
>
> In[1]:= AbsoluteTiming[Table[NestWhileList[g, m, #>1&],{m, 1, 1000000}];]
> Out[1]= {211.9884000,Null}
>
> Check the result for m = 10:
>
> In[2]:= Table[NestWhileList[g,m,#>1&],{m,1,10}]
>
> Out[2]=
> {{1},{2,1},{3,10,5,16,8,4,2,1},{4,2,1},{5,16,8,4,2,1},{6,3,10,5,16,8,4,2,1},{7,22,11,34,17,52,26,13,40,20,10,5,16,8,4,2,1},{8,4,2,1},{9,28,14,7,22,11,34,17,52,26,13,40,20,10,5,16,8,4,2,1},{10,5,16,8,4,2,1}}
>
> You'll find it worthile spending a few hours studying this approach.
>
> Tomas
>
>> Date: Tue, 1 Sep 2009 03:53:33 -0400
>> From: de...@hotmail.com
>> Subject: Faster alternative to AppendTo?
>> To: math...@smc.vnet.net
>>

--
DrMaj...@yahoo.com

[DrMajorBob]

Unfortunately, Collatz raises $RecursionLimit and $IterationLimit errors.

10^6 is fine, but some number in the following range is not, since it
throws a $RecursionLimit error:

AbsoluteTiming[Table[Collatz@m, {m, 6*10^3, 7*10^3}];]

The following code lists 761 failures up to 10^6, and it takes eight or
nine times as long as the code I posted a few minutes ago:

Off[$RecursionLimit::"reclim", $IterationLimit::"itlim"]
Reap@AbsoluteTiming[Table[! ListQ@Collatz@m && Sow@m, {m, 1, 10^5}];]

{{450.227054,
Null}, {{6171, 6943, 7963, 9257, 10415, 10617, 10971, 11945, 12135,
12342, 12343, 12399, 12583, 13255, 13886, 13887, 14695, 15039,
15623, 15926, 15927, 16457, 16777, 17647, 17673, 18514, 18515,
18599, 18875, 19593, 19883, 20830, 20831, 20895, 21234, 21235,
21351, 21942, 21943, 22043, 22369, 22559, 23435, 23457, 23529,
23655, 23890, 23891, 24091, 24235, 24270, 24271, 24684, 24685,
24686, 24798, 24799, 25166, 25167, 26471, 26510, 26511, 26623,
27135, 27772, 27773, 27774, 27807, 27899, 28313, 29257, 29390,
29391, 29825, 30078, 30079, 30715, 31231, 31246, 31247, 31343,
31387, 31419, 31687, 31852, 31853, 31854, 32027, 32121, 32313,
32361, 32415, 32913, 32914, 32915, 33019, 33065, 33554, 33555,
33839, 34239, 34719, 35294, 35295, 35346, 35347, 35497, 35655,
37028, 37029, 37030, 37147, 37198, 37199, 37375, 37503, 37750,
37751, 37755, 39009, 39015, 39186, 39187, 39707, 39766, 39767,
39935, 40105, 40111, 40703, 40953, 40959, 41641, 41660, 41661,
41662, 41707, 41711, 41790, 41791, 41849, 42249, 42468, 42469,
42470, 42475, 42702, 42703, 43147, 43884, 43885, 43886, 44025,
44086, 44087, 44671, 44738, 44739, 45055, 45118, 45119, 45127,
46073, 46443, 46639, 46699, 46847, 46870, 46871, 46873, 46914,
46915, 46921, 47015, 47058, 47059, 47081, 47129, 47310, 47311,
47329, 47531, 47780, 47781, 47782, 47785, 47995, 48041, 48182,
48183, 48470, 48471, 48475, 48540, 48541, 48542, 48623, 48927,
49368, 49370, 49372, 49373, 49435, 49529, 49575, 49596, 49597,
49598, 49833, 50332, 50333, 50334, 50759, 50815, 51067, 51359,
52011, 52079, 52249, 52507, 52527, 52942, 52943, 53020, 53021,
53022, 53246, 53247, 53473, 53481, 53483, 53499, 54270, 54271,
54511, 55275, 55521, 55544, 55546, 55548, 55549, 55609, 55614,
55615, 55721, 55798, 55799, 56063, 56071, 56095, 56255, 56487,
56625, 56626, 56627, 56633, 56863, 56937, 57115, 57451, 57529,
57531, 57627, 58513, 58514, 58515, 58523, 58780, 58781, 58782,
59007, 59071, 59561, 59650, 59651, 59655, 59903, 60073, 60156,
60157, 60158, 60159, 60167, 60169, 60187, 60231, 60523, 60607,
60975, 61055, 61430, 61431, 61439, 61551, 61723, 61999, 62185,
62265, 62462, 62463, 62492, 62493, 62494, 62497, 62553, 62561,
62567, 62575, 62686, 62687, 62745, 62774, 62775, 62838, 62839,
63081, 63105, 63374, 63375, 63387, 63579, 63704, 63706, 63708,
63709, 63713, 63993, 64054, 64055, 64242, 64243, 64255, 64626,
64627, 64633, 64721, 64722, 64723, 64830, 64831, 64839, 65511,
65826, 65827, 65828, 65829, 65830, 65835, 65839, 65913, 66038,
66039, 66129, 66130, 66131, 66495, 67007, 67108, 67109, 67110,
67111, 67583, 67678, 67679, 67689, 67691, 67711, 67753, 68089,
68187, 68478, 68479, 69110, 69111, 69121, 69231, 69375, 69438,
69439, 69535, 69665, 69959, 70009, 70049, 70057, 70271, 70306,
70307, 70308, 70309, 70310, 70335, 70372, 70373, 70374, 70380,
70381, 70382, 70523, 70588, 70589, 70590, 70622, 70623, 70692,
70693, 70694, 70966, 70967, 70994, 70995, 71297, 71310, 71311,
71449, 71451, 71527, 71672, 71674, 71676, 71677, 71678, 71679,
71993, 72062, 72063, 72273, 72274, 72275, 72361, 72681, 72706,
72707, 72711, 72713, 72807, 72812, 72813, 72814, 72935, 72943,
73063, 73391, 73755, 74056, 74058, 74060, 74061, 74065, 74145,
74153, 74294, 74295, 74363, 74396, 74397, 74398, 74431, 74475,
74750, 74751, 74761, 74779, 74791, 74793, 75006, 75007, 75500,
75501, 75502, 75510, 75511, 75817, 75867, 75915, 76139, 76153,
76223, 76231, 76601, 76705, 76711, 77031, 77039, 78017, 78018,
78019, 78030, 78031, 78111, 78119, 78267, 78372, 78373, 78374,
78375, 78463, 78761, 78791, 79131, 79263, 79414, 79415, 79532,
79533, 79534, 79551, 79870, 79871, 80097, 80209, 80210, 80211,
80222, 80223, 80225, 80249, 80299, 80697, 80809, 81007, 81159,
81406, 81407, 81767, 81906, 81907, 81918, 81919, 82297, 82411,
82665, 82913, 82975, 83282, 83283, 83320, 83322, 83324, 83325,
83329, 83391, 83403, 83414, 83415, 83422, 83423, 83433, 83503,
83580, 83581, 83582, 83659, 83698, 83699, 83785, 84095, 84107,
84127, 84143, 84383, 84498, 84499, 84679, 84731, 84936, 84938,
84940, 84941, 84945, 84950, 84951, 85295, 85351, 85404, 85405,
85406, 85657, 85673, 85791, 86169, 86175, 86177, 86294, 86295,
86297, 86441, 87087, 87768, 87769, 87770, 87772, 87773, 87785,
87999, 88050, 88051, 88059, 88135, 88172, 88173, 88174, 88511,
88607, 89023, 89119, 89263, 89342, 89343, 89476, 89477, 89478,
89481, 89483, 89855, 90110, 90111, 90236, 90237, 90238, 90239,
90251, 90254, 90255, 90281, 90337, 90347, 90785, 90911, 91305,
91463, 91583, 92146, 92147, 92159, 92161, 92199, 92319, 92327,
92347, 92463, 92585, 92713, 92886, 92887, 92999, 93278, 93279,
93345, 93398, 93399, 93409, 93694, 93695, 93723, 93740, 93741,
93742, 93745, 93746, 93747, 93828, 93829, 93830, 93835, 93841,
93842, 93843, 93851, 93863, 94030, 94031, 94116, 94117, 94118,
94162, 94163, 94183, 94257, 94258, 94259, 94620, 94621, 94622,
94658, 94659, 94959, 95062, 95063, 95081, 95265, 95323, 95369,
95560, 95562, 95564, 95565, 95569, 95570, 95571, 95775, 95990,
95991, 96082, 96083, 96364, 96365, 96366, 96383, 96415, 96481,
96940, 96941, 96942, 96950, 96951, 97080, 97082, 97083, 97084,
97085, 97215, 97246, 97247, 97257, 97259, 97279, 97417, 97531,
97854, 97855, 98267, 98395, 98736, 98740, 98741, 98744, 98746,
98753, 98759, 98870, 98871, 98971, 99007, 99058, 99059, 99067,
99150, 99151, 99192, 99194, 99196, 99197, 99241, 99666, 99667,
99681, 99705, 99721, 99743, 99775}}}

Bobby

On Wed, 02 Sep 2009 03:01:45 -0500, Murray Eisenberg
<mur...@math.umass.edu> wrote:

> There's a package Collatz.m that's long been distributed with
> Mathematica. For Mathematica 7, it's in:
>
> $InstallationDirectory\Documentation\English\System\ExampleData
>
> You can copy the definitions from that .m file and try it directly
> without having to load the package:
>
> Collatz[1] := {1}
> Collatz[n_Integer]:= Prepend[Collatz[3 n + 1], n] /; OddQ[n] && n > 0
> Collatz[n_Integer] := Prepend[Collatz[n/2], n] /; EvenQ[n] && n > 0
>
> Collatz[1000000];//Timing
> {1.0842*10^-19, Null} (* on my PC *)
>
>
> Dem_z wrote:

[DrMajorBob]

Sorry... I meant to say, Collatz going to 10^5 took 8 or 9 times as long
as my code going to 10^6.

Clear[g, h]
g[1] = 1;
g[n_] := Which[
ListQ@n, n,
ListQ@h@n, Rest@h@n,
EvenQ@n, n/2,
True, 3 n + 1
]
AbsoluteTiming[
Table[h[m] = Flatten@Most@FixedPointList[g, m], {m, 1, 1000000}];]

{54.366878, Null}

Bobby

On Wed, 02 Sep 2009 19:09:22 -0500, DrMajorBob <btr...@austin.rr.com>
wrote:

[Elton Kurt TeKolste]

This will not work as 1 is not a fixed point unless you make it so:

collatz[1]:=1

On Wed, 02 Sep 2009 04:07 -0400, "Kurt" <e...@fastmail.net> wrote:
> Try this (you're on your own for timing long runs)
>
> collatz[x_Integer/;EvenQ[x]]:=x/2
> collatz[x_Integer]:=3 x +1
>
> Then the orbit of an integer n is given by
>
> FixedPointList[collatz,n]
>
> If you'd like to be cautious and put a limit on the calculation, you may
> with
>
> FixedPointList[collatz, n, limit]
>
> Of course you can restart the investigation by using the last entry in
> the list for n as n in a new calculation.
>
> Kurt
>
>

> Love,
> Kurt
> e...@fastmail.net
>
>
Regards,
Kurt Tekolste