Division Algorithm(右からの非可換の除法定理)のプログラム


In[1]:=
NCRightPolyDiv[poly_,divs_,monoorder_,valueorder_]:=
  NCRightPolyDiv[poly,divs,monoorder,valueorder]=
    Module[{LT2,PolyList,ListPoly,Polymono2,sig,PolyDiv2,pp},
      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[LT2[g[[i]]][[2]],h1]*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[LT2[gg][[2]],h1]*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}];
      pp=PolyDiv2[Flatten[PolyList[{poly},valueorder],1],
          PolyList[divs,valueorder]];{ListPoly[pp[[1]],valueorder],
        ListPoly[{pp[[2]]},valueorder][[1]]}]   
		       
		       
		       
NCRightPolyDiv[f, {f1, f2, ..., fn},monomialorder,valueorder]と入力すると、
{{a1, a2, ..., an}, r}を出力します。

但し、任意の異なる変数 Xi と Xj に対し、XiXj=ーXjXi とする非可換多項式環で、monomial orderは、weight matrix で入力し(lex orderとgrlex orderとgrevlex orderは、それぞれ、 lex、grlex、grevlex と入力)、f, f1, f2, ..., fn, a1, a2, ..., an, r は多項式です。fをf1, f2, ..., fn という順番で左から割っていったときのそれぞれの商が、a1, a2, ..., an で、余りが、r です。	
( i.e.  f=f1*a1+f2*a2+・・・+fn*an+r を満たしている。)	


(Example)

In[2]:=NCRightPolyDiv[x*y^2+1,{x*y+1,y+1},lex,{x,y}]

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