Primary Decomposition の例

M1171023 森島聖

2000 年 8 月 25 日配布

k はすべて有理数体.

1.

(a) [Example.1] I = ⟨x^{2} − 2, y^{2} − 2⟩ ∈ k [x, y] の primary decomposition は,

In[1]:= QPrimaryDecomposition[{x^2 - 2, y^2 - 2}, {x, y}] // Timing
Out[1]= {3.95 Second, {{{x − y, −2 + y^{2} }, {x − y, −2 + y^{2}}},

{{x + y, −2 + y^{2}}, {x + y, −2 + y^{2}}}}}

primary components は, ⟨x − y, −2 + y^{2}⟩ , ⟨x + y, −2 + y^{2}⟩ で, それら自身が associated primes. よって,I は radical である. 実は,I は,zero-dimensial.

(b) [Example.2] I = ⟨x^{2} − z^{2} − 6z − 9, yz − 2y − z^{2} + 2z⟩ ∈ k [x, y, z] の primary decomposition は,

In[2]:=QPrimaryDecomposition[{x^2 - z^2 - 6z - 9,
         y*z - 2y - z^2 + 2z}, {x, y, z}] // Timing
Out[2]= {11.9333 Second, {{{−5 + x, −2 + z }, {−2 + z, −5 + x}},

{{5 + x, −2 + z }, {−2 + z, 5 + x}}, {{−3 + x − z, y − z},

{y − z, −3 + x − z}},{{3 + x + z, y − z}, {y − z, 3 + x + z}}}}

primary components は, ⟨−5 + x, −2 + z⟩ , ⟨5 + x, −2 + z⟩ , ⟨−3 + x − z, y − z⟩ , ⟨3 + x + z, y − z⟩ で, それら自身が associated primes. よって,I は radical である.

(c) [Example.3] I = ⟨x^{2} + y^{2} + 1, y^{2} + 2x⟩ ∈ k [x, y] の primary decomposition は,

In[3]:= QPrimaryDecomposition[{x^2 + y^2 + 1, y^2 + 2x},
         {x, y}] // Timing

Out[3]= {3.65 Second, {{{1 − 2x + x^{2}, 2x + y^{2} }, {−1 + x, 2 + y^{2}}}}}

primary component は, ⟨1 − 2x + x^{2}, 2x + y^{2}⟩ で, associated prime は, ⟨−1 + x, 2 + y^{2}⟩. よって,I は primary であり,I の radical は,⟨−1 + x, 2 + y^{2}⟩.

(d) [Example.4] I = ⟨xz − y^{2}, x^{3} − yz⟩ ∈ k [x, y, z] の primary decomposition は,

In[4]:= QPrimaryDecomposition[{x*z - y^2, x^3 - y*z},
         {x, y, z}] // Timing
Out[4]= {9.86667 Second, {{{x, y }, {x, y}},

{{y^{2} − xz, x^{3} − yz, x^{2}y − z^{2}}, {y^{2} − xz, x^{3} − yz, x^{2}y − z^{2}}}}}

primary components は, ⟨x, y⟩ , ⟨y^{2} − xz, x^{3} − yz, x^{2}y − z^{2}⟩ で, それら自身が associated primes. よって,I は radical である.

(e) [Example.5] I = ⟨2 + y^{2}, x^{3} + x^{2}y, −2x + x^{2}⟩ ∈ k [x, y] の primary decomposition は,

In[5]:= QPrimaryDecomposition[{2 + y^2, x^3 + x^2*y, -2x + x^2},
         {x, y}] // Timing
Out[5]= {2.51667 Second, {{{x, 2 + y^{2} }, {x, 2 + y^{2}}}}}

primary component は, ⟨x, 2 + y^{2}⟩ で, associated prime はそれ自身. よって,I は prime である. ちなみに,

In[6]:= Groebner[{2 + y^2, x^3 + x^2y, -2x + x^2}, grevlex, {x, y}]
Out[6]= {2 + y^{2}, x}

である.

(f) [Example.6] I = ⟨−4y^{5} − 4y^{7} − y^{9}, 8x + 8y^{2} − 3y^{6} − y^{8}⟩ ∈ k [x, y] の primary decomposition は,

In[7]:= QPrimaryDecomposition[{-4y^5 - 4y^7 - y^9,
         8x + 8y^2 - 3y^6 - y^8}, {x, y}] // Timing
Out[7]= {48.1167 Second, {{{1 − 2x + x^{2}, 2x + y^{2} }, {−1 + x, 2 + y^{2}}},

{{x^{3}, x + y^{2}, x^{2}y}, {x, y}}}}

