Re: Re: Working with factors of triangular numbers.
- To: mathgroup at smc.vnet.net
- Subject: [mg78806] Re: [mg78750] Re: [mg78490] Working with factors of triangular numbers.
- From: János <janos.lobb at yale.edu>
- Date: Tue, 10 Jul 2007 06:27:38 -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> <a851af150707072125o69edf471o4b5be8932a924a32@mail.gmail.com> <200707081015.GAA09600@smc.vnet.net>
In[101]:=
Reduce[{a1*a2*a3*a4*a5 + 1 ==
n*((n + 1)/2),
n*((n + 1)/2) < 1200,
1 < n, 1 < a1 < a2 < a3 <
a4 < a5}, {a1, a2, a3,
a4, a5, n}, Integers]
Out[101]=
a1 == 2 && a2 == 3 &&
a3 == 4 && a4 == 5 &&
a5 == 9 && n == 46
In[6]:=
$Version
Out[6]=
"5.2 for Mac OS X (64 bit) \
(June 20, 2005)"
The above one is a VERY slow newbie code, so I would not use it for
anything, only to verify that 1081 is the right number.
J=E1nos
On Jul 8, 2007, at 6:15 AM, Andrzej Kozlowski wrote:
> You are quite right. I have checked it and can now confirm that my
> code works correctly with Mathematica 6 but not with Mathematica 5.2.
> Indeed, with exactly the same definitions I get:
>
>
> $Version
> "6.0 for Mac OS X PowerPC (32-bit) (April 20, 2007)"
>
> T[5]
> 1081
>
> but
>
> $Version
>
> 5.2 for Mac OS X (February 24, 2006)
>
> T[5]
>
> 10011
>
> which is completely wrong. There seems to be some very fundamental
> difference between Mathematica 5.2 and Mathematica 6. I don't think
> the diffeence is between the Backtrack functions in the Combinatrica
> packages, because I used the old one a number of times in the past
> and it worked fine. I have to admit that at the moment I am
> completely baffled. Although I can't right now devote much more time
> to this problem, I think finding out what it is that makes the
> difference here is important. I can now see that the difference lies
> in the function FF. For example, in Mathematica 6:
>
> FF[576]
> 4
>
> but in Mathematica 5.2:
>
>
>
> FF[576]
>
> "Nonatomic expression expected at position `1` Thread[False]
>
> 2
>
> It suggests that the difference may lie in error handling. I hope
> someone reading this will see where the problem lies and let us know.
> If not, I will try to discover it myself, but it won't be very soon.
> I don't think this alone is quite good enough reason to upgrade to
> version 6, but there are plenty of better ones and that would solve
> your immediate problem ;-)
>
> Andrzej Kozlowski
>
>
>
>
>
>
> On 8 Jul 2007, at 13:25, Diana Mecum wrote:
>
>> Andrzej,
>>
>> I copied your code verbatim, except for DiscreteMath Combinatorica.
>>
>> With Mathematica 5.2, a pc and a fresh kernel, I get:
>>
>> <<DiscreteMath`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,91,1431,10011,218791,8378371}
>>
>> Diana M.
>>
>> On 7/7/07, Andrzej Kozlowski <akoz at mimuw.edu.pl> wrote: *This
>> message was transferred with a trial version of CommuniGate(tm) Pro*
>> 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.
>>
>>
>>
>>
>> --
>> "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>
- Re: Working with factors of triangular numbers.
- From: Andrzej Kozlowski <akoz@mimuw.edu.pl>
- Working with factors of triangular numbers.