Mathematica 9 is now available
Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2011

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: How to do quickest

  • To: mathgroup at smc.vnet.net
  • Subject: [mg116579] Re: How to do quickest
  • From: Artur <grafix at csl.pl>
  • Date: Sun, 20 Feb 2011 05:27:16 -0500 (EST)

Thank You for procedure! On my computer
{12.312, {4996, 5781, 3361, 3449, 2653, 4055, 1360, 1249, 3360, 1321,
   2470, 412, 1103, 1114, 1652, 1129, 105, 102, 416, 206, 25,1}}

Bob try Your quickest steps combined with following which is still 
little quickest

{10.313, {4996, 5781, 3361, 3449, 2653, 4055, 1360, 1249, 3360, 1321,
   2470, 412, 1103, 1114, 1652, 1129, 105, 102, 416, 206, 25, 1}}

(*Daniel Lichtblau modified by Artur Jasinski*)

Timing[cc = {}; pol = x^8 - x - 1;
  nn = Length[CoefficientList[pol, x]] - 1;
  pp = IntegerPartitions[nn];
  Do[htab[pp[[j]]] = j, {j, Length[pp]}];
  aa = Table[0, {Length[pp]}];
  n = 1; cn = 0;
  While[cn < nn!, p = Prime[n];
   n++;
   kk = FactorList[pol, Modulus -> p];
   ww = Rest[Exponent[kk[[All, 1]], x]];
   ww = Reverse[Sort[ww]];
   pos = htab[ww];
   If[pos == 0, , cn++; aa[[pos]] = aa[[pos]] + 1]];
  aa]

{10.313, {4996, 5781, 3361, 3449, 2653, 4055, 1360, 1249, 3360, 1321,
   2470, 412, 1103, 1114, 1652, 1129, 105, 102, 416, 206, 25, 1}}

W dniu 2011-02-19 17:37, DrMajorBob pisze:
> This is easier to read, if no faster.
>
> Timing[
>  Clear[a, c];
>  pol = x^8 - x - 1;
>  nn = Length@CoefficientList[pol, x] - 1;
>  If[
>   IrreduciblePolynomialQ[pol],
>   a[i_] = {};
>   c[i_] := Length@Flatten[a@i];
>   pp = IntegerPartitions@nn;
>   b = FactorInteger[Discriminant[pol, x]][[All, 1]];
>   n = 1;
>   cn = 0;
>   While[cn < nn!, p = Prime@n;
>    If[! MemberQ[b, p],
>     cn++;
>     k = Reverse@Rest@FactorList[pol, Modulus -> p][[All, 1]];
>     w = Length@CoefficientList[#, x] - 1 & /@ k;
>     pos = Position[pp, w, 1, 1][[1, 1]];
>     a[pos] = {a[pos], p}];
>    n++]];
>  Array[c, Length@pp]
>  ]
>
> {10.8518, {4996, 5781, 3361, 3449, 2653, 4055, 1360, 1249, 3360, 1321,
>    2470, 412, 1103, 1114, 1652, 1129, 105, 102, 416, 206, 25, 1}}
>
> Bobby
>
> On Sat, 19 Feb 2011 04:12:14 -0600, Sjoerd C. de Vries 
> <sjoerd.c.devries at gmail.com> wrote:
>
>> Without changing the basic operation of your algorithm I've changed a
>> couple of details. The difference is not huge, but about 20% of speed
>> gain is still nice.
>>
>> pol = x^8 - x - 1;
>>  nn = Length[CoefficientList[pol, x]] - 1;
>>  If[IrreduciblePolynomialQ[pol],
>>   pp = IntegerPartitions[nn];
>>   aa = Table[{}, {n, 1, Length[pp]}]; Print[aa];
>>   ff = FactorInteger[Discriminant[pol, x]];
>>   bb = Table[ff[[n, 1]], {n, 1, Length[ff]}];
>>   n = 1;
>>   cn = 0;
>>   While[cn < nn!,
>>    p = Prime[n];
>>    If[MemberQ[bb, p],
>>     (*True*),
>>     cn++;
>>     kk = FactorList[pol, Modulus -> p];
>>     ww = Table[
>>       Length[CoefficientList[kk[[m, 1]], x]] - 1,
>>       {m, Length[kk], 2, -1}
>>       ];
>>     pos = Position[pp, ww, 1, 1][[1, 1]];
>>     aa[[pos]] = {aa[[pos]], p};
>>     ];
>>    n++
>>    ]
>>   ]; aa = Map[Flatten, aa, {1}];
>>  Table[Length[aa[[m]]], {m, 1, Length[aa]}]
>>  ]
>>
>>
>> Cheers -- Sjoerd
>>
>>
>> On Feb 15, 12:33 pm, Artur <gra... at csl.pl> wrote:
>>> Dear Mathematica Gurus,
>>> How to do following procedure quickest?
>>> (*start*)
>>> pol = x^8 - x - 1; nn = Length[CoefficientList[pol, x]] - 1; If[
>>>  IrreduciblePolynomialQ[pol], pp = IntegerPartitions[nn]; aa = {};
>>>  Do[AppendTo[aa, {}], {n, 1, Length[pp]}]; Print[aa];
>>>  ff = FactorInteger[Discriminant[pol, x]]; bb = {};
>>>  Do[AppendTo[bb, ff[[n]][[1]]], {n, 1, Length[ff]}]; n = 1; cn = 0;
>>>  While[cn < nn!, p = Prime[n];
>>>   If[MemberQ[bb, p], , cn = cn + 1;
>>>    kk = FactorList[pol, Modulus -> p]; ww = {};
>>>    Do[cc = Length[CoefficientList[kk[[m]][[1]], x]];
>>>     AppendTo[ww, cc - 1], {m, 2, Length[kk]}]; ww = Reverse[ww];
>>>    pos = Position[pp, ww][[1]][[1]]; AppendTo[aa[[pos]], Prime[n]]]=
>> ;
>>>   n++]]; Table[Length[aa[[m]]], {m, 1, Length[aa]}]
>>> (*end*)
>>> Best wishes
>>> Artur
>>
>>
>
>


  • Prev by Date: Re: problem with NDSolve::dvnoarg:
  • Next by Date: Re: How to do quickest
  • Previous by thread: Re: How to do quickest
  • Next by thread: Re: How to do quickest