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