reduce-historical/r37/packages/groebner/groebspa.red

module groebspa;
 
% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
% manipulation of subspaces.
% A subspace among the variables is described by an exponent vector
%  with only zeroes and ones. It terminates with the last
% one. It may be null (nil);

expr procedure vevUnion(e1,e2);
    begin scalar x,y;
       y := vevUnion1(e1,e2);
       x := reverse y;
       if car x = 1 then return y;
       while x and car x = 0 do x := cdr x;
       return reversip x;
    end;

expr procedure vevUnion1(e1,e2);
    if vdpSubspacep(e1,e2) then e2
       else
    if vdpSubspacep(e2,e1) then e1
       else
    if car e1 neq 0 or car e2 neq 0 then 1 . vevUnion1(cdr e1,cdr e2)
       else
          0 . vevUnion1(cdr e1,cdr e2);
           
expr procedure vdpSubspacep(e1,e2);     
% test if e1 describes a subspace from e2
    if null e1 then t
      else
    if null e2 then vdpSpacenullp(e1)
      else
    if car e1 > car e2 then nil
      else
    if e1 = e2 then t
      else
         vdpSubspacep(cdr e1,cdr e2);
          
expr procedure vdpOrthSpacep(e1,e2);  
% test if e1 and e2 describe orthogonal spaces(no intersection);
    if null e1 or null e2 then t
       else
    if car e2 = 0 or car e1 = 0
          then vdpOrthSpacep(cdr e1,cdr e2)
       else nil;

                 
expr procedure vdpSpacenullp(e1);
% test if e1 describes an null space
     if null e1 then t
        else
     if car e1 = 0 then vdpSpacenullp(cdr e1)
        else nil;
 

expr procedure vdpSpace(p);
  % determine the variables of the polynomial.
    begin scalar x,y;
        if vdpzero!? p then return nil;
        x := vdpGetProp(p,'SUBROOM);
        if x then return x;
        x := vevUnion(nil,vdpevlmon p);
        y := vdpred p;
        while not vdpzero!? y do
         <<x := vevUnion(x,vdpevlmon y);
           y := vdpred y>>;
        vdpPutProp (p,'SUBROOM,x);
        return x;
    end;

symbolic procedure vdpUnivariate!?(p);
    if vdpGetProp(p,'UNIVARIATE) then t
     else begin scalar ev; integer n;
         ev := vdpevlmon p;
         for each x in ev do 
           if not(x=0) then n := n#+1;
         if not(n=1) then return nil;
         ev := vdpSpace(p);
         for each x in ev do 
           if not(x=0) then n := n#+1; 
         if not(n=1) then return nil; 
         vdpPutProp(p,'UNIVARIATE,t);
         return t;
     end;
         
endmodule;

end;