Artifact 4d18fbc016fb3b4f57eae623b16c9af083cf4e6dc9b2d5f277ea40745e0f6e9d:

• File psl-1983/3-1/util/gsort.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 8057) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/gsort.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 8057) [annotate] [blame] [check-ins using]

%===================================================================
% Simple sorting functions for PSL strings and Ids
% use with FindPrefix and FindSuffix

% MLG,  8:16pm  Monday, 14 December 1981
%===================================================================

% Revision History
%
% Edit by Cris Perdue, 26 Jan 1983 1343-PST
% Fixed the order of arguments in one call to make GMergeSort stable.
% MLG, 2 Jan 1983
%	Changed IDSORT form Macro to procedure, so that
%	it could be redefined for experiments with alternate GSORT
%	Affected RCREF and FIND


lisp procedure StringCompare(S1,S2);    
%  Returns 1,0,-1 for S1<S2,S1=S2,S1>S2
% String Comparison
 Begin scalar L1,L2,I,L;
        L1:=Size(S1); L2:=Size(S2);
        L:=MIN2(L1,L2);
        I:=0;
  loop: If I>L then return(If L1 <L2 then 1
                           else if L1 > L2 then -1
                           else 0);
	if S1[I] < S2[I] then return 1;
      	if S1[I] > S2[I] then return (-1);
	I:=I+1;
	goto loop;
 End;

lisp procedure IdCompare(D1,D2);	
%  Compare IDs via print names
					%/ What of case
  StringCompare(Id2String D1,Id2String D2);

lisp procedure SlowIdSort DList;            
%  Worst Possible Sort;
  If Null DList then NIL
   else InsertId(car Dlist, SlowIdSort Cdr Dlist);

lisp procedure InsertId(D,DL);
 If Null DL then D . Nil
  else if IdCompare(D,Car DL)>=0 then D . DL
  else Car Dl . InsertId(D,Cdr Dl);

% ======= Tree based ALPHA-SORT package, derived from CREF

%  routines modified from FUNSTR for alphabetic sorting
%
%  Tree Sort of list of  ELEM
%
% Tree is  NIL or STRUCT(VAL:value,SONS:Node-pair)
%		Node-pair=STRUCT(LNode:tree,RNode:tree);

lisp smacro procedure NewNode(Elem); %/ use A vector?
	LIST(Elem,NIL);

lisp smacro procedure VAL Node; 	
%  Access the VAL in node
	CAR Node;

lisp smacro procedure LNode Node;
	CADR Node;

lisp smacro procedure RNode Node;
	CDDR Node;

lisp smacro procedure NewLeftNode(Node,Elem);
	RPLACA(CDR Node,NewNode Elem);

lisp smacro procedure NewRightNode(Node,Elem);
	RPLACD(CDR Node,NewNode Elem);

lisp procedure IdSort LST;  
%  Sort a LIST of ID's. Do not remove Dups
% Build Tree then collapse;
 Tree2LST(IdTreeSort(LST),NIL);

lisp procedure IdTreeSort LST;
% Uses insert of Element to Tree;
   Begin scalar Tree;
	If NULL LST then Return NIL;
	Tree:=NewNode CAR LST; % First Element
	While PAIRP(LST:=CDR LST) DO IdPutTree(CAR LST,Tree);
	Return Tree;
   END;

lisp smacro procedure IdPlaceToLeft (Elem1,Elem2);
% ReturnS T If Elem to go to left of Node
	IdCompare(Elem1,Elem2)>=0;

lisp procedure IdPutTree(Elem,Node);	
%  Insert Elements into Tree
  Begin
  DWN:	If Not IdPlaceToLeft(Elem,VAL Node)  then GOTO RGT;
	If LNode Node then <<Node:=LNode Node;GO TO DWN>>;
		NewLeftNode(Node,Elem);
		Return;
  RGT:	If RNode Node then <<Node:=RNode Node;GO TO DWN>>;
		NewRightNode(Node,Elem);
		Return;
  END;

lisp procedure Tree2LST(Tree,LST);	
%  Collapse Tree to LIST
  Begin
	While Tree DO 
	   <<LST:=VAL(Tree) .Tree2LST(RNode Tree,LST);
	    Tree:=LNode Tree>>;
 	Return LST;
   END;

% More General Sorting, given Fn=PlaceToRight(a,b);

lisp procedure GenSort(LST,Fn);  
%  Sort a LIST of  elems
% Build Tree then collapse;
 Tree2LST(GenTreeSort(LST,Fn),NIL);

lisp procedure GenTreeSort(LST,Fn);
% Uses insert of Element to Tree;
   Begin scalar Tree;
	If NULL LST then Return NIL;
	Tree:=NewNode CAR LST; % First Element
	While PAIRP(LST:=CDR LST) DO GenPutTree(CAR LST,Tree,Fn);
	Return Tree;
   END;

lisp procedure GenPutTree(Elem,Node,SortFn);	
%  Insert Elements into Tree
  Begin
  DWN:	If Not Apply(SortFn,list(Elem,VAL Node))  then GOTO RGT;
	If LNode Node then <<Node:=LNode Node;GO TO DWN>>;
		NewLeftNode(Node,Elem);
		Return;
  RGT:	If RNode Node then <<Node:=RNode Node;GO TO DWN>>;
		NewRightNode(Node,Elem);
		Return;
  END;


% More General Sorting, given SortFn=PlaceToLeft(a,b);

