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: [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
>>>
>>


  • Prev by Date: Re: DeveloperContextFreeForm and local symbols in packages (more)
  • Next by Date: Re: How to do quickest
  • Previous by thread: Re: How to do quickest
  • Next by thread: Re: How to do quickest