Re: How to do quickest

*To*: mathgroup at smc.vnet.net*Subject*: [mg116593] Re: How to do quickest*From*: Artur <grafix at csl.pl>*Date*: Mon, 21 Feb 2011 04:20:52 -0500 (EST)

Dear Mathematica Gurus, To working Galois prcedure up to 16 degree is necessary dynamical procedure (independent from order of polynomials, n-set of roots resolvent and operation + or *. I'm too poor programist yet to write these. Could You help me? Also in case that pattern of factorization will be contained any square factors will be necessary to convert them on square free patern by brutal opertaion (deg of factor)*power Input variable: pol ,deg, nnn n-set, operation e.g. 0 for + , 1 for * In particular case sample procedure is order dynamic, 2 root resolvents fixed, operation + fixed (I need both three dynamic) (*2 root resolvent +*) p = x9 - 9*x7 - 21*x6 + 72*x5 + 99*x4 - 99*x3 - 585*x2 + 549*x + 166;; deg = Length[CoefficientList[p, x]] - 1; k = N[x /. Solve[p == 0, x], 300]; pol = 1; aa = {}; Do[ Do[pol = pol (x - (k[[m]] + k[[n]])), {m, n + 1, deg}], {n, 1, deg - 1}]; kk = Round[CoefficientList[Expand[pol], x]]; pl = 0; Do[ pl = pl + kk[[n]] x^(n - 1), {n, 1, Length[kk]}]; Factor[pl] (*3 set roots resolventi with * operation*) p = x9 - 9*x7 - 21*x6 + 72*x5 + 99*x4 - 99*x3 - 585*x2 + 549*x + 166; deg = Length[CoefficientList[p, x]] - 1; k = N[x /. Solve[p == 0, x], 300]; pol = 1; aa = {}; Do[ Do[Do[pol = pol (x - (k[[m]] * k[[n]] * k[[r]])), {r, m + 1, deg}], {m, n + 1, deg - 1}], {n, 1, deg - 2}]; kk = Round[CoefficientList[Expand[pol], x]]; pl = 0; Do[ pl = pl + kk[[n]] x^(n - 1), {n, 1, Length[kk]}]; Factor[pl] Who know how is upper limitation for order of polynomial to function Factor or FactorList on integer coefficients polynomial in Mathematica (or is unlimited with only one limitation memory of computer)? My sample code of new function of Mathematica Galois is following (this sample counts Galois groups of polynomials up to order 5) : Galois[pol_, var_] := Module[{coeff, dim, n, x, pr, ls, pom, mroot, gr, data, dd, sp, sps, d, contr, j, pos, cn, p, nn}, If[IrreduciblePolynomialQ[pol], coeff = CoefficientList[pol, var]; dim = Length[coeff] - 1; If[coeff[[dim + 1]] < 0, Do[coeff[[n]] = - coeff[[n]], {n, 1, dim + 1}]]; contr = True; If[dim == 2, gr = 1, data = Sqrt[Discriminant[pol, var]]; sp = data /. Sqrt[_] -> 1; sps = data/sp; If[sps == 1, d = 1, d = 0]; If[dim == 3, If[d == 1, gr = 1, gr = 2], pp = IntegerPartitions[dim]; Do[htab[pp[[j]]] = j, {j, Length[pp]}]; aa = Table[0, {Length[pp]}]; nn = 1; cn = 0; While[cn < 4096, p = Prime[nn]; nn++; kk = FactorList[pol, Modulus -> p]; ww = Rest[Exponent[kk[[All, 1]], var]]; ww = Reverse[Sort[ww]]; pos = htab[ww]; If[pos == 0, Print[p], cn++; aa[[pos]] = aa[[pos]] + 1]]; Print[aa]; Print[d]; If[dim == 4, If[d == 1, If[aa[[2]] == 0, gr = 2, gr = 4], If[aa[[2]] == 0, If[aa[[4]] == 0, gr = 1, gr = 3], gr = 5]], If[dim == 5, If[d == 1, If[aa[[5]] == 0, gr = 1, If[aa[[4]] == 0, gr = 2, gr = 4]], If[aa[[4]] == 0, gr = 3, gr = 5]]](*!*), contr = False; Print["Not implemented yet"]]]; If[contr == True, Print["Galois transitive group : ", dim, "T", gr]]], Print["Reducible polynomial ", Factor[pol]]]]; (*Sample polynomial*) Galois[#1^5-#1-1,#1] In the future will be necessary yet one dynamical parametr accuracy because in case very big coefficients precission 300 will be not sufficient (but I don't have idea how control this yet but I'm thinking (probably if patern will be wrong (anyone from expected will be necessary to twice accuracy.. I don't expand them on higher orders yet because in case more than one variable polynomials this algorhitm will be useless because not possibility count disriminant in such case and is necessary rebuild them on algorhitm which will be don't use information if Sqrt[Discriminant]] is perfect square or not. I will be greatfull for help and rebuild my statical procedure on dynamical which is absolutely necessary start from order 8 which is smallest order where algorithm of Lenstra-Czebotaryev (my previosly ask about help in message How to do quickest) is not sufficient to exact determination of Galois groups. Follow finish algorhitm determination of Galois grups will be available to write next to solving polynomials higher degree as 4 for radicals. Best wishes Artur W dniu 2011-02-20 11:27, Artur pisze: > 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 >>> >>