Re: Working with factors of triangular numbers.
- To: mathgroup at smc.vnet.net
- Subject: [mg78740] Re: [mg78490] Working with factors of triangular numbers.
- From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Date: Sun, 8 Jul 2007 06:10:31 -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>
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.