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