File r38/packages/xideal/xcrit.red artifact 7d3d398699 part of check-in ab67b20f90

module xcrit;

% Critical pairs, critical values

% Author: David Hartley

Comment. Critical pairs are stored as

	crit_pr	::= {key, type, pf, pf}
	key	::= mon
	type	::= 'spoly_pair | 'wedge_pair | 'xcomm_pair

endcomment;


fluid '(xvarlist!* zerodivs!* xtruncate!* !*twosided);


symbolic procedure critical_pairs(q,p,c);
   % q,p:list of pf, c:xset -> critical_pairs:xset
   % add critical pairs for new poly's q to existing xset c,
   % which is based on old poly's p.
   begin scalar f;
   foreach l on q do
     begin
     f := car l;
     foreach g in cdr l do
       (if pr then add_item(pr,c)) where pr = make_spoly_pair(f,g);
     foreach g in p do
       (if pr then add_item(pr,c)) where pr = make_spoly_pair(f,g);
     foreach x in zerodivs!* do
       (if pr then add_item(pr,c)) where pr = make_wedge_pair(x,f);
     foreach x in if !*twosided then xvarlist!* do
       (if pr then add_item(pr,c)) where pr = make_xcomm_pair(x,f);
     end;
   return c;
   end;


symbolic procedure remove_critical_pairs(G,P);
   % G:list of pf, P:xset -> remove_critical_pairs:xset
   % Remove critical pairs for old poly's G from existing xset P.
   <<if G then remove_items(P,G); P>>;


symbolic procedure make_spoly_pair(f,g);
   % f,g:pf -> make_spoly_pair:crit_pr|nil
   % construct critical pair (spoly) for f and g in canonical order
   % return nil if simple criteria fail
   if pfordp(g,f) then make_spoly_pair(g,f) else
   and(t,
       red f or red g,
       not triviallcm(l,xval f,xval g),
       not xdegreecheck mknwedge l,
       {l,'spoly_pair,f,g})
   where l = xlcm(xval f,xval g);


symbolic procedure triviallcm(l,p,q);
   % l,p,q:mon -> triviallcm:bool
   % l is xlcm(p,q), result is t if l = p . q
   xdiv(p,l) = q;


symbolic procedure xdegreecheck u;
   % u:lpow pf -> xdegreecheck:bool
   % result is t if degree of u exceeds truncation
   % degree in graded GB's
   xtruncate!* and xdegree u > xtruncate!*;


symbolic procedure make_wedge_pair(x,f);
   % x:kernel, f:pf -> make_wedge_pair:crit_pr|nil
   % construct critical pair (wedge) for x and f
   % return nil if simple criteria fail
   and(!*twosided and not xtruncate!* or x memq xval f,
       not overall_factor(x,f),
       not xdegreecheck mknwedge l,
       {l,'wedge_pair,!*k2pf x,f})
   where l = xlcm({x,x},xval f);


symbolic procedure overall_factor(x,f);
   % x:kernel,f:pf -> overall_factor:bool
   null f or x memq xval f and overall_factor(x,red f);


symbolic procedure make_xcomm_pair(x,f);
   % x:kernel, f:pf -> make_xcomm_pair:crit_pr|nil
   % construct critical pair (commutator) for x and f
   % return nil if simple criteria fail
   and(!*twosided,
       not xtruncate!*,       % left ideal = right ideal if homogeneous.
       {xval f,'xcomm_pair,!*k2pf x,f});


symbolic procedure critical_element pr;
   % pr:crit_pr -> critical_element:pf
   % calculate a critical element for pr
   apply1(pr_type pr,pr);


symbolic procedure spoly_pair pr;
   % pr:crit_pr -> spoly_pair:pf
   % calculate a critical element for pr
   begin scalar l,f,g;
   f := pr_lhs pr; g := pr_rhs pr;
   l := xkey pr;
   f := wedgepf(!*k2pf mknwedge xdiv(xval f,l),f); % left multiplication
   g := wedgepf(!*k2pf mknwedge xdiv(xval g,l),g); % left multiplication
   return addpf(multpfsq(f,lc g),negpf multpfsq(g,lc f)); % normalise?
   end;


symbolic procedure wedge_pair pr;
   % pr:crit_pr -> wedge_pair:pf
   % calculate a critical element for pr
   if !*twosided and not xdiv(xval pr_lhs pr,xval pr_rhs pr) then
     wedgepf(wedgepf(pr_lhs pr,pr_rhs pr),pr_lhs pr) % split cofactor
   else wedgepf(pr_lhs pr,pr_rhs pr);


symbolic procedure xcomm_pair pr;
   % pr:crit_pr -> xcomm_pair:pf
   % calculate a critical element for pr
   addpf(wedgepf(pr_lhs pr,pr_rhs pr),
         if evenp xdegreemon xval pr_rhs pr
            then wedgepf(pr_rhs pr,negpf pr_lhs pr)
            else wedgepf(pr_rhs pr,pr_lhs pr));

endmodule;

end;