Re: Working with factors of triangular numbers.
- To: mathgroup at smc.vnet.net
- Subject: [mg78766] Re: [mg78490] Working with factors of triangular numbers.
- From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Date: Mon, 9 Jul 2007 01:33:13 -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> <EC981B8F-E91E-4CB7-A4C2-030EE8C5F319@mimuw.edu.pl> <B9DF7620-D7E2-49D7-B44E-619C8EB636BF@mimuw.edu.pl> <a851af150707080555r966885cl6a03f44f637ac3ef@mail.gmail.com> <a851af150707080608u4040f2a8y5368c781342d05c1@mail.gmail.com> <a851af150707080617s436ad717uc39e1e68cb974315@mail.gmail.com>
Well, I stayed up longer than I wanted and I think I have now fixed
it, I hope for the final time. Here is the new FF:
FFF[n_] := Module[{u = FactorInteger[n], s, k, partialQ, finalQ, space},
s = u[[All,2]]; k = Length[u]; 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]], Total[l] == s - 1}];
space = Table[DeleteCases[Tuples[(Range[0, #1] & ) /@ (s - 1)],
Alternatives @@ IdentityMatrix[k], Infinity], {k}];
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)]
This gives the right answers for the first 8 values and in particular:
T[8]
665281
I am pretty sure it now works fine! ;-))
Andrzej
On 8 Jul 2007, at 22:17, Diana Mecum wrote:
> Andrzej,
>
> Please disregard my last e-mail.
>
> The eighth term of the sequence should be 665281
>
> 665280 = 11*7*5*3*9*2*4*8
>
> Diana
>
> On 7/8/07, Diana Mecum <diana.mecum at gmail.com> wrote: Andrzej,
>
> I appreciate all of your work. I have stopped working on this problem,
>
> The best first 8 terms I have at this point are:
>
> 3,15,55,253,1081,13861,138601,665281
>
> The first 8 terms I get with your algorithm are:
>
> 3,15,55,253,1081,13861,115921,1413721
>
> 115921 = 13 * 37 * 241, which does not fit the rule.
>
> I would be interested in any further information you would have,
> but also would understand your not wanting to take further time
> with this.
>
> Thanks again,
>
> Diana M.
>
>
> On 7/8/07, Diana Mecum < diana.mecum at gmail.com> wrote: Hi Andrzej,
>
> I knew you would find it! You're the best :-)
>
> Thanks,
>
> Diana
>
>
> On 7/8/07, Andrzej Kozlowski < akoz at mimuw.edu.pl> wrote:*This
> message was transferred with a trial version of CommuniGate(tm) Pro*
> Well, I have found it! First of all the solution to the problem:
> replace the defintion of FF by the following one:
>
>
> 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]], 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 can remain unchanged. (Can you see the difference between the
> codes?)
>
> The difference between Mathematica 5.2 and Mathematica 6 which caused
> this behaviour can be seen here:
>
> Mathematica 5.2 :
>
>
> Thread[False]
>
> "Nonatomic expression expected at position`1 in Thread[False]"
>
> Thread[False]
>
>
> However, in Mathematica 6 we get:
>
> Thread[False]
> False
>
> which is much better. This is, of course, a difference in "error
> handling" as I put it when I was speculating about it becaause Thread
> [False] should never actually occur (and it does not if we make the
> change I made in the code I am now sending).
>
> So I hope now everything will work fine for you.
>
> Andrzej Kozlowski
>
>
>
>
>
>
> On 8 Jul 2007, at 14:40, Andrzej Kozlowski wrote:
>
> > *This message was transferred with a trial version of CommuniGate
> > (tm) Pro*
> > 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.
> >
>
>
>
>
> --
>
> "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.
>
>
>
> --
> "God made the integers, all else is the work of man."
> L. Kronecker, Jahresber. DMV 2, S. 19.
- Follow-Ups:
- Re: Re: Working with factors of triangular numbers.
- From: Carl Woll <carlw@wolfram.com>
- Re: Re: Working with factors of triangular numbers.
- References:
- Working with factors of triangular numbers.
- From: Diana <diana.mecum@gmail.com>
- Working with factors of triangular numbers.