File r38/packages/poly/tdconv.red from the latest check-in


module tdconv; % Procedures for conversion of internal & external
               % expressions defined with total degree ordering.
 
% Authors: Shuichi Moritsugu <y31046@tansei.cc.u-tokyo.ac.jp>
%          and Eiichi Goto.
 
symbolic procedure setunion(l1,l2);
   % Union of two sets.
      if null l2 then l1
        else if member(car l2,l1) then setunion(l1,cdr l2)
        else setunion(append(l1,car l2 . nil),cdr l2);
 
symbolic procedure searchtm term;
   % Search for variables in a term.
      if domainp term then nil
        else caar term . searchpl cdr term;
 
symbolic procedure searchpl poly;
   % Search for variables in a polynomial.
      if domainp poly then nil
        else setunion(searchtm car poly,searchpl cdr poly);
 
symbolic procedure qsort l;
   % Quick sort of variables with lexicographic ordering.
      begin scalar a,l1,l2,ll;
            if null l then return nil;
            a:=car l; ll:=cdr l;
            loop : if null ll then go to exit;
   % We need ORDOP rather than ORDERP in next line to be consistent
   % with the way that REDUCE orders expressions.
                   if ordop(a,car ll) then l2:=car ll . l2
                                       else l1:=car ll . l1;
                   ll:=cdr ll; go to loop;
            exit : return append(qsort l1,a . qsort l2);
      end;
 
symbolic procedure mapins(ep,cfl);
   % Insert of exponent into coefficient list.
      if null cfl then nil
        else ((ep . caar cfl) . cdar cfl) . mapins(ep,cdr cfl);
 
symbolic procedure mkzl n;
   % Making of zero-list (length = n-1).
      if n=1 then nil else 0 . mkzl(n-1);
 
symbolic procedure sq2sstm(sqtm,vd);
   % Transformation of term from sq to ss.
      begin scalar ep,cf,cfl;
            if caar sqtm=caar vd
              then <<cf:=cdr sqtm; ep:=cdar sqtm;
                     if domainp cf
                       then return ((ep . mkzl cdr vd) . cf) . nil
                       else cfl:=sq2sscfpl(cf,cdar vd . sub1 cdr vd)>>
              else <<cfl:=sq2sscfpl(sqtm . nil,cdar vd . sub1 cdr vd);
                     ep:=0>>;
            return mapins(ep,cfl);
      end;
 
symbolic procedure sq2sscfpl(cfpl,vd);
   % Transformation of coefficient polynomial from sq to ss.
      if null cfpl then nil
        else if domainp cfpl then (mkzl(cdr vd+1) . cfpl) . nil
        else append(sq2sstm(car cfpl,vd),sq2sscfpl(cdr cfpl,vd));
 
symbolic procedure sq2sspl(sqpl,vd);
   % Transformation of polynomial from sq to ss.
      if domainp sqpl then sqpl
        else append(sq2sstm(car sqpl,vd),sq2sspl(cdr sqpl,vd));
 
symbolic procedure sdlist nm;
   % Classification of ss by the degree of main variable.
      begin scalar anslist,partlist,n,rnm;
            rnm:=nm;
            init : n:=caaar rnm; partlist:= car rnm . nil;
            loop : rnm:=cdr rnm;
                   if null rnm
                     then <<anslist:=append(anslist,partlist . nil);
                            go to exit>>;
                   if domainp rnm
                     then <<anslist:=append(append(anslist,
                                                   partlist . nil),
                                            rnm);
                            go to exit>>;
                   if n=caaar rnm
                     then <<partlist:=append(partlist,car rnm . nil);
                            go to loop>>
                     else <<anslist:=append(anslist,partlist . nil);
                            go to init>>;
            exit : return anslist;
      end;
 
symbolic procedure univsdl2sq(var,sdl);
   % Transformation from univariate ss to sq.
      if domainp sdl then sdl
        else if zerop caaaar sdl then cdaar sdl
        else ((var . caaaar sdl) . cdaar sdl) . univsdl2sq(var,cdr sdl);
 
symbolic procedure mapdel sdl;
   % Deletion of the exponent of main variable from ss.
      if null sdl then nil
        else (cdaar sdl . cdar sdl) . mapdel cdr sdl;
 
