プログラムの説明は工事中 (有理数体もしくは、有理数体係数の有理関数体を係数とする多項式環のイデアルの準素分解のプログラム) 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]] 但し、 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}]