reduce-historical/r37/packages/cali/odim.red

module odim;

COMMENT

		##########################################
		##					##
		##   Applications to zerodimensional	##
		##	ideals and modules.		##
		##					##
		##########################################

getkbase returns a k-vector space basis of S^c/M,
odim_borderbasis computes a borderbasis of M,
odim_up finds univariate polynomials in zerodimensional ideals.

END COMMENT;

% -------------- Test for zero dimension -----------------
% For a true answer m must be a gbasis. 

put('dimzerop,'psopfn,'odim!=zerop);
symbolic procedure odim!=zerop m; 
  begin scalar c;
  intf_test m; intf_get(m:=car m);
  if not (c:=get(m,'gbasis)) then 
	put(m,'gbasis,c:=gbasis!* get(m,'basis));
  if dimzerop!* c then return 'yes else return 'no;
  end;

symbolic procedure dimzerop!* m; null odim_parameter m;
  
symbolic procedure odim_parameter m; 
% Return a parameter of the dpmat m or nil, if it is zerodimensional
% or (1).
  odim!=parameter moid_from_dpmat m;

symbolic procedure odim!=parameter m;
  if null m then nil
  else odim!=parameter1 cdar m or odim!=parameter cdr m;

symbolic procedure odim!=parameter1 m;
  if null m then 
	((if u then car u else u)
	where u:= reverse ring_names cali!=basering)
  else if mo_zero!? car m then nil
  else begin scalar b,u;
  u:=for each x in m join if length(b:=mo_support x)=1 then b;
  b:=reverse ring_names cali!=basering; 
  while b and member(car b,u) do b:=cdr b;
  return if b then car b else nil;
  end;

% --- Get a k-base of F/M as a list of monomials ----
% m must be a gbasis for the correct result.

put('getkbase,'psopfn,'odim!=evkbase);
symbolic procedure odim!=evkbase m; 
  begin scalar c;
  intf_test m; intf_get(m:=car m);
  if not (c:=get(m,'gbasis)) then 
	put(m,'gbasis,c:=gbasis!* get(m,'basis));
  return moid_2a getkbase!* c;
  end;

symbolic procedure getkbase!* m;
  if not dimzerop!* m then rederr"dpmat not zerodimensional"  
  else for each u in moid_from_dpmat m join 
        odim!=kbase(mo_from_ei car u,ring_names cali!=basering,cdr u);

symbolic procedure odim!=kbase(mo,n,m);
  if moid_member(mo,m) then nil
  else mo . for each x on n join
                odim!=kbase(mo_inc(mo,car x,1),append(x,nil),m);

% --- Produce an univariate polynomial inside the ideal m ---

symbolic procedure odim_up(a,m);
% Returns a univariate polynomial (of smallest possible degree if m
% is a gbasis) in the variable a inside the zerodimensional ideal m.
% Uses Buchberger's approach.
  if dpmat_cols m>0 or not dimzerop!* m then 
      rederr"univariate polynomials only for zerodimensional ideals"
  else if not member(a,ring_names cali!=basering) then 
    typerr(a,"variable name")  
  else if dpmat_unitideal!? m then dp_fi 1
  else begin scalar b,v,p,l,q,r;
    % l is a list of ( p(a) . NF p(a) ), sorted by lt NF p(a)
    p:=(dp_fi 1 . dp_fi 1); b:=dpmat_list m;  v:=mo_from_a a;
    while cdr p do
      << l:=merge(list p,l,function odim!=greater);
         q:=dp_times_mo(v,car p); 
         r:=red_redpol(b,bas_make(0,dp_times_mo(v,cdr p)));
         p:=odim!=reduce(dp_prod(cdr r,q) . bas_dpoly car r,l);
      >>;
    return 
    if !*bcsimp then car dp_simp car p
    else car p;
    end;     
                
symbolic procedure odim!=greater(a,b); 
    mo_compare(dp_lmon cdr a,dp_lmon cdr b)=1;

symbolic procedure odim!=reduce(a,l);
  if null cdr a or null l or odim!=greater(a, car l) then a
  else if mo_equal!?(dp_lmon cdr a,dp_lmon cdar l) then
    begin scalar z,z1,z2,b; 
    b:=car l; z1:=bc_neg dp_lc cdr a; z2:=dp_lc cdr b;
    if !*bcsimp then
      << if (z:=bc_inv z1) then <<z1:=bc_fi 1; z2:=bc_prod(z2,z)>>
         else
           << z:=bc_gcd(z1,z2);
              z1:=car bc_divmod(z1,z);
              z2:=car bc_divmod(z2,z);
           >>;
      >>;
    a:=dp_sum(dp_times_bc(z2,car a),dp_times_bc(z1,car b)) .
           dp_sum(dp_times_bc(z2,cdr a),dp_times_bc(z1,cdr b));
    return odim!=reduce(a,cdr l)
    end
  else odim!=reduce(a,cdr l);

% ------------------------- Borderbasis -----------------------

symbolic procedure odim_borderbasis m;
% Returns a border basis of the zerodimensional dpmat m as list of
% base elements.
  if not !*noetherian then
	rederr"BORDERBASIS only for non noetherian term orders"
  else if not dimzerop!* m then
	rederr"BORDERBASIS only for zerodimensional ideals or modules"
  else begin scalar b,v,u,mo,bas;
  bas:=bas_zerodelete dpmat_list m;
  mo:=for each x in bas collect dp_lmon bas_dpoly x;
  v:=for each x in ring_names cali!=basering collect mo_from_a x;
  u:=for each x in bas collect
	{dp_lmon bas_dpoly x,red_tailred(bas,x)};
  while u do
  << b:=append(b,u);
     u:=listminimize(
	for each x in u join
	    for each y in v join
		(begin scalar w; w:=mo_sum(first x,y);
		if not listtest(b,w,function(lambda(x,y);car x=y))
			and not odim!=interior(w,mo) then 
			return {{w,y,bas_dpoly second x}}
		end),
	function(lambda(x,y);car x=car y));
     u:=for each x in u collect 
	{first x, 
	red_tailred(bas,bas_make(0,dp_times_mo(second x,third x)))};
  >>;
  return bas_renumber for each x in b collect second x;
  end;

symbolic procedure odim!=interior(m,mo);
% true <=> monomial m is in the interior of the moideal mo.
  begin scalar b; b:=t;
  for each x in mo_support m do
	b:=b and moid_member(mo_diff(m,mo_from_a x),mo);
  return b;
  end;
         
endmodule; % odim

end;