Re: How to do quickest
- To: mathgroup at smc.vnet.net
- Subject: [mg116541] Re: How to do quickest
- From: "Sjoerd C. de Vries" <sjoerd.c.devries at gmail.com>
- Date: Sat, 19 Feb 2011 05:12:14 -0500 (EST)
- References: <ijdo9g$f8a$1@smc.vnet.net>
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