symbolic procedure mulvsdl2sq(vd,sdl);
   % Transformation from multivariate ss to sq.
      if domainp sdl then sdl
        else if zerop caaaar sdl
               then if domainp cdr sdl and cdr sdl
                      then append(sdl2sq(cdar vd . sub1 cdr vd,
                                         sdlist mapdel car sdl),
                                  cdr sdl)
                      else sdl2sq(cdar vd . sub1 cdr vd,
                                  sdlist mapdel car sdl)
               else ((caar vd . caaaar sdl)
                      . sdl2sq(cdar vd . sub1 cdr vd,
                               sdlist mapdel car sdl))
                    . mulvsdl2sq(vd,cdr sdl);
 
symbolic procedure sdl2sq(vd,sdl);
   % Transformation from classified ss to sq.
      if cdr vd=1 then univsdl2sq(caar vd,sdl)
                   else mulvsdl2sq(vd,sdl);
 
symbolic procedure termorder1(term1,term2);
   % Comparison of ordering between two terms (purely lexicographic
   % ordering).
      if null term1 then 0
        else if zerop term1 and zerop term2 then 0
        else if zerop term1 then -1
        else if zerop term2 then 1
        else if car term1<car term2 then -1
        else if car term1>car term2 then 1
        else termorder1(cdr term1,cdr term2);
 
symbolic procedure listsum l;
   % Total degree.
      if null l then 0 else car l+listsum cdr l;
 
symbolic procedure termorder(term1,term2);
   % Comparison of ordering between two terms (total degree and
   % lexicographic ordering).
      begin scalar s1,s2;
            if null term1 then 0
              else if zerop term1 and zerop term2 then 0
              else if zerop term1 then -1
              else if zerop term2 then 1;
              s1:=listsum term1; s2:=listsum term2;
              return if s1=s2 then termorder1(term1,term2)
                       else if s1<s2 then -1 else 1;
      end;
 
symbolic procedure xxsort l;
   sort(l,function(lambda (a, b); termorder(car a,car b)<0));

% symbolic procedure xxsort l;
%  %Sort of terms with present ordering.
%     begin scalar a,l1,l2,ll;
%           if null l then return nil;
%           a:=car l; ll:=cdr l;
%           loop : if null ll then go to exit;
%                  if termorder(car a,caar ll)<0
%                    then l1:=car ll . l1
%                    else l2:=car ll . l2;
%                  ll:=cdr ll; go to loop;
%           exit : return append(xxsort l1,a . xxsort l2);
%     end;
 
symbolic procedure lxsort l;
   sort(l,function(lambda (a, b); termorder1(car a,car b)<0));

% symbolic procedure lxsort l;
%  % Sort of terms with purely lexicographic ordering.
%     begin scalar a,l1,l2,ll;
%           if null l then return nil;
%           a:=car l; ll:=cdr l;
%           loop : if null ll then go to exit;
%                  if termorder1(car a,caar ll)<0
%                    then l1:=car ll . l1
%                    else l2:=car ll . l2;
%                  ll:=cdr ll; go to loop;
%           exit : return append(lxsort l1,a . lxsort l2);
%     end;
 
symbolic procedure delet(a,l);
   %Deletion from list.
      if null a then l
        else if null l or a=l then nil
        else if a=car l then cdr l
        else car l . delet(a,cdr l);
 
symbolic procedure lx2xx ss;
   % Transformation from lex. to another normal ordering.
      begin scalar nm,ct;
            if domainp ss or domainp car ss then return ss;
	    nm:=cadr ss; ct:=cdr lastnondomain nm;
            return car ss . (append(xxsort delet(ct,nm),ct) . cddr ss);
      end;
 
symbolic procedure lastnondomain u;
   % Return the last non-domain pair of the list u.
   if domainp u then errach list("non-domain",u)
    else if domainp cdr u then u
    else lastnondomain cdr u;

symbolic procedure xx2lx ss;
   % Transformation from normal ordering to lex.
      begin scalar nm,ct;
            if domainp ss or domainp car ss then return ss;
	    nm:=cadr ss; ct:=cdr lastnondomain nm;
            return car ss . (append(lxsort delet(ct,nm),ct) . cddr ss);
      end;
 
symbolic procedure sf2ss f;
   % Transformation from sf to ss (with denominator 1).
      begin scalar vl,vd;
            if domainp f then return f;
            vl:=searchpl f; vd:=qsort vl . length vl;
            return lx2xx(vd . (sq2sspl(f,vd) . 1));
      end;
 
symbolic procedure ss2sf s;
   % Transformation from ss to sf (neglecting the denominator).
      if domainp s then s
        else sdl2sq(car s , sdlist cadr xx2lx s );
 
endmodule;
 
end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]