1
$\begingroup$

I have downloaded Galois theory package from http://library.wolfram.com/infocenter/Articles/2872/ and I currently have Mathematica v 12.0.

When I loaded the module (I needed to delete the blue stuff in the beginning for it to work properly), I entered these commands into notepad:

Define[a^3, 2]
Define[b^2, -a^2-ab]
Factor[x^3-2, a, b]

As per the notebook file, this should output

(-a + X) (-b + X) (a + b + X)

But this is outputting

(-a+X)(a^2+ax+x^2)

Why ?

(Also when I load the package, it's showing some errors like Tag Norm in Norm[Poly_, a Symbol] is protected])

I am a complete noob in mathematica so don't bash me if this turns out to be a trivial issue.

| improve this question | | | | |
$\endgroup$
  • 1
    $\begingroup$ Just a guess, but I suspect you want ab to mean a*b in which case there should be either a space or an explicit multiplication (the asterisk) in that second Define. $\endgroup$ – Daniel Lichtblau Aug 27 '19 at 15:18
1
$\begingroup$

That's because the names of some functions in this package conflict with the names of system built-in functions. (In particular, the Factor function in this function package)

$FilledCircle = "\(CenterDot)";
If[$VersionNumber >= 3.0, $FilledCircle = "\[FilledSmallCircle]";
  BaseStyle = {"Courier-New", 12}, 
  Format[CenterDot[x_, y_]] := StringForm["``  ``", x, y];];

Module[{i}, ClearAll[ZerosList$];
 For[i = 1, i <= Length[UsedSymbols], i++, 
  ClearAll[Evaluate[UsedSymbols[[i]]]]];
 UsedSymbols = {};]


Define[a_Symbol^n_Integer, b_] := 
 Module[{i}, UsedSymbols = Union[UsedSymbols, {a}];
   a /: a^n := b;
   For[i = n + 1, i <= 2 n, i++, 
    a /: a^i := Evaluate[FixedPoint[Expand, (a^(i - 1)) a]]];
   a /: a^m$_ := 
    FixedPoint[Expand, (a^(2 n)) (a^(m$ - 2 n))] /; m$ > 2 n] /; n > 1

Define[a_, a_] := Print["Rule already defined."]

Define[F_Symbol[a_], b_] := Module[{}, F[a] := b;] /; UnsameQ[F[a], b]

Homomorph::usage = 
  "Homomorph[F] defines F to be a homomorphism between two
      fields M and K.";

Homomorph[F_Symbol] := 
  Module[{}, UsedSymbols = Union[UsedSymbols, {F}];
   ClearAll[Evaluate[F]];
   F[a$_ b$_] := FixedPoint[Expand, F[a$] F[b$]];
   F[a$_ + b$_] := F[a$] + F[b$];
   F[a$_^b$_Integer] := FixedPoint[Expand, F[a$]^b$];
   F[a$_Integer] := a$;
   F[a$_Rational] := a$;];

SetAttributes[Homomorph, HoldAll];

CheckHomo::usage = "CheckHomo[F,D] verifies that F is a homomorphism
     with a domain of D. Note that only a basis of the field D must \
be given.";

CheckHomo[f_, D_List] := 
 Module[{i, j}, 
  For[i = Length[D], i > 0, i--, 
   For[j = Length[D], j > 0, j--, 
    If[FixedPoint[Expand, f[D[[i]]] f[D[[j]]] - f[D[[i]] D[[j]]]] =!= 
      0, Print["f[", D[[i]], "] * f[", D[[j]], "] is not equal to f[",
       D[[i]], "*", D[[j]], "]"];
     Return[False]];
    If[f[D[[i]]] + f[D[[j]]] =!= f[D[[i]] + D[[j]]], 
     Print["f[", D[[i]], "] + f[", D[[j]], "] is not equal to f[", 
      D[[i]] + D[[j]], "]"];
     Return[False]]]];
  Return[True]]

ClearDefs::usage = 
  "ClearDefs resets all definitions created by this notebook.";

ClearDefs := Module[{j}, Unprotect[Plus];
  SetAttributes[Plus, Listable];
  Protect[Plus];
  ClearAll[ZerosList$];
  For[j = 1, j <= Length[UsedSymbols], j++, 
   ClearAll[Evaluate[UsedSymbols[[j]]]]];
  UsedSymbols = {};]

Group::usage = 
  "Group[X_List] gives a list of elements of the group                
      symbolically presented by the set of generators X and           \

      the inference rules previously defined.";

Group[G_List] := Module[{m, n, i, j, g, Repeat}, g = Union[G];
  m = Length[g];
  Repeat = True;
  While[Repeat, Repeat = False;
   n = Length[g];
   Do[Do[If[MemberQ[g, CenterDot[g[[i]], g[[j]]]], , Repeat = True;
      g = Append[g, CenterDot[g[[i]], g[[j]]]]], {i, 1, n}], {j, 1, 
     m}]];
  Sort[g]]

ToStr[x_] := 
 StringJoin[
  Select[Characters[
    ToString[
     If[MemberQ[ToCharacterCode[ToString[x]], 10], InputForm[x], 
      x]]], # =!= " " &]]

ColorTable := {RGBColor[1, 1, 0], RGBColor[1, 0, 1], 
   RGBColor[0, 1, 1], RGBColor[1, 0, 0], RGBColor[0, 1, 0], 
   RGBColor[.6, .4, .8], RGBColor[1, .6, 0], RGBColor[.7, .8, .7], 
   RGBColor[.8, .6, .5], RGBColor[.5, .6, .8], RGBColor[.8, .2, .5], 
   RGBColor[.8, .6, .2], RGBColor[.6, .6, .2], RGBColor[1, .4, .4], 
   RGBColor[.2, .8, .7], RGBColor[1, .6, 1], RGBColor[.7, 1, 0], 
   RGBColor[0, 0, 1], RGBColor[.6, .4, .4], RGBColor[0, .6, 1], 
   RGBColor[1, .8, .7], RGBColor[.4, .2, 1], RGBColor[1, .8, .4], 
   RGBColor[.2, .6, .4], RGBColor[.5, .8, .8], RGBColor[.4, .8, .5], 
   RGBColor[0, 1, .6], RGBColor[.8, .5, .2], RGBColor[.2, .2, .9]};

SubSetPosition[Q_List, S_] := 
  Module[{i, j}, If[Head[S] === List, j = 0;
    For[i = 1, i <= Length[Q], i++, 
     If[Complement[S, Q[[i]]] === {}, j = i; i = Length[Q]]], 
    If[MemberQ[Q, S], j = Position[Q, S, 1][[1]][[1]], j = 0]];
   j];

MultTable::usage = 
  "MultTable[X_List] gives a multiplication table of the elements     \

      in the list, using different colors for different elements.     \

      The list can have no more than 27 elements.";

MultTable[Q_List] := 
 Module[{i, j, T}, 
  If[Length[Q] > 27, Print["Group too big to print table."], 
   T = Table[
     If[i === 0, If[j === 0, RGBColor[1, 1, 1], ColorTable[[j]]], 
      If[j === 0, ColorTable[[i]], 
       If[MemberQ[Q, CenterDot[Q[[i]], Q[[j]]]], 
        ColorTable[[
         Position[Q, CenterDot[Q[[i]], Q[[j]]], 1][[1]][[1]]]], 
        RGBColor[0, 0, 0]]]], {i, Length[Q], 0, -1}, {j, 0, 
      Length[Q]}];
   If[Max[
       Table[Length[Characters[ToStr[Q[[i]]]]], {i, 1, 
         Length[Q]}]]*(Length[Q] + 1) < 85, 
    Show[Graphics[RasterArray[T]], 
     Graphics[
      Table[Text[ToStr[Q[[i]]], {i + .5, Length[Q] + .5}], {i, 1, 
        Length[Q]}]], 
     Graphics[
      Table[Text[ToStr[Q[[j]]], {.5, Length[Q] - j + .5}], {j, 1, 
        Length[Q]}]], 
     Graphics[
      Table[Text[
        If[MemberQ[Q, CenterDot[Q[[i]], Q[[j]]]], 
         ToStr[CenterDot[Q[[i]], Q[[j]]]], " "], {j + .5, 
         Length[Q] - i + .5}], {i, 1, Length[Q]}, {j, 1, Length[Q]}]],
      Graphics[
      Line[{{1, 0}, {1, Length[Q]}, {Length[Q] + 1, Length[Q]}}]]], 
    Show[Graphics[RasterArray[T]], 
     Graphics[
      Table[Text[
        ToStr[Q[[i]]], {-.5, Length[Q] - i + .5}, {1, 0}], {i, 1, 
        Length[Q]}]], 
     Graphics[
      Line[{{1, 0}, {1, Length[Q]}, {Length[Q] + 1, Length[Q]}}]], 
     AspectRatio -> Automatic, PlotRange -> All]]]]

ArrowG[Color_, {{x1_, y1_}, {x2_, y2_}}] := 
 Module[{dx, dy, Len}, dx = x2 - x1;
  dy = y2 - y1;
  Len = N[Sqrt[dx N[dx] + dy N[dy]]];
  If[Len + 0. =!= 0., {Color, Line[{{N[x1], N[y1]}, {N[x2], N[y2]}}], 
    Polygon[{{N[x2], N[y2]}, {N[x2 - (.1 dx + .05 dy)/Len], 
       N[y2 - (.1 dy - .05 dx)/Len]}, {N[x2 - (.1 dx - .05 dy)/Len], 
       N[y2 - (.1 dy + .05 dx)/Len]}}]}, 
   Len = N[Sqrt[2 x2 N[x2] + 2 y2 N[y2]]];
   dx = x2/Len;
   dy = y2/Len;
   {Color, 
    Line[{{N[x2 - .1 dy - .1 dx], 
       N[y2 + .1 dx - .1 dy]}, {N[x2 - .1307 dy - .1459 dx], 
       N[y2 + .1307 dx - .1459 dy]}, {N[x2 - .2 dx - .1414 dy], 
       N[y2 - .2 dy + .1414 dx]}, {N[x2 - .1307 dy - .2541 dx], 
       N[y2 + .1307 dx - .2541 dy]}, {N[x2 - .1 dy - .3 dx], 
       N[y2 + .1 dx - .3 dy]}, {N[x2 - .0541 dy - .3307 dx], 
       N[y2 + .0541 dx - .3307 dy]}, {N[x2 - .3413 dx], 
       N[y2 - .3414 dy]}, {N[x2 + .0541 dy - .3307 dx], 
       N[y2 - .0541 dx - .3307 dy]}, {N[x2 + .1 dy - .3 dx], 
       N[y2 - .1 dx - .3 dy]}, {N[x2 + .1307 dy - .2541 dx], 
       N[y2 - .1307 dx - .2541 dy]}, {N[x2 - .2 dx + .1414 dy], 
       N[y2 - .2 dy - .1414 dx]}, {N[x2 + .1307 dy - .1459 dx], 
       N[y2 - .1307 dx - .1459 dy]}, {N[x2 + .1 dy - .1 dx], 
       N[y2 - .1 dx - .1 dy]}, {N[x2], N[y2]}}], 
    Polygon[{{N[x2], N[y2]}, {N[x2 - .15 dy - .05 dx], 
       N[y2 + .15 dx - .05 dy]}, {N[x2 - .05 dy - .15 dx], 
       N[y2 + .05 dx - .15 dy]}}]}]]

CircleGraph[G_, F_] := 
 Module[{T, L, n, i, j, k, m, Q, S}, S = ToStr[Hold[G]];
  m = StringPosition[S, {"{", ",", "}"}];
  If[m === {}, S = ToStr[ReleaseHold[G]];
   m = StringPosition[S, {"{", ",", "}"}]];
  L = Length[G];
  If[m === {}, L = 0];
  T = {};
  For[i = 1, i <= L, i++, If[Position[T, i] === {}, Q = {i};
    j = Position[ReleaseHold[G], ReleaseHold[F[G[[i]]]]];
    If[j === {}, j = i, j = j[[1]][[1]]];
    While[Position[Union[Q, T], j] === {}, AppendTo[Q, j];
     j = Position[ReleaseHold[G], ReleaseHold[F[G[[j]]]]];
     If[j === {}, j = i, j = j[[1]][[1]]]];
    AppendTo[T, Q]]];
  Show[Graphics[{{ColorTable[[3]], Circle[{0, 0}, 1]}, 
     Table[Text[
       Style[$FilledCircle, {"Symbol", 18}], {Sin[2 Pi n/N[L]], 
        Cos[2 Pi n/N[L]]}, {.1, 0}], {n, 1, L}], 
     Text[StringTake[S, {m[[1]][[1]] + 1, m[[2]][[1]] - 1}], {0, 
       1.1}, {0, -1}], 
     If[EvenQ[L], 
      Text[StringTake[
        S, {m[[1 + Quotient[L, 2]]][[1]] + 1, 
         m[[2 + Quotient[L, 2]]][[1]] - 1}], {0, -1.1}, {0, 1}], {}], 
     Table[
      Text[StringTake[
        S, {m[[n + 1]][[1]] + 1, 
         m[[n + 2]][[1]] - 1}], {Sin[2 Pi n/N[L]]*1.1, 
        Cos[2 Pi n/N[L]]*1.1}, {-1, 0}], {n, 1, Quotient[L - 1, 2]}], 
     Table[Text[
       StringTake[
        S, {m[[n + 1]][[1]] + 1, 
         m[[n + 2]][[1]] - 1}], {Sin[2 Pi n/N[L]]*1.1, 
        Cos[2 Pi n/N[L]]*1.1}, {1, 0}], {n, Quotient[L + 2, 2], 
       L - 1}], Table[Table[n = T[[k]][[j]] - 1;
       i = Position[ReleaseHold[G], ReleaseHold[F[G[[n + 1]]]]];
       If[
        i === {}, {Text[Style["?", {"Symbol", 18}], {0, 0}], 
         ArrowG[ColorTable[[
           3 + k]], {{Sin[2 Pi n/N[L]], 
            Cos[2 Pi n/N[L]]}, {.1 Sin[2 Pi n/N[L]], .1 Cos[
              2 Pi n/N[L]]}}]}, i = i[[1]][[1]] - 1;
        ArrowG[
         ColorTable[[
          3 + k]], {{Sin[2 Pi n/N[L]], 
           Cos[2 Pi n/N[L]]}, {Sin[2 Pi i/N[L]], 
           Cos[2 Pi i/N[L]]}}]], {j, 1, Length[T[[k]]]}], {k, 1, 
       Length[T]}]}, AspectRatio -> Automatic, PlotRange -> All]]]

SetAttributes[CircleGraph, HoldFirst];

ToVector[Q_] := Module[{i, L, X, T}, X = Expand[Q];
  If[Head[X] =!= Plus, X = {X}];
  L = Length[X];
  T = {};
  For[i = 1, i <= L, i++, 
   If[NumberQ[X[[i]]], 
    If[Head[X[[i]]] === Complex, 
     If[Re[X[[i]]] =!= 0, AppendTo[T, {Re[X[[i]]], 1}]];
     AppendTo[T, {Im[X[[i]]], I}], AppendTo[T, {X[[i]], 1}]], 
    If[Head[X[[i]]] =!= Times, AppendTo[T, {1, X[[i]]}], 
     If[NumberQ[X[[i]][[1]]], 
      AppendTo[T, {X[[i]][[1]], X[[i]]/X[[i]][[1]]}], 
      AppendTo[T, {1, X[[i]]}]]]]];
  T]

Vectorize[x_, y_List] := 
 Module[{i, j, Y, M, L, Q, T, Z, Vars}, Vars = {};
  Y = Append[y, x];
  M = Length[Y];
  For[j = 1, j <= M, j++, 
   Vars = Union[Vars, Transpose[ToVector[Y[[j]]]][[2]]]];
  L = Length[Vars];
  Q = {};
  For[i = 1, i <= M, i++, T = ToVector[Y[[i]]];
   Z = Table[0, {j, 1, L}];
   For[j = 1, j <= Length[T], j++, 
    Z[[Position[Vars, T[[j]][[2]]][[1]][[1]]]] = T[[j]][[1]]];
   AppendTo[Q, Z]];
  Q = RowReduce[Transpose[Q]];
  T = {};
  i = 1;
  For[j = 1, j < M, j++, 
   If[(i > L) || (Q[[i, j]] === 0), AppendTo[T, 0], 
    AppendTo[T, Q[[i, M]]];
    i++]];
  If[(i > L) || Q[[i, M]] === 0, T, NotInSpan]]

GeneratorReduce[Basis_List] := 
 Module[{i, j}, Bas = Union[DeleteCases[Basis, 0]];
  M = Length[Bas];
  Vars = {};
  For[j = 1, j <= M, j++, 
   Vars = Union[Vars, Transpose[ToVector[Bas[[j]]]][[2]]]];
  L = Length[Vars];
  T = Table[Vectorize[Bas[[j]], Vars], {j, 1, M}];
  If[(Flatten[DeleteCases[T, _Integer, 2]] === {}) && (Length[
       Union[Bas, Vars]] === M), Bas = Vars];
  Bas]

NormG[Poly_, a_Symbol] := 
 Module[{Pol, i, j, k, n, T, gg, Temp}, Pol = FixedPoint[Expand, Poly];
  n = 1;
  While[Exponent[a^n, a] === n, n++];
  If[((Variables[a^n] === {a}) || (Variables[
         a^n] === {})) && (Coefficient[Poly /. i_Rational -> j, j] ===
       0), QuickNorm[Poly, a], T = {};
   Temp = Sum[gg[i] a^i, {i, 0, n - 1}];
   For[i = 0, i < n, i++, 
    AppendTo[T, 
     Table[Coefficient[FixedPoint[Expand, Temp (a^i)], a, j], {j, 0, 
       n - 1}]]];
   Temp = Expand[Det[T]];
   For[i = 0, i < n, i++, 
    Temp = Temp /. gg[i] -> Coefficient[Pol, a, i]];
   FixedPoint[Expand, Temp]]]

NormG[Poly_, {a__Symbol}] := Module[{i, Temp}, Temp = Poly;
  For[i = Length[{a}], i > 0, i--, Temp = NormG[Temp, {a}[[i]]]];
  Temp]

QuickNorm[Poly_, a_Symbol] := 
 Module[{Y, Z, i, n}, If[Head[ZerosList$[a]] =!= List, n = 1;
   While[Exponent[a^n, a] === n, n++];
   Z = NSolve[Y^n == (a^n /. a -> Y), Y, 100];
   If[Length[Z] === n, 
    ZerosList$[a] = Table[Z[[i]][[1]][[2]], {i, 1, n}], 
    Print["The extension variable is not defined properly."]];];
  Z = Expand[
    Product[Poly /. a -> ZerosList$[a][[i]], {i, 1, 
      Length[ZerosList$[a]]}]];
  Z = Z /. i_Complex -> Round[i];
  Z = Z /. i_Real -> Round[i]]

UnNorm[Poly_, nn_Symbol, X_Symbol, a_Symbol] := 
 Module[{Big, B, i, j, k, q, Z, d1, n, m, d, Y, Prod, Temp, T}, B = {};
  Big = {};
  n = 1;
  While[Exponent[a^n, a] === n, n++];
  If[Poly[[0]] === Times, Prod = Poly, Prod = {Poly}];
  Prod[[0]] = List;
  m = 1;
  For[k = 1, k <= Length[Prod], k++, 
   m = Max[m, Exponent[Prod[[k]], X]/n]];
  T = 1;
  If[m > 1, T = NormG[X - a, a]];
  For[k = 1, k <= m, k++, B = {};
   For[i = 0, i < n, i++, Temp = NormG[(X - nn a)^k + a^i, a];
    AppendTo[B, 
     Table[Coefficient[Coefficient[Temp, nn, k*n - k - j], X, j], {j, 
       0, n - 1}]]];
   AppendTo[Big, B];];
  For[k = 1, k <= Length[Prod], k++, m = Exponent[Prod[[k]], X]/n;
   Prod[[k]] = Prod[[k]]/Coefficient[Prod[[k]], X, m*n];
   Temp = X^m;
   For[i = 1, i <= m, i++, 
    Z = Coefficient[Prod[[k]] /. X -> X nn, nn, n*m - i];
    If[i > 1, 
     Z = Z - Coefficient[NormG[Temp /. X -> (nn X - nn a), a], nn, 
        n*m - i]];
    Z = PolynomialQuotient[Z, T^(m - i), X];
    d1 = Table[Coefficient[Z, X, j], {j, 0, n - 1}];
    d = Transpose[RowReduce[Transpose[Append[Big[[i]], d1]]]][[n + 1]];
    Temp = Temp + Sum[d[[j]] a^(j - 1)*X^(m - i), {j, 1, n}];];
   Prod[[k]] = Temp];
  Prod[[0]] = Times;
  Prod]

UnNorm[Poly_, nn_Symbol, X_Symbol, w_, {a__Symbol}] := 
 Module[{Big, B, i, j, k, q, Z, d1, n, m, d, L, Y, Prod, Temp, T, 
   Bas}, B = {};
  Big = {};
  L = {a};
  Bas = {1};
  For[i = 1, i <= Length[L], i++, n = 1;
   While[Exponent[L[[i]]^n, L[[i]]] === n, n++];
   Bas = Flatten[
     Table[L[[i]]^k Bas[[j]], {k, 0, n - 1}, {j, 1, Length[Bas]}]];];
  n = Length[Bas];
  If[Poly[[0]] === Times, Prod = Poly, Prod = {Poly}];
  Prod[[0]] = List;
  m = 1;
  For[k = 1, k <= Length[Prod], k++, 
   m = Max[m, Exponent[Prod[[k]], X]/n]];
  T = 1;
  If[m > 1, T = NormG[X - w, L]];
  For[k = 1, k <= m, k++, B = {};
   For[i = 1, i <= n, i++, Temp = NormG[(X - nn w)^k + Bas[[i]], L];
    AppendTo[B, 
     Table[Coefficient[Coefficient[Temp, nn, k*n - k - j], X, j], {j, 
       0, n - 1}]]];
   AppendTo[Big, B];];
  For[k = 1, k <= Length[Prod], k++, m = Exponent[Prod[[k]], X]/n;
   Prod[[k]] = Prod[[k]]/Coefficient[Prod[[k]], X, m*n];
   Temp = X^m;
   For[i = 1, i <= m, i++, 
    Z = Coefficient[Prod[[k]] /. X -> X nn, nn, n*m - i];
    If[i > 1, 
     Z = Z - Coefficient[NormG[Temp /. X -> (nn X - nn w), L], nn, 
        n*m - i]];
    Z = PolynomialQuotient[Z, T^(m - i), X];
    d1 = Table[Coefficient[Z, X, j], {j, 0, n - 1}];
    d = Transpose[RowReduce[Transpose[Append[Big[[i]], d1]]]][[n + 1]];
    Temp = Temp + Sum[d[[j]] Bas[[j]]*X^(m - i), {j, 1, n}];];
   Prod[[k]] = Temp];
  Prod[[0]] = Times;
  Prod]

SimpleExtension[a__Symbol] := 
 Module[{L, i, j, k, n, w, p, Bas, d, pp, M}, L = {a};
  Bas = {1};
  w = Sum[L[[i]], {i, 1, Length[L]}];
  p = 1;
  d = 1;
  For[i = 1, i <= Length[L], i++, n = 1;
   While[Exponent[L[[i]]^n, L[[i]]] === n, n++];
   Bas = Flatten[
     Table[L[[i]]^k Bas[[j]], {k, 0, n - 1}, {j, 1, Length[Bas]}]];];
  n = Length[Bas];
  While[M = {Vectorize[1, Bas]};
   pp = 1;
   For[i = 1, i <= n - 1, i++, pp = FixedPoint[Expand, w pp];
    AppendTo[M, Vectorize[pp, Bas]]];
   RowReduce[M][[n]][[n]] == 0, w = w + d L[[p]];
   p++;
   If[d < Length[L], d++];
   If[p > Length[L], p = 1];];
  w]

FactorLister[Poly_] := 
 Module[{Temp, L, i, j, k}, Temp = FactorList[Poly];
  If[Temp === {}, Temp = {{1, 1}}];
  If[NumberQ[Temp[[1]][[1]]] && (Length[Temp] > 1), 
   L = {Expand[Temp[[1]][[1]] Temp[[2]][[1]]]}; k = 2, 
   L = {Temp[[1]][[1]]}; k = 1];
  For[i = 1, i < Temp[[k]][[2]], i++, L = {L, Temp[[k]][[1]]}];
  For[i = k + 1, i <= Length[Temp], i++, 
   For[j = 0, j < Temp[[i]][[2]], j++, L = {L, Temp[[i]][[1]]}]];
  Flatten[L]]


QuickFactor[Poly_, X_Symbol, {a__Symbol}] := 
 Module[{Temp, L, b, i}, L = {a};
  b = Last[L];
  L = Drop[L, -1];
  Temp = Poly /. X -> X - (2^Length[L] + 1) b;
  Temp = NormG[Temp, b];
  If[Length[L] > 0, 
   QuickFactor[Temp, X, L], (Length[FactorLister[Temp]] > 1)]]

TotalFactor[Poly_, X_Symbol, {a__Symbol}] := 
 Module[{nn, Temp, L, b, i, Prod}, Prod = FactorLister[Poly];
  For[i = 1, i <= Length[Prod], i++, 
   If[(Length[CoefficientList[Prod[[i]], X]] > 2) && 
     QuickFactor[Prod[[i]], X, {a}], 
    If[Length[{a}] > 1, w = SimpleExtension[a], w = a];
    Temp = Prod[[i]];
    For[j = Length[{a}], j > 0, j--, 
     Temp = Temp /. X -> X - nn Coefficient[w, {a}[[j]], 1] {a}[[j]];
     Temp = NormG[Temp, {a}[[j]]]];
    Temp = Factor[Temp];
    If[Temp[[0]] === Times, 
     Prod[[i]] = UnNorm[Temp, nn, X, w, {a}]];]];
  Prod[[0]] = Times;
  Prod]

Unprotect[P, OrderedQ, Sort, FactorG];
ClearAttributes[FactorG, Listable];

P::usage = "P[i, j, k, ...] denotes the permutation that sends 1 to i,
              2 to j, 3 to k, etc.";

P /: CenterDot[P[x___Integer], P[y___Integer]] := 
 Module[{u, L, M, Temp, i}, L = {x};
  M = {y};
  u = Max[Length[L], Length[M]];
  For[i = Length[L] + 1, i <= u, i++, AppendTo[L, i]];
  For[i = Length[M] + 1, i <= u, i++, AppendTo[M, i]];
  Temp = L;
  For[i = 1, i <= u, i++, Temp[[i]] = L[[M[[i]]]]];
  While[Temp[[u]] == u, Temp = Delete[Temp, u]; u--];
  Temp[[0]] = P;
  Temp]

P[a___Integer, b_Integer] := P[a] /; Length[{a}] === b - 1;

OrderedQ[{P[a___Integer], P[b___Integer]}] := 
 Module[{i}, If[Length[P[a]] > Length[P[b]], Return[False]];
  If[Length[P[a]] < Length[P[b]], Return[True]];
  For[i = Length[P[a]], i > 0, i--, 
   If[P[a][[i]] < P[b][[i]], Return[False]];
   If[P[a][[i]] > P[b][[i]], Return[True]]];
  Return[True]]

Sort[a_] := Sort[a, OrderedQ[{#1, #2}] &]

P[a___Integer][b_] := If[b > 0 && b <= Length[{a}], P[a][[b]], b, b]

AnOrSn[Polynom_, Quad_, L_, H_] := 
 Module[{X, i, j, k, R, T, d, dd, n, d0, d1, Bas, M, Temp}, 
  X = Variables[Polynom][[1]];
  R = NSolve[Polynom == 0, X, 20];
  R = Table[R[[i]][[1]][[2]], {i, Length[R]}];
  k = Product[
    R[[i]] - R[[j]], {i, 1, Length[R] - 1}, {j, i + 1, Length[R]}];
  k = Sqrt[Round[k^2]];
  If[IntegerQ[k], T = Table[X - H[[i]], {i, 1, Length[H]}];
   dd = Expand[X^2 - Quad/Coefficient[Quad, X, 2]] /. X -> d;
   Define[d^2, dd];
   AppendTo[T, d];
   AppendTo[T, 
    X - (PolynomialQuotient[Quad, X - d, X]/Coefficient[Quad, X, 2])];
   R = Product[
      T[[i]] - T[[j]], {i, 1, Length[T] - 1}, {j, i + 1, Length[T]}] -
      k;
   R = FixedPoint[Expand, R];
   d1 = Coefficient[R, d, 1];
   d0 = Coefficient[R, d, 0];
   Bas = {1};
   For[i = 1, i <= Length[L], i++, n = 1;
    While[Exponent[L[[i]]^n, L[[i]]] === n, n++];
    Bas = 
     Flatten[Table[
       L[[i]]^k Bas[[j]], {k, 0, n - 1}, {j, 1, Length[Bas]}]];];
   n = Length[Bas];
   M = {Table[
      If[IntegerQ[Bas[[i]]], j = Select[d1, IntegerQ], 
       j = Coefficient[d1, Bas[[i]]];
       If[IntegerQ[j], , 
        If[j[[0]] === Plus, j = Select[j, IntegerQ], j = 0]]];
      j, {i, 1, n}]};
   For[k = 2, k <= n, k++, R = FixedPoint[Expand, d1 Bas[[k]]];
    AppendTo[M, 
     Table[If[IntegerQ[Bas[[i]]], j = Select[R, IntegerQ], 
       j = Coefficient[R, Bas[[i]]];
       If[IntegerQ[j], , 
        If[j[[0]] === Plus, j = Select[j, IntegerQ], j = 0]]];
      j, {i, 1, n}]]];
   AppendTo[M, 
    Table[If[IntegerQ[Bas[[i]]], j = Select[-d0, IntegerQ], 
      j = Coefficient[-d0, Bas[[i]]];
      If[IntegerQ[j], , 
       If[j[[0]] === Plus, j = Select[j, IntegerQ], j = 0]]];
     j, {i, 1, n}]];
   M = Transpose[RowReduce[Transpose[M]]][[n + 1]];
   Temp = X - Sum[M[[i]] Bas[[i]], {i, 1, n}];
   Temp = Temp*PolynomialQuotient[Quad, Temp, X], Temp = Quad];
  Temp]

FactorG[Polynom_, a__Symbol] := 
 Module[{X, Temp, i, j, k, n, L, T, U, Poly}, X = Variables[Polynom];
  L = {a};
  T = L;
  For[i = 1, i <= Length[L], i++, n = 1;
   While[Exponent[L[[i]]^n, L[[i]]] === n, n++];
   T = Union[L, Variables[L[[i]]^n]]];
  X = Complement[X, T];
  If[Length[X] > 1, 
   Print["Only one variable in the polynomial can be indeterminate."],
    X = X[[1]];
   Poly = FactorList[Polynom];
   k = Length[Poly];
   T = 1;
   For[j = 1, j <= k, j++, Temp = Poly[[j]][[1]];
    For[i = 1, i <= Length[L], i++, 
     If[FixedPoint[Expand, Temp /. X -> L[[i]]] === 0, 
      T = T*(X - L[[i]])^Poly[[j]][[2]];
      Temp = PolynomialQuotient[Temp, X - L[[i]], X];
      U = 
       X - PolynomialQuotient[X^2 - L[[i]]^2 /. L[[i]] -> X, 
         X - L[[i]], X];
      If[FixedPoint[Expand, Temp /. X -> U] === 0, 
       T = T*(X - U)^Poly[[j]][[2]];
       Temp = PolynomialQuotient[Temp, X - U, X]];
      i--]];
    If[(T[[0]] === Times) && (Length[T] + 2 === 
        Exponent[Polynom, X]) && (Length[Variables[Polynom]] === 
        1) && (Exponent[Temp, X] === 2), 
     Temp2 = AnOrSn[Polynom, Expand[Temp], L, T];
     If[(Temp2 === Temp) && (Length[L] + 2 < Exponent[Polynom, X]), 
      Temp2 = TotalFactor[Temp, X, L]];
     T = T*Temp2, T = T*TotalFactor[Temp, X, L]^Poly[[j]][[2]]];];
   T]]
Homomorph[F_Symbol] := Module[{a, b},
        UsedSymbols = Union[UsedSymbols, {F}];
        ClearAll[F];
        F[a_ b_] := FixedPoint[Expand, F[a] F[b]];
        F[a_ + b_] := F[a] + F[b];
        F[a_^b_Integer] := FixedPoint[Expand, F[a]^b];
        F[a_Integer] := a;
        F[a_Rational] := a;]

Protect[P, OrderedQ, Sort, Factor];

This code is too long. You need to see the changes by yourself. Then we can get some results in galois.nb:

Define[a^5, 5 a - 12]
FactorG[X^5 - 5 X + 12, a]

enter image description here I don't know if you want this result.

| improve this answer | | | | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.