File r37/packages/ncpoly/ncgroeb.red artifact 8a1d96c90a part of check-in 5f584e9b52


module ncgroeb; % Groebner for noncommutative one sided ideals.

% Author: H. Melenk, ZIB Berlin, J. Apel, University of Leipzig.

% Following Carlo Traverso's model.

fluid '(pcount!* ncdipbase!* ncdipvars!* !*gsugar 
        !*nc!-traverso!-sloppy 
        !*trgroebfull    % print a full trace
        !*ncg!-right     % if t, compute in right ideal
        nccof!*          % cofactors after a reduction step
        factortime!* groetime!* hcount!* mcount!* fcount!* bcount!*
        b4count!* hzerocount!* basecount!* glterms!* groecontcount!*
        !*vdpinteger !*trgroeb !*trgroebs);

global '(glterms);

switch gsugar;

symbolic procedure nc!-groebeval u;
  begin scalar g;
    nc!-gsetup();
    u:=car u;
    g := for each p in cdr listeval(u,nil) collect a2ncvdp reval p;
    g := nc!-traverso g;
    return 'list.for each w in g collect vdp2a w;
  end;

put('nc_groebner,'psopfn,'nc!-groebeval);

symbolic procedure nc!-preduce u;
  begin scalar g,p,!*gsugar;
    nc!-gsetup();
    g := for each p in cdr listeval(cadr u,nil) collect a2ncvdp reval p;
    p := a2ncvdp reval car u;
    p := nc!-normalform(p,g,nil,nil);
    return vdp2a p;
  end;

put('nc_preduce,'psopfn,'nc!-preduce);

symbolic procedure nc!-div u;
  begin scalar g,p,!*gsugar;
    nc!-gsetup();
    g := a2ncvdp reval cadr u;
    p := a2ncvdp reval car u;
    p := nc!-qremf(p,g);
    return {'list,vdp2a car p,vdp2a cdr p};
  end;

put('nc_divide,'psopfn,'nc!-div);

symbolic procedure nc!-gsetup();
 <<    factortime!* := 0;
       groetime!*   := time();
       vdpinit2 ncdipvars!*;
       vdponepol(); % we construct dynamically
       hcount!* := 0; mcount!* := 0; fcount!* := 0; pcount!* := 0;
       bcount!* := 0; b4count!* := 0; hzerocount!* := 0;
       basecount!* := 0; !*gcd := t; glterms := list('list);
       groecontcount!* := 10;
       !*nc!-traverso!-sloppy:=t;
       !*vdpinteger:=t;
       if null ncdipbase!* then 
        rederr "non-commutative ideal initialization missing";
>>;

!*gsugar := t;

symbolic procedure nc!-traverso g0;
  begin scalar g,d,s,h,p;

  g0:=for each fj in g0 collect
                gsetsugar(vdpenumerate vdpsimpcont fj,nil);

  main_loop:
    if null g0 and null d then return nc!-traverso!-final g;

    if g0 then 
         <<h:=car g0;g0:=cdr g0;
           p := list(nil,h,h)
         >>
       else
         <<p := car d;
           d := cdr d;
           s := nc!-spoly (cadr p, caddr p);
                  !*trgroeb and groebmess3 (p,s);
           h:=groebsimpcontnormalform nc!-normalform(s,g,'list,t);
           if vdpzero!? h then 
           <<!*trgroeb and groebmess4(p,d); goto main_loop>>;

            if vevzero!? vdpevlmon h then % base 1 found
                  <<   !*trgroeb and groebmess5(p,h);
                       d:=g:=g0:=nil;
                  >>;       
         >>;

         h := groebenumerate h; !*trgroeb and groebmess5(p,h);

          % new pair list
         d := nc!-traverso!-pairlist(h,g,d);
          
          % new basis
         g := nconc(g,{h});
         goto main_loop;
   end;

symbolic procedure nc!-traverso!-pairlist(gk,g,d);
  % gk: new polynomial,
  % g:  current basis,
  % d:  old pair list.
  begin scalar ev,r,n,nn,q;
     % delete triange relations from old pair list.
    d := nc!-traverso!-pairs!-discard1(gk,d);

     % build new pair list.
    ev := vdpevlmon gk;

    for each p in g do n := groebmakepair(p,gk) . n;

     % discard multiples: collect survivers in n

    <<
      if !*nc!-traverso!-sloppy then !*gsugar:=nil;
      n := groebcplistsort(n)
    >>   where !*gsugar=!*gsugar;

    nn := n; n:=nil;
    for each p in nn do
    <<q:=nil;
      for each r in n do 
        q:=q or vevdivides!?(car r,car p);
      if not q then n:=groebcplistsortin(p,n);
    >>;

    return groebcplistmerge(d,reversip n);
  end;

symbolic procedure nc!-traverso!-pairs!-discard1(gk,d);
  % crit B 
  begin scalar gi,gj,tij,evk;
   evk:=vdpevlmon gk;
   for each pij in d do
   <<tij := car pij; gi:=cadr pij; gj:=caddr pij;
    if vevstrictlydivides!?(tt(gi,gk),tij)
       and vevstrictlydivides!?(tt(gj,gk),tij)
      then d:=delete(pij,d);
   >>;
   return d;
  end;

symbolic procedure vevstrictlydivides!?(ev1,ev2);
   not(ev1=ev2) and vevdivides!?(ev1,ev2); 

symbolic procedure nc!-traverso!-final g;
  % final reduction and sorting;
  begin scalar r,p,!*gsugar;
   g:=vdplsort g; % descending
   while g do
   <<p:=car g; g:=cdr g;
     if not groebsearchinlist(vdpevlmon p,g) then
       r := groebsimpcontnormalform nc!-normalform(p,g,'list,t) . r;
   >>;
   return reversip r;
  end;

symbolic procedure nc!-fullprint(comm,cu,u,tu,cv,v,tv,r);
  <<terpri(); prin2 "COMPUTE ";prin2t comm;
    vdpprin2 cu; prin2 " * P("; prin2 vdpnumber u; prin2 ")=> ";
    vdpprint tu;
    vdpprin2 cv; prin2 " * P("; prin2 vdpnumber v; prin2 ")=> ";
    vdpprint tv;
    prin2t "               ====>";
    vdpprint r;
    prin2t " - - - - - - -";
  >>;

symbolic procedure nc!-spoly(u,v);
 % Compute S-polynomial.
  begin scalar cu,cv,tu,tv,bl,l,r;
    l := vev!-cofac(vdpevlmon u,vdpevlmon v);
    bl :=vbc!-cofac(vdplbc u,vdplbc v);
    cu := vdpfmon(car bl, car l);
    cv := vdpfmon(cdr bl, cdr l);
    if !*ncg!-right  then
    << tu:=vdp!-nc!-prod(u,cu);
       tv:=vdp!-nc!-prod(v,cv);
    >>
    else
    << tu:=vdp!-nc!-prod(cu,u);
       tv:=vdp!-nc!-prod(cv,v);
    >>;
    nccof!* := cu.cv;
    r:=vdpdif(tu,tv);
    if !*trgroebfull then
      nc!-fullprint("S polynomial:",cu,u,tu,cv,v,tv,r);
    return r;
  end;

symbolic procedure nc!-qremf(u,v);
 % compute (u/v, remainder(u,v)).
  begin scalar ev,cv,q;
   q:=a2vdp 0;
   if vdpzero!? u then return q.q;
   ev:=vdpevlmon v; cv:=vdplbc v;
   while not vdpzero!? u and vevdivides!?(ev,vdpevlmon u) do
   <<u:=nc!-reduce1(u,vdplbc u,vdpevlmon u, v);
     q:=if !*ncg!-right then vdp!-nc!-prod(q,car nccof!*)
                        else vdp!-nc!-prod(car nccof!*,q);
     q:=vdpsum(q,cdr nccof!*);
   >>;
   return q.u;
 end;
     
symbolic procedure nc!-reduce1(u,bu,eu,v);
 % Compute u - w*v such that monomial (bu*x^eu) in u is deleted.
  begin scalar cu,cv,tu,tv,bl,l,r;
    l := vev!-cofac(eu,vdpevlmon v);
    bl :=vbc!-cofac(bu,vdplbc v);
    cu := vdpfmon(car bl, car l);
    cv := vdpfmon(cdr bl, cdr l);
    if !*ncg!-right then
    << tu := vdp!-nc!-prod(u,cu);
       tv := vdp!-nc!-prod(v,cv);
    >>
    else
    << tu := vdp!-nc!-prod(cu,u);
       tv := vdp!-nc!-prod(cv,v);
    >>;
    nccof!* := cu.cv;
    r:=vdpdif(tu,tv);
    if !*trgroebfull then
      nc!-fullprint("Reduction step:",cu,u,tu,cv,v,tv,r);
     %%%% if null yesp "cont" then rederr "abort";
    return r;
  end;

symbolic procedure nc!-normalform(s,g,mode,cmode); 
   <<mode := nil; nc!-normalform2(s,g,cmode)>>;
     
symbolic procedure nc!-normalform2(s,g,cmode);
 % Normal form 2: full reduction.
  begin scalar g0,ev,f,s1,b;
   loop:
     s1:= s;
        % unwind to last reduction point.
     if ev then while vevcomp(vdpevlmon s1,ev)>0 do s1:=vdpred s1;
    loop2:
     if vdpzero!? s1 then return s;
     ev := vdpevlmon s1; b:=vdplbc s1;
     g0 := g;
     f := nil;
     while null f and g0 do
       if vevdivides!?(vdpevlmon car g0,ev) then f:=car g0 else
         g0:=cdr g0;
     if null f then <<s1:=vdpred s1; goto loop2>>;
     s:=nc!-reduce1(s,b,ev,f);
     if !*trgroebs then <<prin2 "//"; prin2 vdpnumber f>>;
     if cmode then s:=groebsimpcontnormalform s;
     goto loop;
   end;

endmodule;

end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]