左イデアルの被約Groebner基底を計算するプログラム


In[1]:=
NCLeftGroebner[generator_,monoorder_,valueorder_]:=
  NCLeftGroebner[generator,monoorder,valueorder]=
    Module[{LT2,ListPoly,PolyList,Polymono2,sig,PolyDiv2,S2,Groeb2,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_]:=
        PolyList[F,val]=
          Module[{s,PolyListone},
            PolyListone[f_,v_]:=
              PolyListone[f,v]=
                Module[{getcoeff,aa,bb},
                  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]}]}]];aa=MonomialList[f];
                  bb=Length[aa];Table[getcoeff[aa[[i]],v],{i,1,bb}]];
            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];
      sig[le_,ri_]:=
        sig[le,ri]=
          Module[{s},
            s=Length[le];(-1)^(
                Sum[Sum[le[[b]],{b,a+1,s}]*ri[[a]],{a,1,s-1}])];
      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=sig[h1,LT2[g[[i]]][[2]]]*LT2[p][[1]]/(LT2[g[[i]]][[1]]);
                  a=ReplacePart[a,Polymono2[a[[i]],{h2,h1}],i];gg=g[[i]];
                  While[gg=!={},
                    p=Polymono2[
                        p,{-sig[h1,LT2[gg][[2]]]*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,{sig[a[[2]],LT2[ff][[2]]]*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,{-sig[a[[2]],LT2[f][[2]]]*sig[b[[2]],LT2[g][[2]]]*
                      sig[b[[2]],LT2[gg][[2]]]*b[[1]]*LT2[gg][[1]],
                    b[[2]]+LT2[gg][[2]]}];
              gg=Polymono2[gg,{-LT2[gg][[1]],LT2[gg][[2]]}]];aa];
      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[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];
      ListPoly[RedGroeb[PolyList[generator,valueorder]],valueorder]]

													
										
		       
		       
		       
NCLeftGroebner[{f1, f2, ..., fn},monomialorder,valueorder]と入力すると、
指定したmonomial orderと、変数のorderに関する、左イデアル<f1, ..., fn> の被約Groebner基底: {g1, g2, ..., gs}を出力します。

但し、任意の異なる変数 Xi と Xj に対し、XiXj=ーXjXi とする非可換多項式環で、monomial orderは、weight matrix で入力し(lex orderとgrlex orderとgrevlex orderは、それぞれ、 lex、grlex、grevlex と入力)、f1, f2, ..., fn, g1, g2, ..., gs, は多項式です。


(Example)

In[2]:=NCLeftGroebner[{x*z-y^2,x^3-z^2},lex,{x,y,z}]

Out[2]={-y^2+x*z, x^3-z^2, x^2*y^2+z^3, x*y^4+z^4, y^2*z^2, y^6, y^4*z, z^5}

In[3]:=NCLeftGroebner[{x*z-y^2,x^3-z^2},grlex,{x,y,z}]

Out[3]={-y^2+x*z, x^3-z^2, x^2*y^2+z^3, x*y^4+z^4, y^2*z^2, y^6, y^4*z, z^5}

In[4]:=NCLeftGroebner[{x*z-y^2,x^3-z^2},grevlex,{x,y,z}]

Out[4]={y^2-x*z, x^3-z^2, x*z^3, z^5}
 
In[5]:=NCLeftGroebner[{x*z-y^2,x^3-z^2},{{1,1,1},{1,1,0},{1,0,0}},{x,y,z}]

Out[5]={y^2-x*z, x^3-z^2, x*z^3, z^5}