lisp procedure GSort(LST,SortFn);  
%  Sort a LIST of  elems
% Build Tree then collapse;
Begin 
 CopyD('GsortFn!*,SortFn);
 LST:= Tree2LST(GTreeSort LST,NIL);
 RemD('GsortFn!*);
 Return LST;
 End;


lisp procedure GTreeSort LST;
% Uses insert of Element to Tree;
   Begin scalar Tree;
	If NULL LST then Return NIL;
	Tree:=NewNode CAR LST; % First Element
	While PAIRP(LST:=CDR LST) DO GPutTree(CAR LST,Tree);
	Return Tree;
   END;

lisp procedure GPutTree(Elem,Node);	
%  Insert Elements into Tree
  Begin
  DWN:	If Not GSortFn!*(Elem,VAL Node)  then GOTO RGT;
	If LNode Node then <<Node:=LNode Node;GO TO DWN>>;
		NewLeftNode(Node,Elem);
		Return;
  RGT:	If RNode Node then <<Node:=RNode Node;GO TO DWN>>;
		NewRightNode(Node,Elem);
		Return;
  END;

% Standard Comparison Functions:

lisp procedure IdSortFn(Elem1,Elem2);
% ReturnS T If Elem1 to go to right of Elem 2;
	IdCompare(Elem1,Elem2)>=0;

lisp procedure NumberSortFn(Elem1,Elem2);
       Elem1 <= Elem2;

lisp procedure NumberSort Lst;
   Gsort(Lst,'NumberSortFn);

lisp procedure StringSortFn(Elem1,Elem2);
       StringCompare(Elem1,Elem2)>=0;

lisp procedure StringSort Lst;
   Gsort(Lst,'StringSortFn);

lisp procedure NoSortFn(Elem1,Elem2);
       NIL;

lisp procedure AtomSortFn(E1,E2);
 % Ids, Numbers, then strings;
 If IdP E1 then
     If IdP E2 then IdSortFn(E1,E2)
      else NIL
  else if Numberp E1
      then if IdP E2 then T
            else if NumberP E2 then NumberSortFn (E1,E2)
            else NIL
  else if StringP(E1)
        then if IDP(E2) then T
        else if Numberp E2 then T
        else StringSortFn(E1,E2)
  else NIL;

lisp procedure AtomSort Lst;
  Gsort(Lst,'AtomSortFn);

lisp procedure StringLengthFn(S1,S2);    
%  For string length
% String Length Comparison
    Size(S1)<=Size(S2);

procedure IdLengthFn(e1,e2);
  StringLengthFn(Id2string e1,Id2string e2);

On syslisp;

syslsp procedure SC1(S1,S2);    
%  Returns T if S1<=S2
% String Comparison
 Begin scalar L1,L2,I,L;
        S1:=Strinf s1; S2:=Strinf S2;
        L1:=StrLen(S1); L2:=StrLen(S2);
        If L1>L2 then L:=L2 else L:=L1;
        I:=0;
  loop: If I>L then return(If L1 <=L2 then T else NIL);
	if StrByt(S1,I) < StrByt(S2,I) then return T;
	if StrByt(S1,I) > StrByt(S2,I) then return NIL;
	I:=I+1;
	goto loop;
 End;

syslsp procedure IdC1(e1,e2);
  Sc1(ID2String e1, ID2String e2);

syslsp procedure SC2(S1,S2);    
% Returns T if S1<=S2
% String Comparison done via packed word compare, may glitch
 Begin scalar L1,L2,I,L;
        S1:=Strinf s1; S2:=Strinf S2;
        L1:=Strpack StrLen(S1); L2:=strpack StrLen(S2);
        S1:=S1+1; S2:=S2+1;
        If L1>L2 then L:=L2 else L:=L1;
        I:=0;              %/ May be off by one?
  loop: If I>L then return(If L1 <=L2 then T else NIL);
	if S1[I] < S2[I] then return T;
	if S1[I] > S2[I] then return NIL;
	I:=I+1;
	goto loop;
 End;

syslsp procedure IdC2(e1,e2);
  Sc2(ID2String e1,ID2String e2);

Off syslisp;

Lisp procedure GsortP(Lst,SortFn);
Begin 
    If Not PairP Lst then return T;
 L: If Not PairP Cdr Lst then Return T;
    If Not Apply(SortFn,list(Car Lst, Cadr Lst)) then return NIL;
    Lst :=Cdr Lst;
    goto L;
END;

Lisp procedure GMergeLists(L1,L2,SortFn);
 If  Not PairP L1 then L2 
  else if  Not PairP L2 then L1
  else if Apply(SortFn,list(Car L1, Car L2))
    then Car(L1) . GMergeLists(cdr L1, L2,SortFn)
  else car(L2) . GmergeLists(L1, cdr L2,SortFn);

Lisp procedure MidPoint(Lst1,Lst2,M);      % Set MidPointer List at M
  Begin 
        While Not (Lst1 eq Lst2) and M>0 do
          <<Lst1 := cdr Lst1;
            M:=M-1>>;
       return  Lst1;
  End;

Lisp procedure GMergeSort(Lst,SortFn);
 GMergeSort1(Lst,NIL,Length Lst,SortFn);

Lisp procedure GMergeSort1(Lst1,Lst2,M,SortFn);
 If M<=0 then NIL
  else if M =1 then if null cdr Lst1 then Lst1 else List Car lst1
  else if M=2 then
      (if Apply(SortFn,list(Car Lst1,Cadr Lst1)) then List(Car Lst1, Cadr Lst1)
        else List(Cadr Lst1,Car lst1))
  else begin scalar Mid,M1;
       M1:=M/2;
       Mid :=MidPoint(Lst1,Lst2,M1);
       Lst1 :=GMergeSort1(Lst1,Mid, M1,SortFn);
       Lst2 :=GmergeSort1(Mid,Lst2, M-M1,SortFn);
       Return GmergeLists(Lst1,Lst2,SortFn);
  end;

end;