reduce-historical/r38/packages/alg/order.red

module order; % Functions for internal ordering of expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1999 Anthony C. Hearn.  All rights reserved.

fluid '(kord!*);

% symbolic procedure ordad(a,u);
%   if null u then list a
%    else if ordp(a,car u) then a . u
%    else car u . ordad(a,cdr u);

% This definition, due to A.C. Norman, avoids recursion.

symbolic procedure ordad(a,u);
   begin scalar r;
      while u and not ordp(a,car u) do <<r := car u . r; u := cdr u>>;
      u := a . u;
      while r do <<a := cdr r; rplacd(r,u); u := r; r := a>>;
      return u
   end;

symbolic procedure ordn u;
   if null u then nil
    else if null cdr u then u
    else if null cddr u then ord2(car u,cadr u)
    else ordad(car u,ordn cdr u);

symbolic procedure ord2(u,v);
   if ordp(u,v) then list(u,v) else list(v,u);

symbolic procedure ordp(u,v);
   % Returns TRUE if U ordered ahead or equal to V, NIL otherwise.
   % An expression with more structure at a given level is ordered
   % ahead of one with less.
   if null u then null v
    else if null v then t
    else if vectorp u then if vectorp v then ordpv(u,v) else atom v
    else if atom u
       then if atom v
		then if numberp u then numberp v and not(u<v)
		      else if idp v then orderp(u,v)
		      else numberp v
%            else flagp(car v,'noncom)
	     else nil
%   else if atom v then not flagp(car u,'noncom)
    else if atom v then t
    % I used to think the additional noncom check was needed here, but
    % it can lead to confusing results.
%   else if car u=car v then ordp(cdr u,cdr v)
%   else if car u=car v then flagp(car u,'noncom) or ordpl(cdr u,cdr v)
    else if car u=car v then ordpl(cdr u,cdr v)
    else if flagp(car u,'noncom)
     then if flagp(car v,'noncom) then ordp(car u, car v) else t
    else if flagp(car v,'noncom) then nil
    else ordp(car u,car v);

symbolic procedure ordpl(u,v);
   % Returns TRUE if list U ordered ahead or equal to V, NIL otherwise.
   % We also allow for a dotted pair.
   if atom u then ordp(u,v)
    else if atom v then t
    else if car u=car v then ordpl(cdr u,cdr v)
    else ordp(car u,car v);

symbolic procedure ordpv(u,v);
   % U and v are vectors. Set up comparison loop.
   ordpv1(u,v,-1,upbv u,upbv v);

symbolic procedure ordpv1(u,v,i,lu,lv);
   if (i:=i#+1)>lu then i>lv
    else (if x=y then ordpv1(u,v,i,lu,lv) else ordp(x,y))
	  where x=getv(u,i),y=getv(v,i);

symbolic procedure ordop(u,v);
   begin scalar x;
        x := kord!*;
    a:  if null x then return ordp(u,v)
         else if u eq car x then return t
         else if v eq car x then return;
        x := cdr x;
        go to a
   end;

symbolic procedure ordpp(u,v);
   % This version is used for addition, where NONCOM properties aren't
   % relevant.
   begin scalar x;
	if car u eq car v then return cdr u>cdr v;
        x := kord!*;
	u := car u;
	v := car v;
    a:  if null x then return ordpa(u,v)
         else if u eq car x then return t
	 else if v eq car x then return nil;
        x := cdr x;
        go to a
   end;

symbolic procedure ordpa(u,v);
   % Returns TRUE if U ordered ahead or equal to V, NIL otherwise.
   % An expression with more structure at a given level is ordered
   % ahead of one with less.
   if null u then null v
    else if null v then t
    else if vectorp u then if vectorp v then ordpv(u,v) else atom v
    else if atom u
       then if atom v
		then if numberp u then numberp v and not(u<v)
		      else if idp v then orderp(u,v)
		      else numberp v
             else nil
    else if atom v then t
    else if car u=car v then ordpa(cdr u,cdr v)
    else ordpa(car u,car v);

endmodule;

end;