primary components は, ⟨1 − 2x + x^{2}, 2x + y^{2}⟩ , ⟨x^{3}, x + y^{2}, x^{2}y⟩ で,associated primes は, それぞれ,⟨−1 + x, 2 + y^{2}⟩ , ⟨x, y⟩. よって,I の radical は, \sqrt{I} = \sqrt{⟨1 − 2x + x^{2}, 2x + y^{2}⟩} ⋂ \sqrt{⟨x^{3}, x + y^{2}, x^{2}y⟩} = ⟨−1 + x, 2 + y^{2}⟩ ⋂ ⟨x, y⟩ より,

In[8]:= IdealIntersection[{{-1 + x, 2 + y^2}, {x, y}}, {x, y}]

Out[8]= {2x + y^{2}, −x + x^{2}, −y + xy}

から,\sqrt{I} = ⟨2x + y^{2}, −x + x^{2}, −y + xy⟩ である. このように, primary decomposition algorithm から, radical を計算することも出来る. しかし, 計算速度の効率面では, テキストの radical algorithm を用いた方が良いと思われる.

2. [プログラム説明]

QPrimaryDecomposition[F_, value_] :=
QPrimaryDecomposition[F, value] =
  Module[{Combi, P, FF, ev, ch, co, e, ee, Q, C, a, G, H, ex, f, s},
    Combi[n_] :=
      Combi[n] =
        Module[{aa, bb}, aa = {};
          Do[bb = Table[{ii}, {ii, 1, i}];
            While[bb[[1]][[1]] =!= n - i + 2, aa = Append[aa, bb];
              bb = ReplacePart[bb, {bb[[-1]][[1]] + 1}, -1];
              Do[If[bb[[-ii]][[1]] == n - ii + 2,
                  bb = ReplacePart[
                      bb, {bb[[-ii - 1]][[1]] + 1}, -ii - 1]], {ii, 1,
                  i - 1}];
              Do[If[bb[[ii]][[1]] == n - i + ii + 1,
                  bb = ReplacePart[bb, {bb[[ii - 1]][[1]] + 1}, ii]], {ii,
                  2, i}]], {i, 1, n - 1}]; aa]; P = {};
    FF = Groebner[F, grlex, value];
    If[FF =!= {1},
      If[IdealZeroDimCheck[FF, value] == True, ev = {}, ch = True;
        co = Combi[Length[value]];
        While[ch, e = co[[1]]; co = Drop[co, 1]; ee = Delete[value, e];
          If[Elimination[FF, value, Complement[value, ee]] == {0},
            ch = False; ev = ee]]];
      Q = ZeroQPrimaryDecomposition[FF, Complement[value, ev]]; C = {};
      While[Q =!= {}, a = Q[[1]]; Q = Delete[Q, 1];
        G = Contraction[a[[1]], value, ev];
        H = Contraction[a[[2]], value, ev]; C = Union[C, {{G, H}}]];
      ex = ExtCont[FF, value, ev]; f = ex[[1]]; s = ex[[2]];

        P = Union[C,
            QPrimaryDecomposition[Union[FF, Expand[Simplify[{f^s}]]], value]],
         P]]

ideal I ∈ k [x_{1}, ⋯, x_{n}] の生成元を, I = ⟨f_{1}, ⋯, f_{r}⟩ とするとき,

QPrimaryDecomposition[{ f_{1}, · · · , f_{r} },{ x_{1}, · · · , x_{n} }]

と入力すると, primary decomposition I = ⋂_{i=1}^{s} Q_{i} の components Q_{i} と, その associated

primes P_{i}(= \sqrt{Q_{i}}) の生成元の組を出力する。但し体 k は, 有理数体もしくは有理数係数の有理関数体の場合のみである.

但し, プログラム中の関数は以下の通り.

