Artifact 8a1d96c90a9c5c6ff90cf797dbd4b056584383065c9c581e3b0e68444a9ffce4:
- Executable file
r37/packages/ncpoly/ncgroeb.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7732) [annotate] [blame] [check-ins using] [more...]
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;