被約Groebner基底に変換するプログラム


In[1]:=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]		       

但し、        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]		       
		       
      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]  	   
 
             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,{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,{-b[[1]]*LT2[gg][[1]],
                        b[[2]]+LT2[gg][[2]]}];gg=Polymono2[gg,{-LT2[gg][[1]],
                        LT2[gg][[2]]}]];aa]
 
 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=LT2[p][[1]]/(LT2[g[[i]]][[1]]);
                        a=ReplacePart[a,Polymono2[a[[i]],{h2,h1}],i];gg=g[[i]];
                        While[gg=!={},p=Polymono2[p,{-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}]
	
Groeb2[F_]:=Groeb2[F]=Module[{G,GG,z,s,r},
                        G=F;z={};While[G=!=GG,GG=G;s=Length[GG];
                        Do[Do[r=PolyDiv2[S2[GG[[i]],GG[[j]]],G][[-1]];
                        If[r=!=z,G=Append[G,r]],{j,i+1,s}],{i,1,s-1}]];G]
			
MinGroeb[F_]:=MinGroeb[F]=Module[{G,s,a,h,ss,t,sss,aa},
                        G=Groeb2[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,{aa[[m]][[1]]/t,aa[[m]][[2]]},m],
                        {m,sss}];G=ReplacePart[G,aa,k]],{k,ss}];G]			
		       
		       
		       
RedGroeb[{f1, f2, ..., fn}]と入力すると、
被約Groebner基底: {g1, g2, ..., gs}を出力します。

但し、Orderは、Lex Orderを採用し、f1, f2, ..., fn, g1, g2, ..., gs, は、リストで表した多項式です。


(Example)

In[2]:=RedGroeb[{{{1,{0,2,1,1}},{1,{0,0,0,0}}},{{1,{3,1,1,1}},{-1,{0,1,0,1}}},     
                {{1,{0,0,1,1}},{-1,{3,0,0,1}}},{{1,{0,4,0,0}},{-1,{0,0,0,0}}}}]

Out[2]={{{1,{3,0,0,0}},{-1,{0,0,1,0}}},{{1,{0,2,0,0}},{1,{0,0,1,1}}},
       {{1,{0,0,2,0}},{-1,{0,0,0,0}}},{{1,{0,0,0,2}},{-1,{0,0,0,0}}}}