Re: Working with factors of triangular numbers.
- To: mathgroup at smc.vnet.net
- Subject: [mg78747] Re: [mg78490] Working with factors of triangular numbers.
- From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Date: Sun, 8 Jul 2007 06:14:09 -0400 (EDT)
- References: <200707030923.FAA17995@smc.vnet.net> <6D2F6E70-2462-4B69-A617-4DEC322D69BF@mimuw.edu.pl> <93E8C621-E93F-4761-A0FF-205BF84249CD@mimuw.edu.pl> <a851af150707070640g1f6a22e9ue072d4eba5c9262a@mail.gmail.com> <6F7B3048-4C96-48BC-AADF-2A62837DE6D3@mimuw.edu.pl> <9F4DE591-C9FC-4474-A4AA-55BB06222CEB@mimuw.edu.pl> <7E37AEC6-3F22-48F7-8C71-7DFED9B47B96@mimuw.edu.pl>
In fact, one more remark (its hard to stop adding these remarks!).
Clearly if you are computing the values of T[n] for several different
n, this is an inefficient way to proceed, because you if we know that
t1 is the smallest triagular number that can be factored as a
product of n factors than we know also that no triangular number
smaller than t1 can be factored as a product of (n+1) factors. It is
then better to proceed like this.
t[a_] := k /. ToRules[Reduce[k (k + 1)/2 == a && k > 0, k]]
T[n_, m_:1] :=
Block[{k = t[m], $Messages}, While[k++; FF[k*((k + 1)/2) - 1] < n,
Null];
k*((k + 1)/2)]
T can now be usd to search starting with the last found triangular
number. Thus:
i = 1; NestList[T[++i, #] &, 3, 6]
{3, 15, 55, 253, 1081, 13861, 115921}
should be a faster way to find successive values of T[n].
Andrzej Kozlowski
On 8 Jul 2007, at 09:37, Andrzej Kozlowski wrote:
> Just one more remark. I have found that even this relatively slow
> program on my slow 1 gigahertz PowerBook can compute
>
> T[8] // Timing
> {61.9871, 1413721}
>
> and
>
> Timing[T[9]]
> {932.333005, 27331921}
>
> the time complexity of the algorithm is clearly very high, which
> suggests that perhaps even a much faster implementation will not be
> able to compute many more values in a reasonable time.
>
>
> Andrzej Kozlowski
>
>
> On 8 Jul 2007, at 06:21, Andrzej Kozlowski wrote:
>
>> I am still curious how you got these wrong answers using my
>> program which is correct and gives the right ones when I run it
>> here, and the only hypothesis that comes to my mind that is that
>> it is the fault of the program you are using to read e-mail and
>> that the code you pasted in was not exactly the same as the one I
>> sent. This has been known to happen with some programs. If you are
>> still not getting the right answers I can send you a Mathematica
>> notebook.
>>
>> Andrzej Kozlowski
>>
>>
>> On 7 Jul 2007, at 23:00, Andrzej Kozlowski wrote:
>>
>>>
>>> You must have made some mistake.
>>>
>>> Let me do it all form the beginning, with Mathematica 6.0 for Mac
>>> and fresh kernel:
>>>
>>> << Combinatorica`
>>>
>>> FF[n_] := Module[{u = FactorInteger[n], s, k, partialQ, finalQ,
>>> space, sp},
>>> s = u[[All,2]]; k = Length[u]; sp[m_] := Tuples[Range[0, m],
>>> {k}];
>>> partialQ[l_List] := And @@ Flatten[{Last[l] == Array[0 & , k] ||
>>> !MemberQ[Most[l], Last[l]], Thread[Total[l] <= s - 1]}];
>>> finalQ[l_List] := And @@ Flatten[{Last[l] == Array[0 & , k] ||
>>> !MemberQ[Most[l], Last[l]], Thread[Total[l] == s - 1]}];
>>> space = DeleteCases[sp /@ (s - 1), Alternatives @@
>>> IdentityMatrix[k],
>>> Infinity]; k + Max[0, Length /@ DeleteCases[Backtrack
>>> [space, partialQ,
>>> finalQ, All], Array[0 & , k], Infinity]]]
>>>
>>> T[n_] := Block[{k = 1, $Messages},
>>> While[k++; FF[k*((k + 1)/2) - 1] < n, Null]; k*((k + 1)/2)]
>>>
>>> Map[T, Range[7]]
>>> {3, 15, 55, 253, 1081, 13861, 115921}
>>>
>>> which is what you expected?
>>>
>>> Andrzej Kozlowski
>>>
>>>
>>>
>>> On 7 Jul 2007, at 22:40, Diana Mecum wrote:
>>>
>>>> Andrzej,
>>>>
>>>> I appreciate all of the work you have done with my question.
>>>>
>>>> I tested this latest update, and got
>>>>
>>>> Map[T, Range[6]]
>>>> {3,15,91, 1431, 10011, 218791}
>>>>
>>>> The expect that the first 6 terms would be:
>>>>
>>>> {3,15,55,253,1081,13861}
>>>>
>>>> I used the first's e-mail code for T, and the second code for FF.
>>>>
>>>> Thanks,
>>>>
>>>> Diana
>>>>
>>>> On 7/7/07, Andrzej Kozlowski <akoz at mimuw.edu.pl> wrote: *This
>>>> message was transferred with a trial version of CommuniGate(tm)
>>>> Pro*
>>>> I did not intend to work any more on this code, because, as I wrote
>>>> earlier, it is certiany possible to implement the same idea much
>>>> faster wihtout using the Combinatorica package, but then I
>>>> noticed a
>>>> very blatant inefficiency in the posted code and felt obliged to
>>>> correect it. Here is the corrected version of the function FF. The
>>>> fucntion T is unchanged.
>>>>
>>>> Andrzej Kozlowski
>>>>
>>>> FF[n_] :=
>>>> Module[{u = FactorInteger[n], s, k, partialQ, finalQ, space, sp},
>>>> s = u[[All, 2]]; k = Length[u]; sp[m_] := Tuples[Range[0, m],
>>>> {k}];
>>>> partialQ[l_List] :=
>>>> And @@
>>>> Flatten[{Last[l] == Array[0 &, k] || Not[MemberQ[Most[l], Last
>>>> [l]]],
>>>> Thread[Total[l] <= s - 1]}];
>>>> finalQ[l_List] :=
>>>> And @@
>>>> Flatten[{Last[l] == Array[0 &, k] || Not[MemberQ[Most[l], Last
>>>> [l]]],
>>>> Thread[Total[l] == s - 1]}];
>>>> space =
>>>> DeleteCases[ sp /@ (s - 1), Alternatives @@ (IdentityMatrix
>>>> [k]),
>>>> Infinity];
>>>> k + Max[0,
>>>> Length /@
>>>> DeleteCases[Backtrack[space, partialQ, finalQ, All], Array
>>>> [0 &,
>>>> k],
>>>> Infinity]]]
>>>>
>>>>
>>>> On 6 Jul 2007, at 20:26, Andrzej Kozlowski wrote:
>>>>
>>>> > *This message was transferred with a trial version of CommuniGate
>>>> > (tm) Pro*
>>>> > On 3 Jul 2007, at 18:23, Diana wrote:
>>>> >
>>>> >> Math folks,
>>>> >>
>>>> >> I first generate a list of triangular numbers:
>>>> >>
>>>> >> 1, 3, 6, 10, 15, 21, ...
>>>> >>
>>>> >> and then subtract one from each as:
>>>> >>
>>>> >> 0, 2, 5, 9, 14, 20, ...
>>>> >>
>>>> >> I am trying to find the smallest triangular number (minus
>>>> one) which
>>>> >> can be written as a product of "n" distinct factors, each
>>>> factor > 1.
>>>> >>
>>>> >> For example:
>>>> >>
>>>> >> a(2) = 15, because 2*7 + 1 = 15.
>>>> >> a(3) = 55, because 2*3*9 + 1 = 55.
>>>> >>
>>>> >> I have worked with Divisors and FactorInteger, but am getting
>>>> bogged
>>>> >> down with repeated terms. Can someone think of a neat trick
>>>> to work
>>>> >> this problem?
>>>> >>
>>>> >> Diana M.
>>>> >>
>>>> >>
>>>> >
>>>> > I wil start with a grumble. Unfortunately your problem is not, in
>>>> > my judgment, solvable by means of any nice mathematics,
>>>> because you
>>>> > do not require the factors to be mutually prime, that is, not
>>>> to be
>>>> > divisible by the same prime. Without that one can't make use of
>>>> > uniqueness of prime decomposition and that in this kind of
>>>> problems
>>>> > generally means that brute force has to be used. (I have a much
>>>> > nicer solution of the same problem when the factors are
>>>> required to
>>>> > be mutually prime)
>>>> >
>>>> > So now I will present a 'brute force" argument, whose main virtue
>>>> > is that it can be much improved (but I will not do so). I will
>>>> use
>>>> > the combinatorica package, which, in Mathematica 6.0 is loaded
>>>> like
>>>> > this:
>>>> >
>>>> > << Combinatorica`
>>>> >
>>>> > I want to make use of the Backtrack function in this package.
>>>> (This
>>>> > is the main weakness of this approach and the point which can be
>>>> > greatly improved). Here is an auxiliary function, which uses
>>>> > backtracking:
>>>> >
>>>> > FF[n_] := Module[{u = FactorInteger[n], s, k, partialQ, finalQ,
>>>> > space, sp},
>>>> > s = u[[All,2]]; k = Length[u]; sp[m_] := Tuples[Range[0,
>>>> m], {k}];
>>>> > partialQ[l_List] := And @@ Flatten[
>>>> > { !MemberQ[IdentityMatrix[k], Last[l]], Last[l] == Array[0
>>>> > & , k] ||
>>>> > !MemberQ[Most[l], Last[l]], Thread[Total[l] <= s -
>>>> 1]}];
>>>> > finalQ[l_List] := And @@ Flatten[{ !MemberQ[IdentityMatrix
>>>> [k],
>>>> > Last[l]],
>>>> > Last[l] == Array[0 & , k] || !MemberQ[Most[l], Last[l]],
>>>> > Thread[Total[l] == s - 1]}]; space = sp /@ (s - 1);
>>>> > k + Max[0, Length /@ DeleteCases[Backtrack[space, partialQ,
>>>> > finalQ, All],
>>>> > Array[0 & , k], Infinity]]]
>>>> >
>>>> > For any positive integer n this computes the length of the
>>>> largest
>>>> > factorization of n into distinct factors. For example:
>>>> >
>>>> > FF[2*3*9*11]
>>>> > 4
>>>> >
>>>> > which is obviously right. There is some minor problem in the code
>>>> > that causes a Part error message to appear sometimes, without
>>>> > however affecting the result:
>>>> >
>>>> > FF[3]
>>>> > Part::partw:Part 2 of {1} does not exist. >>
>>>> > Part::partw:Part 2 of ( {
>>>> > {{0}}
>>>> > } ) does not exist. >>
>>>> > Set::partw:Part 2 of {1} does not exist. >>
>>>> > 1
>>>> >
>>>> > However, I don't to spend time on trying to find out the cause of
>>>> > this message so on my main program I will simply suppress all
>>>> > messages:
>>>> >
>>>> > So now here is the main function T:
>>>> >
>>>> > T[n_] := Block[{k = 1, $Messages}, While[k++; FF[k*((k + 1)/2)
>>>> - 1]
>>>> > < n,
>>>> > Null]; k*((k + 1)/2)]
>>>> >
>>>> > which for a given n looks for the smallest triangular number
>>>> with n-
>>>> > distinct factors:
>>>> >
>>>> > Map[T, Range[8]]
>>>> > {3, 15, 55, 253, 1081, 13861, 115921, 1413721}
>>>> >
>>>> > I can't say that this is really fast, but the good news is
>>>> that it
>>>> > certainly could be greatly improved. The Combinatorica general-
>>>> > purpose Backtrack function is very slow, and if someone writes a
>>>> > custom-made backtracking version suited to the problem at hand
>>>> and
>>>> > compiles it, it will certainly become orders of magnitude faster.
>>>> > This has been done on this list in various situations several
>>>> > times. Unfortunately I can't spare the time necessary to do
>>>> > this. . Writing backtracking programs requires careful
>>>> procedural
>>>> > programming and I am really out of practice in procedural
>>>> > programming, but there are several excellent examples in the
>>>> > archives written by Fred Simons and Maxim Rytin, and if this is
>>>> > important for you, you should either learn to do it yourself by
>>>> > studying these programs or persuade one of them to do it for
>>>> you ;-)
>>>> >
>>>> > Andrzej Kozlowski
>>>> >
>>>> >
>>>> > ------------------------------------------
>>>> > Your proposition may be good
>>>> > But let's have one thing understood --
>>>> > Whatever it is, I'm against it!
>>>> > And even when you've changed it or condensed it,
>>>> > I'm against it.
>>>> >
>>>> > Professor Quincy Adams Wagstaff
>>>> > President of Huxley College
>>>>
>>>>
>>>>
>>>>
>>>> --
>>>> "God made the integers, all else is the work of man."
>>>> L. Kronecker, Jahresber. DMV 2, S. 19.
>>>
>>
>
- References:
- Working with factors of triangular numbers.
- From: Diana <diana.mecum@gmail.com>
- Working with factors of triangular numbers.