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


In[1]:=Groeb[F_]:=Groeb[F]=Module[{G,GG,z,s,r},
                           G=F;z=0;Do[z={z},{Depth[F[[1]]]-1}];
                           While[G=!=GG,GG=G;s=Length[G];
                           Do[Do[r=PolyDiv[S[G[[i]],G[[j]]],G][[-1]];
                           If[r=!=z,G=Append[G,r]],{j,i+1,s}],{i,1,s-1}]];G]		       

但し、         LT[f_]:=LT[f]=Module[{n,ff,deglist,coe},
	               n=Depth[f]-1;ff[i_]:=ff[i]=ff[i-1][[-1]];
                       ff[1]:=f;deglist=Table[Length[ff[i]]-1,{i,1,n}];
                       coe=Flatten[f][[-1]];{deglist,coe}]		       
		       
      Polymono[f_,m_]:=Polymono[f,m]=
                       Module[{deglist,coe,f1,f2,k,a,zero,f3,co,ze},
	               deglist=m[[1]];coe=m[[2]];k=deglist[[1]]+1;
                       If[Length[f]>=k,If[Length[deglist]==1,
                       If[coe+f[[k]]==0,f1=ReplacePart[f,0,k];
                       While[Length[f1]>=2&&f1[[-1]]==0,f1=Delete[f1,-1]];f1,
                       ReplacePart[f,coe+f[[k]],k]],
		       f2=ReplacePart[f,Polymono[f[[k]],
		       {Delete[deglist,1],coe}],k];
                       While[Length[f2]>=2&&Flatten[f2[[-1]]]=={0},
		       f2=Delete[f2,-1]];f2],a=k-Length[f];zero=0;
		       Do[zero={zero},{Depth[f]-2}];f3=f;
                       Do[f3=Append[f3,zero],{a-1}];co={coe};ze=0;
                       Do[Do[co=Prepend[co,ze],{deglist[[-i]]}];co={co};
                       ze={ze},{i,1,Length[deglist]-1}];
                       If[Depth[co]==2,co=coe,co=FlattenAt[co,{1}]];
		       Append[f3,co]]] 	   
 
             S[f_,g_]:=S[f,g]=
	               Module[{mf,mg,s,a,b,z,aa,ff,gg},mf=LT[f][[1]];
		       mg=LT[g][[1]];s=Length[mf];c={};
		       Do[c=Append[c,Max[{mf[[i]],mg[[i]]}]],{i,1,s}];
                       a={c-mf,1/(LT[f][[2]])};b={c-mg,1/(LT[g][[2]])};
	               z=0;Do[z={z},{s}];aa=z;ff=f;While[ff=!=z,
                       aa=Polymono[aa,{a[[1]]+LT[ff][[1]],a[[2]]*LT[ff][[2]]}];
                       ff=Polymono[ff,{LT[ff][[1]],-LT[ff][[2]]}]];gg=g;
                       While[gg=!=z,aa=Polymono[aa,{b[[1]]+LT[gg][[1]],
		       -b[[2]]*LT[gg][[2]]}];
                       gg=Polymono[gg,{LT[gg][[1]],-LT[gg][[2]]}]];aa]
 
 PolyDiv[f_,g_]:=PolyDiv[f,g]=Module[{s,z,a,r,p,i,c,h1,h2,gg},
                       s=Length[g];z=0;Do[z={z},{Depth[f]-1}];a={};
		       Do[a=Append[a,z],{s}];r=z;p=f;
                       While[p=!=z,i=1;c=True;
                       While[i<=s&&c,h1=LT[p][[1]]-LT[g[[i]]][[1]];
                       If[Select[h1,#1<0&]=={},h2=LT[p][[2]]/(LT[g[[i]]][[2]]);
                       a=ReplacePart[a,Polymono[a[[i]],{h1,h2}],i];gg=g[[i]];
                       While[gg=!=z,
		       p=Polymono[p,{h1+LT[gg][[1]],-h2*LT[gg][[2]]}];
                       gg=Polymono[gg,{LT[gg][[1]],-LT[gg][[2]]}]];
		       c=False,i=i+1]];
                       If[c,r=Polymono[r,LT[p]];
		       p=Polymono[p,{LT[p][[1]],-LT[p][[2]]}]]];{a,r}]
		
		       
		       
		       
Groeb[{f1, f2, ..., fn}]と入力すると、
Groebner基底: {f1, f2, ..., fn, g1, g2, ..., gs}を出力します。

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


(Example)

In[2]:=Groeb[{{{{0},{0},{-1}},{{0,1}}},{{{0,0,-1}},{{0}},{{0}},{{1}}}}]

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