Groebner[generator_, monoorder_, valueorder_] :=
  Groebner[generator, monoorder, valueorder] =
 Module[{LT2, ListPoly, PolyList, Polymono2, PolyDiv2, S2, Groeb3, MinGroeb,
        RedGroeb},
      If[monoorder == lex,
        LT2[f_] :=
          LT2[f] = Module[{s, lt, a}, s = Length[f]; lt = f[[1]];
              Do[If[DeleteCases[lt[[2]] - f[[a]][[2]], 0][[1]] < 0,
                  lt = f[[a]]], {a,2,s}]; lt]];
      If[monoorder == grlex,
        LT2[f_] :=LT2[f] =
            Module[{s, lt, t, sum1, sum2, a}, s = Length[f]; lt = f[[1]];
              t = Length[lt[[2]]];
              Do[sum1 = Sum[lt[[2]][[i]], {i, t}];
                sum2 = Sum[f[[a]][[2]][[i]], {i, t}];
                If[sum1 < sum2, lt = f[[a]],
                  If[sum1 == sum2,
                    If[DeleteCases[lt[[2]] - f[[a]][[2]], 0][[1]] < 0,
                      lt = f[[a]]]]], {a, 2, s}]; lt]];
      If[monoorder == grevlex,
        LT2[f_] :=LT2[f] =
            Module[{s, lt, t, sum1, sum2, a}, s = Length[f]; lt = f[[1]];
              t = Length[lt[[2]]];
              Do[sum1 = Sum[lt[[2]][[i]], {i, t}];
                sum2 = Sum[f[[a]][[2]][[i]], {i, t}];

If[sum1 < sum2, lt = f[[a]],
If[sum1 == sum2,
If[DeleteCases[lt[[2]] - f[[a]][[2]], 0][[-1]] > 0,
lt = f[[a]]]]], {a, 2, s}]; lt]];
If[monoorder =!= lex && monoorder =!= grlex && monoorder =!= grevlex,
LT2[f_] :=LT2[f] = Module[{s, lt, t, c, j}, s = Length[f]; lt = f[[1]];
t = Length[monoorder];
Do[c = False; j = 1;
While[c == False,
If[monoorder[[j]].lt[[2]] =!= monoorder[[j]].f[[i]][[2]],
c = True; If[
monoorder[[j]].lt[[2]] < monoorder[[j]].f[[i]][[2]],
lt = f[[i]]]]; j = j + 1], {i, 2, s}]; lt]];
PolyList[F_, val_] :=
Module[{s, PolyListone},
PolyListone[f_, v_] :=
PolyListone[f, v] =
Module[{getcoeff, MonomialList, aa, bb, kkk, tta, cce, ii, dc},
getcoeff[m_, b_] := getcoeff[m, b] = Module[{a, c},
 If[Variables[m] =!= {}, a = Exponent[m, b];
  c = Times @@ (b^a);
    If[c =!= 1, {Coefficient[m, Times @@ (b^a)], a}, {m,
      a}], {m,
      Table[0, {Length[b]}]}]];
MonomialList[aiueo_] :=
Module[{sasisuseso, full},
kakikukeko = Expand[aiueo] + sasisuseso;
full = FullForm[kakikukeko];
DeleteCases[
Table[full[[1]][[iii]], {iii, 1, Length[full[[1]]]}],
sasisuseso]]; aa = MonomialList[f];
bb = Length[aa];
tta = Table[getcoeff[aa[[i]], v], {i, 1, bb}]; cce = True;
Do[ii = j + 1; cce = True;
While[cce,
If[tta[[j]][[2]] == tta[[ii]][[2]], cce = False;
tta = ReplacePart[
    tta, {tta[[ii]][[1]] + tta[[j]][[1]],
      tta[[ii]][[2]]}, ii];
tta = ReplacePart[tta, True, j]];

        If[ii == Length[tta], cce = False, ii = ii + 1]], {j, 1,
        Length[tta] - 1}];
dc = DeleteCases[tta, True];
    Table[{Expand[Simplify[dc[[iii]][[1]]]],
        dc[[iii]][[2]]}, {iii, 1, Length[dc]}]];
s = Length[F]; Table[PolyListone[F[[i]], val], {i, s}]];
ListPoly[F_, val_] :=
ListPoly[F, val] =
Module[{ListPolyone, s, FF},
ListPolyone[f_, v_] :=
  ListPolyone[f, v] =
    Module[{s, ss}, s = Length[f]; ss = Length[v];
      Sum[f[[i]][[1]]*
          Product[v[[j]]^(f[[i]][[2]][[j]]), {j, 1, ss}], {i, 1,
          s}]];
s = Length[F]; FF = {};
Do[FF = Append[FF, ListPolyone[F[[i]], val]], {i, s}];
FF]; Polymono2[f_, m_] :=
Polymono2[f, m] =
Module[{ff, s, c, a}, ff = f; s = Length[ff];
If[s == 0, ff = {m}, c = True; a = 1;
  While[c, If[DeleteCases[m[[2]] - ff[[a]][[2]], 0] == {},
      ff = ReplacePart[ff, {ff[[a]][[1]] + m[[1]], m[[2]]}, a];
      If[ff[[a]][[1]] == 0, ff = Delete[ff, a]]; c = False,
      a = a + 1];
    If[a == s + 1, ff = Append[ff, m]; c = False]]]; ff];
PolyDiv2[f_, g_] :=
PolyDiv2[f, g] =Module[{s, a, r, p, i, c, h1, h2}, s = Length[g]; a = {};
Do[a = Append[a, {}], {s}];
r = {}; p = f;
While[p =!= {}, i = 1; c = True;
  While[i <= s && c, h1 = LT2[p][[2]] - LT2[g[[i]]][[2]];
   If[Select[h1, #1 < 0 &] == {},
      h2 = Expand[Simplify[LT2[p][[1]]/(LT2[g[[i]]][[1]])]];
      a = ReplacePart[a, Polymono2[a[[i]], {h2, h1}], i];
      gg = g[[i]];
      While[gg =!= {},
        p = Polymono2[
            p, {Expand[Simplify[-h2*LT2[gg][[1]]]],
              h1 + LT2[gg][[2]]}];

        gg = Polymono2[gg, {-LT2[gg][[1]], LT2[gg][[2]]}]];
      c = False,
      i = i + 1]];
  If[c, r = Polymono2[r, LT2[p]];
    p = Polymono2[p, {-LT2[p][[1]], LT2[p][[2]]}]]]; {a, r}];
S2[f_, g_] :=S2[f, g] =
Module[{mf, mg, s, c, a, b, z, aa, ff, gg}, mf = LT2[f][[2]];
mg = LT2[g][[2]]; s = Length[mf]; c = {};
Do[c = Append[c, Max[{mf[[i]], mg[[i]]}]], {i, 1, s}];
a = {1/(LT2[f][[1]]), c - mf}; b = {1/(LT2[g][[1]]), c - mg};
z = {}; aa = {};
ff = f;
While[ff =!= z,
  aa = Polymono2[
      aa, {Expand[Simplify[a[[1]]*LT2[ff][[1]]]],
        a[[2]] + LT2[ff][[2]]}];
  ff = Polymono2[ff, {-LT2[ff][[1]], LT2[ff][[2]]}]]; gg = g;
While[gg =!= z,
  aa = Polymono2[
      aa, {Expand[Simplify[-b[[1]]*LT2[gg][[1]]]],
        b[[2]] + LT2[gg][[2]]}];
  gg = Polymono2[gg, {-LT2[gg][[1]], LT2[gg][[2]]}]]; aa];
Groeb3[F_] :=
Groeb3[F] =
Module[{Criterion, s, B, G, t, ss, k, S},
Criterion[i_, j_, SS_] :=
  Criterion[i, j, SS] =
    Module[{sss, c, cc, ii}, sss = Length[G]; c = False;
      cc = True; ii = 1;
      While[cc,
        If[(ii =!= i) && (ii =!= j) && (
              MemberQ[SS, If[ii > i, {i, ii}, {ii, i}]] ==
                False) && (
              MemberQ[SS, If[ii > j, {j, ii}, {ii, j}]] ==
                False) && (
              Select[
                  Table[Max[{LT2[G[[i]]][[2]][[kk]],
                         LT2[G[[j]]][[2]][[kk]]}], {kk, ss}] -
                    LT2[G[[ii]]][[2]], #1 < 0 &] == {}),
          c = True;

          cc = False]; If[ii == sss, cc = False]; ii = ii + 1];
      c]; s = Length[F];
B = {};
Do[Do[B = Append[B, {i, j}], {j, i + 1, s}], {i, 1, s - 1}];
G = F; t = s;
ss = Length[F[[1]][[1]][[2]]];
While[B =!= {}, k = B[[1]];
  If[(Table[Max[{LT2[G[[k[[1]]]]][[2]][[i]],
                LT2[G[[k[[2]]]]][[2]][[i]]}], {i,
              ss}] =!=
         LT2[G[[k[[1]]]]][[2]] + LT2[G[[k[[2]]]]][[2]]) && (
        Criterion[k[[1]], k[[2]], B] == False),
    S = PolyDiv2[S2[G[[k[[1]]]], G[[k[[2]]]]], G][[2]];
    If[S =!= {}, t = t + 1; G = Append[G, S];
      Do[B = Append[B, {tt, t}], {tt, 1, t - 1}]]];
  B = Delete[B, 1]]; G];
MinGroeb[F_] :=
MinGroeb[F] =
Module[{G, s, a, h, ss, t, sss, aa}, G = Groeb3[F]; s = Length[G];
Do[Do[If[i =!= j && G[[j]] =!= a && G[[i]] =!= a,
      h = LT2[G[[i]]][[2]] - LT2[G[[j]]][[2]];
      If[Select[h, #1 < 0 &] == {}, G = ReplacePart[G, a, i]]];
    j = j + 1, {j, s}];
  i = i + 1, {i, s}]; G = DeleteCases[G, a]; ss = Length[G];
Do[t = LT2[G[[k]]][[1]];
  If[t =!= 1, sss = Length[G[[k]]]; aa = G[[k]];
    Do[aa =
        ReplacePart[
          aa, {Expand[Simplify[aa[[m]][[1]]/t]], aa[[m]][[2]]},
          m], {m,
        sss}]; G = ReplacePart[G, aa, k]], {k, ss}]; G];
RedGroeb[F_] :=
RedGroeb[F] =
Module[{G, s, k}, G = MinGroeb[F]; s = Length[G];
Do[k = PolyDiv2[G[[j]], Delete[G, j]][[2]];
  G = ReplacePart[G, k, j], {j, s}]; G];
Expand[
Simplify[
ListPoly[RedGroeb[PolyList[generator, valueorder]], valueorder]]]]

Elimination[ideal_, value_, elimi_] :=
Elimination[ideal, value, elimi] =
Module[{s, t, m, g, yyy}, s = Length[value]; t = Table[1, {s}];
m = Table[1, {Length[elimi]}];
m = {Join[m, Table[0, {s - Length[elimi]}]]}; m = Append[m, t];
Do[m = Append[m, ReplacePart[t, 0, -i]], {i, 1, s}];
g = Groebner[ideal, m, Join[elimi, Complement[value, elimi]]];
Do[If[Complement[Variables[g[[i]]], elimi] =!= Variables[g[[i]]],
    g = ReplacePart[g, yyy, i]], {i, 1, Length[g]}];
g = DeleteCases[g, yyy]; If[g == {}, {0}, g]]

IdealIntersection[ff_, val_] :=
IdealIntersection[ff, val] =
Module[{m, eliva, gg}, m = Length[ff]; eliva = Table[ttt[i], {i, 1, m}];
gg = Flatten[Table[ttt[i]*ff[[i]], {i, 1, m}]];
Elimination[Append[gg, 1 - Sum[ttt[i], {i, 1, m}]], Join[val, eliva],
  eliva]]

IdealQuotient[f_, g_, value_] :=
IdealQuotient[f, g, value] =
Module[{s, a}, s = Length[g];
a = If[g[[1]] === 0, {1},
    Expand[IdealIntersection[{f, {g[[1]]}}, value]/g[[1]]]];
Do[a = IdealIntersection[{a,
        If[g[[i]] === 0, {1},
          Expand[Simplify[
              IdealIntersection2[f, {g[[i]]}, value]/g[[i]]]]]},
      value], {i, 2, s}]; Expand[Simplify[a]]]

Saturation[ideal_, f_, value_] :=
Saturation[ideal, f, value] =
Module[{a, b, k},
a = Groebner[IdealQuotient[ideal, {f}, value], grlex, value];

b = Groebner[IdealQuotient[ideal, {f^2}, value], grlex, value]; n = 1;
While[(Length[a] =!= Length[b]) || (k =
        Table[MemberQ[b, a[[i]]], {i, 1, Length[a]}];
      DeleteCases[k, True] =!= {}), a = b;
  b = Groebner[IdealQuotient[ideal, {f^(n + 2)}, value], grlex, value];
  n = n + 1]; {n, a}]

IdealZeroDimCheck[ideal_, value_] :=
IdealZeroDimCheck[ideal, value] =
Module[{LT2, PolyList, g},
LT2[f_] :=
LT2[f] =
    Module[{s, lt, t, sum1, sum2, a}, s = Length[f]; lt = f[[1]];
        t = Length[lt[[2]]];
        Do[sum1 = Sum[lt[[2]][[i]], {i, t}];
          sum2 = Sum[f[[a]][[2]][[i]], {i, t}];
          If[sum1 < sum2, lt = f[[a]],
            If[sum1 == sum2,
              If[DeleteCases[lt[[2]] - f[[a]][[2]], 0][[1]] < 0,
                lt = f[[a]]]]], {a, 2, s}]; lt];
PolyList[F_, val_] :=
    Module[{s, PolyListone},
  PolyListone[f_, v_] :=
      PolyListone[f, v] =
        Module[{getcoeff, MonomialList, aa, bb, kkk, tta, cce, ii, dc},
          getcoeff[m_, b_] := getcoeff[m, b] = Module[{a, c},
                 If[Variables[m] =!= {}, a = Exponent[m, b];
                  c = Times @@ (b^a);
                   If[c =!= 1, {Coefficient[m, Times @@ (b^a)], a}, {m,
                      a}], {m,
                      Table[0, {Length[b]}]}]];
          MonomialList[aiueo_] :=
            Module[{sasisuseso, full},
              kakikukeko = Expand[aiueo] + sasisuseso;
              full = FullForm[kakikukeko];
              DeleteCases[
                Table[full[[1]][[iii]], {iii, 1, Length[full[[1]]]}],

                sasisuseso]]; aa = MonomialList[f];
            bb = Length[aa];
          tta = Table[getcoeff[aa[[i]], v], {i, 1, bb}]; cce = True;
          Do[ii = j + 1; cce = True;
            While[cce,
              If[tta[[j]][[2]] == tta[[ii]][[2]], cce = False;
                tta = ReplacePart[
                    tta, {tta[[ii]][[1]] + tta[[j]][[1]],
                      tta[[ii]][[2]]}, ii];
                tta = ReplacePart[tta, True, j]];
              If[ii == Length[tta], cce = False, ii = ii + 1]], {j, 1,
              Length[tta] - 1}];
dc = DeleteCases[tta, True];
          Table[{Expand[Simplify[dc[[iii]][[1]]]],
              dc[[iii]][[2]]}, {iii, 1, Length[dc]}]];
      s = Length[F]; Table[PolyListone[F[[i]], val], {i, s}]];
g = Groebner[ideal, grlex, value]; g = PolyList[g, value];
g = Table[LT2[g[[i]]], {i, 1, Length[g]}];
g = Table[g[[i]][[2]], {i, 1, Length[g]}];
g = Table[
    If[Length[DeleteCases[g[[i]], 0]] =!= 1, Table[0, {Length[value]}],
      g[[i]]], {i, 1, Length[g]}]; g = Sum[g[[i]], {i, 1, Length[g]}];
If[DeleteCases[g, 0] == g, True, False]]

ZeroDimRadical[ideal_, value_] :=
ZeroDimRadical[ideal, value] =
Module[{g, a, b}, g = ideal;
Do[a = Elimination[ideal, value, Drop[value, {i}]][[1]];
  b = Expand[
      Simplify[
          IdealIntersection[{{a}, {D[a, value[[i]]]}}, {value[[i]]}]/(D[
                a, value[[i]]])][[1]]];
  g = Join[g, {b}], {i, 1, Length[value]}]; Groebner[g, grlex, value]]

NormPos[FF_, value_] :=
NormPos[FF, value] =

Module[{LT2, PolyList, FormCheck, f, m, p, q, c, d, k, ccc, gr, cp, s,
mm}, LT2[ff_] :=
LT2[ff] = Module[{s, lt, a}, s = Length[ff]; lt = ff[[1]];
Do[If[DeleteCases[lt[[2]] - ff[[a]][[2]], 0][[1]] < 0,
lt = ff[[a]]], {a, 2, s}]; lt];
PolyList[F_, val_] :=
Module[{s, PolyListone},
PolyListone[f_, v_] :=
PolyListone[f, v] =
Module[{getcoeff, MonomialList, aa, bb, kkk, tta, cce, ii, dc},
getcoeff[m_, b_] := getcoeff[m, b] = Module[{a, c},
   If[Variables[m] =!= {}, a = Exponent[m, b];
    c = Times @@ (b^a);
    If[c =!= 1, {Coefficient[m, Times @@ (b^a)], a}, {m,
        a}], {m,
        Table[0, {Length[b]}]}]];
MonomialList[aiueo_] :=
Module[{sasisuseso, full},
kakikukeko = Expand[aiueo] + sasisuseso;
full = FullForm[kakikukeko];
DeleteCases[
  Table[full[[1]][[iii]], {iii, 1, Length[full[[1]]]}],
  sasisuseso]]; aa = MonomialList[f];
bb = Length[aa];
tta = Table[getcoeff[aa[[i]], v], {i, 1, bb}]; cce = True;
Do[ii = j + 1; cce = True;
While[cce,
If[tta[[j]][[2]] == tta[[ii]][[2]], cce = False;
  tta = ReplacePart[
      tta, {tta[[ii]][[1]] + tta[[j]][[1]],
        tta[[ii]][[2]]}, ii];
  tta = ReplacePart[tta, True, j]];
If[ii == Length[tta], cce = False, ii = ii + 1]], {j, 1,
Length[tta] - 1}];
dc = DeleteCases[tta, True];
Table[{Expand[Simplify[dc[[iii]][[1]]]],
dc[[iii]][[2]]}, {iii, 1, Length[dc]}]];
s = Length[F]; Table[PolyListone[F[[i]], val], {i, s}]];
FormCheck[poly_, va_] :=
Module[{po, yyy, ta},

  If[(Length[poly] == Length[va] + 1) && (po = poly;
        Do[If[Complement[Variables[po[[i]]], va] =!=
              Variables[po[[i]]], po = ReplacePart[po, yyy, i]], {i,
            1, Length[po]}]; po = DeleteCases[po, yyy];
        Length[po] == 1) && (po = Complement[poly, {po[[1]]}];
        ta = Table[
            LT2[PolyList[{po[[j]]},
                      Append[va, www]][[1]]][[2]].Append[va, www], {j,
               1, Length[po]}];
        If[MemberQ[Table[MemberQ[va, ta[[i]]], {i, 1, Length[ta]}],
            False], False, True]), True, False]];
      f = Elimination[FF, value, Drop[value, {1}]][[1]];
m = LT2[PolyList[{f}, {value[[1]]}][[1]]][[2]][[1]];
Do[p = Elimination[FF, value, Drop[value, {i}]][[1]];
q = LT2[PolyList[{p}, {value[[i]]}][[1]]][[2]][[1]]; m = m*q;
c[i] = Table[j, {j, 0, If[m < 2, 0, m!/((m - 2)!*2)]}], {i, 2,
  Length[value]}]; cc = {};
Do[cc = Append[cc, c[i]], {i, 2, Length[value]}];
d = Table[Length[cc[[i]]], {i, 1, Length[cc]}];
k = Join[{1}, Table[0, {Length[value] - 1}]]; ccc = {k};
While[Product[d[[i]], {i, 1, Length[d]}] =!= Length[ccc],
k = ReplacePart[k, k[[-1]] + 1, -1];
Do[If[k[[-i]] > d[[-i]] - 1,
    k = ReplacePart[k, k[[-(i + 1)]] + 1, -i - 1];
    k = ReplacePart[k, 0, -i]], {i, 1, Length[d]}];
ccc = Append[ccc, k]]; gr = {0};
While[ccc =!= {} && FormCheck[gr, value] == False, cp = ccc[[1]];
ccc = Delete[ccc, 1]; s = Table[1, {Length[value] + 1}];
mm = Table[1, {Length[value]}]; mm = {Append[mm, 0]};
mm = Append[mm, s];
Do[mm = Append[mm, ReplacePart[s, 0, -i]], {i, 1, Length[value]}];
gr = Groebner[Append[FF, www - (value.cp)], mm, Append[value, www]]];
gr]

ZeroQPrimaryDecomposition[F_, value_] :=
ZeroQPrimaryDecomposition[F, value] = Module[{UniExpo, G, Q, g, glist, P,
m, H, hm, ta},
UniExpo[ff_, val_] :=

  UniExpo[ff, val] =
    Module[{ext},
      Do[ext[i] =
          Max[Table[
              FactorList[
                    Elimination[ff, val,
                        Drop[val, {i}]][[1]]][[j]][[2]], {j, 1,
                Length[FactorList[
                    Elimination[ff, val, Drop[val, {i}]][[1]]]]}]], {i,
          1, Length[val]}]; 1 + Sum[ext[i] - 1, {i, 1, Length[val]}]];
G = NormPos[ZeroDimRadical[F, value], value]; Q = {};
g = Elimination[G, Prepend[value, www], value][[1]];
glist = FactorList[g]; glist = Drop[glist, {1}];
Do[Q = Union[
      Q, {Union[G,
          If[MemberQ[Variables[glist[[i]]],
              www], {glist[[i]][[1]]}, {}]]}], {i, 1, Length[glist]}];
P = {}; m = UniExpo[F, value];
While[Q =!= {}, A = Q[[1]]; Q = Drop[Q, {1}];
  H = Elimination[A, Append[value, www], {www}]; hm = H;
  Do[ta = Table[Expand[H[[i]]*hm], {i, 1, Length[H]}]; hm = ta[[1]];
    Do[hm = Union[hm, ta[[i]]], {i, 2, Length[ta]}], {m - 1}];
  G = Union[F, hm]; G = Groebner[G, grevlex, value];
  P = Union[P, {{G, H}}]]; P]

Contraction[FF_, value_, value2_] :=
Contraction[FF, value, value2] =
Module[{PolyList, LT2, H, s, h, f},
PolyList[F_, val_] :=
    Module[{s, PolyListone},
    PolyListone[f_, v_] :=
      PolyListone[f, v] =
        Module[{getcoeff, MonomialList, aa, bb, kkk, tta, cce, ii, dc},
          getcoeff[m_, b_] := getcoeff[m, b] = Module[{a, c},
                If[Variables[m] =!= {}, a = Exponent[m, b];
                  c = Times @@ (b^a);
               If[c =!= 1, {Coefficient[m, Times @@ (b^a)], a}, {m,

        a}], {m,
        Table[0, {Length[b]}]}]];
MonomialList[aiueo_] :=
Module[{sasisuseso, full},
kakikukeko = Expand[aiueo] + sasisuseso;
full = FullForm[kakikukeko];
DeleteCases[
  Table[full[[1]][[iii]], {iii, 1, Length[full[[1]]]}],
  sasisuseso]]; aa = MonomialList[f];
bb = Length[aa];
tta = Table[getcoeff[aa[[i]], v], {i, 1, bb}]; cce = True;
Do[ii = j + 1; cce = True;
While[cce,
If[tta[[j]][[2]] == tta[[ii]][[2]], cce = False;
  tta = ReplacePart[
      tta, {tta[[ii]][[1]] + tta[[j]][[1]],
        tta[[ii]][[2]]}, ii];
  tta = ReplacePart[tta, True, j]];
If[ii == Length[tta], cce = False, ii = ii + 1]], {j, 1,
Length[tta] - 1}];
dc = DeleteCases[tta, True];
Table[{Expand[Simplify[dc[[iii]][[1]]]],
dc[[iii]][[2]]}, {iii, 1, Length[dc]}]];
s = Length[F]; Table[PolyListone[F[[i]], val], {i, s}]];
LT2[f_] :=LT2[f] =
Module[{s, lt, t, sum1, sum2, a}, s = Length[f]; lt = f[[1]];
t = Length[lt[[2]]];
Do[sum1 = Sum[lt[[2]][[i]], {i, t}];
sum2 = Sum[f[[a]][[2]][[i]], {i, t}];
If[sum1 < sum2, lt = f[[a]],
If[sum1 == sum2,
If[DeleteCases[lt[[2]] - f[[a]][[2]], 0][[1]] < 0,
lt = f[[a]]]]], {a, 2, s}]; lt];
H = Groebner[FF, grlex, Complement[value, value2]]; s = Length[H];
H = Together[H]; H = Table[Denominator[H[[i]]]*H[[i]], {i, 1, s}];
h = PolyList[H, Complement[value, value2]];
h = Table[LT2[h[[i]]][[1]], {i, 1, s}];
f = IdealIntersection[h, value2][[1]];
Elimination[Append[H, 1 - f*yyy], Append[value, yyy], {yyy}]]

ExtCont[FF_, value_, value2_] :=
ExtCont[FF, value, value2] =
Module[{PolyList, LT2, s, ss, t, ord1, ord2, G, monoorder, f, sn},
PolyList[F_, val_] :=
Module[{s, PolyListone},
PolyListone[f_, v_] :=
PolyListone[f, v] =
Module[{getcoeff, MonomialList, aa, bb, kkk, tta, cce, ii, dc},
getcoeff[m_, b_] := getcoeff[m, b] = Module[{a, c},
   If[Variables[m] =!= {}, a = Exponent[m, b];
    c = Times @@ (b^a);
   If[c =!= 1, {Coefficient[m, Times @@ (b^a)], a}, {m,
        a}], {m,
        Table[0, {Length[b]}]}]];
MonomialList[aiueo_] :=
Module[{sasisuseso, full},
kakikukeko = Expand[aiueo] + sasisuseso;
full = FullForm[kakikukeko];
DeleteCases[
  Table[full[[1]][[iii]], {iii, 1, Length[full[[1]]]}],
  sasisuseso]]; aa = MonomialList[f];
bb = Length[aa];
tta = Table[getcoeff[aa[[i]], v], {i, 1, bb}]; cce = True;
Do[ii = j + 1; cce = True;
While[cce,
If[tta[[j]][[2]] == tta[[ii]][[2]], cce = False;
  tta = ReplacePart[
      tta, {tta[[ii]][[1]] + tta[[j]][[1]],
        tta[[ii]][[2]]}, ii];
  tta = ReplacePart[tta, True, j]];
If[ii == Length[tta], cce = False, ii = ii + 1]], {j, 1,
Length[tta] - 1}];
dc = DeleteCases[tta, True];
Table[{Expand[Simplify[dc[[iii]][[1]]]],
dc[[iii]][[2]]}, {iii, 1, Length[dc]}]];
s = Length[F]; Table[PolyListone[F[[i]], val], {i, s}]];
LT2[f_] :=
LT2[f] = Module[{s, lt, t, c, j}, s = Length[f]; lt = f[[1]];

        t = Length[monoorder];
      Do[c = False; j = 1;
        While[c == False,
          If[monoorder[[j]].lt[[2]] =!= monoorder[[j]].f[[i]][[2]],
              c = True;
            If[monoorder[[j]].lt[[2]] < monoorder[[j]].f[[i]][[2]],
              lt = f[[i]]]]; j = j + 1], {i, 2, s}]; lt];
s = Length[Complement[value, value2]]; ss = Length[value2];
t = Join[Table[1, {s}], Table[0, {ss}]]; ord1 = {t};
Do[ord1 = Append[ord1, ReplacePart[t, 0, -(i + ss)]], {i, 1, s}];
ord2 = ord1; t = Join[Table[0, {s}], Table[1, {ss}]];
ord1 = Append[ord1, t];
Do[ord1 = Append[ord1, ReplacePart[t, 0, -i]], {i, 1, ss}];
ord2 = Table[Drop[ord2[[i]], -ss], {i, 1, s + 1}];
G = Groebner[FF, ord1, value];
G = PolyList[G, Complement[value, value2]]; monoorder = ord2;
G = Table[LT2[G[[i]]][[1]], {i, 1, Length[G]}];
f = IdealIntersection[G, value2][[1]];
sn = Saturation[FF, f, value][[1]]; {f, sn}]