Re: How to do quickest
- To: mathgroup at smc.vnet.net
- Subject: [mg116578] Re: How to do quickest
- From: DrMajorBob <btreat1 at austin.rr.com>
- Date: Sun, 20 Feb 2011 05:27:05 -0500 (EST)
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
>
>
--
DrMajorBob at yahoo.com