reduce-historical/r38/packages/xideal/xreduct.red

module xreduct;

% Normal form algorithms

% Author: David Hartley


fluid '(!*trxmod !*trxideal xtruncate!*);


infix xmod;
precedence xmod,freeof;
put('xmod,'rtypefn,'getrtypecar);
put('xmod,'listfn,'xmodlist);
put('xmod,'simpfn,'simpxmod);


symbolic procedure simpxmod u;
   % u:{prefix,prefix} -> simpxmod:sq
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmod");
   x := getrlist aeval cadr u;
   return !*pf2sq repartit xreduce(xpartitop car u,
                                   for each g in x join
                                      if g := xpartitop g then {g});
   end;


symbolic procedure xmodlist(u,v);
   % u:{prefix,prefix},v:bool -> xmodlist:prefix
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmod");
   x := getrlist aeval cadr u;
   u := foreach f in getrlist aeval car u collect xpartitop f;
   x := for each f in x join
           if f := xpartitop f then {f};
   return makelist foreach f in u join
      if f := xreduce(f,x) then {!*q2a1(!*pf2sq repartit f,v)};
   end;


infix xmodideal;
precedence xmodideal,freeof;
put('xmodideal,'rtypefn,'getrtypecar);
put('xmodideal,'listfn,'xmodideallist);
put('xmodideal,'simpfn,'simpxmodideal);


symbolic procedure simpxmodideal u;
   % u:{prefix,prefix} -> simpxmodideal:sq
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmodideal");
   x := getrlist aeval cadr u;
   u := xpartitop car u;
   xtruncate!* := xmaxdegree u;
   x := for each f in x join if f := xpartitop f then {f};
   foreach f in x do if not xhomogeneous f then xtruncate!* := nil;
   x := xidealpf x where !*trxmod = nil; % is this desirable?
   return !*pf2sq repartit xreduce(u,x);
   end;


symbolic procedure xmodideallist(u,v);
   % u:{prefix,prefix},v:bool -> xmodideallist:prefix
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmodideal");
   x := getrlist aeval cadr u;
   u := foreach f in getrlist aeval car u collect xpartitop f;
   xtruncate!* := eval('max . foreach f in u collect xmaxdegree f);
   x := for each f in x join if f := xpartitop f then {f};
   foreach f in x do if not xhomogeneous f then xtruncate!* := nil;
   x := xidealpf x where !*trxmod = nil; % is this desirable?
   return makelist foreach f in u join
      if f := xreduce(f,x) then {!*q2a1(!*pf2sq repartit f,v)};
   end;


put('xauto,'rtypefn,'quotelist);
put('xauto,'listfn,'xautolist);

symbolic procedure xautolist(u,v);
   % u:{prefix},v:bool -> xautolist:prefix
   begin scalar x;
   if length u neq 1 then
      rerror(xideal,0,"Wrong number of arguments to xauto");
   u := foreach f in getrlist aeval car u collect xpartitop f;
   return makelist foreach f in xautoreduce u join
      {!*q2a1(!*pf2sq repartit f,v)};
   end;


symbolic procedure xreduce(f,p);
   % f:pf, p:list of pf -> xreduce:pf
   % returns left normal form of f wrt p
   % l contains reduction chain (not used at present).
   begin scalar g,l;
   l := nil . nil;
   if !*trxmod then
    <<writepri(mkquote preppf f,'nil);
      writepri(" =",'last)>>;
   g := xreduce1(f,p,l);
   if !*trxmod then 
    <<writepri("   ",'first);
      writepri(mkquote preppf g,'last)>>;
   return g;
   end;


symbolic procedure xreduce1(f,p,l);
   % f:pf, p:list of pf, l:list of {pf,pf} -> xreduce1:pf
   % Returns left normal form of f wrt p. Chain of reducing poly's and
   % cofactors stored in l as side-effect.
   if (f := weak_xreduce1(f,p,l)) then lt f .+ xreduce1(red f,p,l);


symbolic procedure weak_xreduce(f,p);
   % f:pf, p:list of pf, result:pf
   % Returns weak left normal form of f wrt p (i.e. lpow f is
   % irreducible).
   begin scalar g,l;
   l := nil . nil;
   if !*trxmod then
    <<writepri(mkquote preppf f,'nil);
      writepri(" =",'last)>>;
   g := weak_xreduce1(f,p,l);
   if !*trxmod then 
    <<writepri("   ",'first);
      writepri(mkquote preppf g,'last)>>;
   return g;
   end;


symbolic procedure weak_xreduce1(f,p,l);
   % f:pf, p:list of pf, l:list of {pf,pf} -> weak_xreduce1:pf
   % Returns weak left normal form of f wrt p (i.e. lpow f is
   % irreducible).
   % Chain of reducing poly's and cofactors stored in l as side-effect.
   begin scalar q,g,h,c,r;
   q := p;
   while f and q do
     begin
     g := car q; q := cdr q;
     if (r := xdiv(xval g,xval f)) then
       begin
       r := !*k2pf mknwedge r;
       h := wedgepf(r,g); % NB: left multiplication here
       c := quotsq(lc f,lc h);
       f := subs2pf addpf(f,multpfsq(h,negsq c));
       if !*trxmod then l := nconc(l,{{multpfsq(r,c),g}});
       if !*trxmod then
        <<writepri("   ",'first);
       	  writepri(mkquote 
	     {'wedge,preppf multpfsq(r,c),preppf g},nil);
       	  writepri(" +",'last);>>;
       q := p;
       end;
     end;
   return f;
   end;


symbolic procedure xautoreduce F;
   % F:list of pf -> weak_xautoreduce:list of pf
   % returns autoreduced form of F,
   % sorted in increasing order of leading terms
   xautoreduce1 weak_xautoreduce F;


symbolic procedure xautoreduce1 G;
   % G:list of pf -> xautoreduce1:list of pf
   % G is weakly autoreduced, result is autoreduced and sorted
   begin scalar H;
   H := reversip sort(G,'pfordp); % otherwise need to reduce wrt H too.
   G := {};
   while H do
     begin scalar k;
     k := car H; H := cdr H;
     k := xreduce(k,G);
     if k then G := k . G;
     end;
   return reversip G;
   end;


symbolic procedure weak_xautoreduce F;
   % F:list of pf -> weak_xautoreduce:list of pf
   % returns weakly autoreduced form of F
   weak_xautoreduce1(F,{});


symbolic procedure weak_xautoreduce1(F,G);
   % F,G:list of pf -> weak_xautoreduce1:list of pf
   % G is (weakly) autoreduced, F may be reducible wrt G.
   begin
   while F do
      begin scalar k;
      k := car F; F := cdr F;
      if k := weak_xreduce(k,G) then
        begin
        k := xnormalise k;
        foreach h in G do
           if xdiv(xval k,xval h) then
            <<F := h . F;
              G := delete(h,G)>>;
        G := append(G,{k});
        end;
      end;
   return G;
   end;


% symbolic procedure print_reduction_chain(f,l,g);
%    % f,g:pf, l:list of {pf,pf} -> print_reduction_chain:nil
%    begin
%    writepri(mkquote preppf f,'nil);
%    writepri(" =",'last);
%    foreach pr in cdr l do
%      <<writepri("   ",'first);
%        writepri(mkquote preppf car pr,nil);
%        writepri(mkquote '(wedge " " " "),'nil);
%        writepri("(",'nil);
%        writepri(mkquote preppf cadr pr,nil);
%        writepri(") +",'last);>>;
%    writepri("   ",'first);
%    writepri(mkquote preppf g,'last);
%    end;

endmodule;

end;