module sort; % A simple sorting routine.
% Author: Arthur C. Norman.
symbolic procedure sort(l,pred);
% Sort the list l according to the given predicate. If l is a list
% of numbers then the predicate "lessp" will sort the list into
% ascending order. The predicate should be a strict inequality,
% i.e. it should return NIL if the two items compared are equal. As
% implemented here SORT just calls STABLE-SORT, but as a matter of
% style any use where the ordering of incomparable items in the
% output matters ought to use STABLE!-SORT directly, thereby
% allowing the replacement of this code with a faster non-stable
% method. (Note: the previous REDUCE sort function also happened to
% be stable, so this code should give exactly the same results for
% all calls where the predicate is self-consistent and never has
% both pred(a,b) and pred(b,a) true).
stable!-sortip(append(l, nil), pred);
symbolic procedure stable!-sort(l,pred);
% Sorts a list, as SORT, but if two items x and y in the input list
% satisfy neither pred(x,y) nor pred(y,x) [i.e. they are equal so far
% as the given ordering predicate is concerned] this function
% guarantees that they will appear in the output list in the same
% order that they were in the input.
stable!-sortip(append(l, nil), pred);
symbolic procedure stable!-sortip(l, pred);
% As stable!-sort, but over-writes the input list to make the output.
% It is not intended that people should call this function directly:
% it is present just as the implementation of the main sort
% procedures defined above.
begin scalar l1,l2,w;
if null l then return l; % Input list of length 0
l1 := l;
l2 := cdr l;
if null l2 then return l; % Input list of length 1
% Now I have dealt with the essential special cases of lists of
% length 0 and 1 (which do not need sorting at all). Since it
% possibly speeds things up just a little I will now have some
% fairly ugly code that makes special cases of lists of length 2.
% I could easily have special code for length 3 lists here (and
% include it, but commented out), but at present my measurements
% suggest that the speed improvement that it gives is minimal and
% the increase in code bulk is large enough to give some pain.
l := cdr l2;
if null l then << % Input list of length 2
if apply2(pred, car l2, car l1) then <<
l := car l1;
rplaca(l1, car l2);
rplaca(l2, l) >>;
return l1 >>;
% Now I will check to see if the list is in fact in order already
% Doing so will have a cost - but sometimes that cost will be
% repaid when I am able to exit especially early. The result of
% all this is that I will have a best case behaviour with linear
% cost growth for inputs that are initially in the correct order,
% while my average and worst-case costs will increase by a
% constant factor.
l := l1;
% In the input list is NOT already in order then I expect that
% this loop will exit fairly early, and so will not contribute
% much to the total cost. If it exits very late then probably in
% the next recursion down the first half of the list will be
% found to be already sorted, and again I have a chance to win.
while l2 and not apply2(pred, car l2, car l) do
<<l := l2; l2 := cdr l2 >>;
if null l2 then return l1;
l2 := l1;
l := cddr l2;
while l and cdr l do << l2 := cdr l2; l := cddr l >>;
l := l2;
l2 := cdr l2;
rplacd(l, nil);
% The two sub-lists are then sorted.
l1 := stable!-sortip(l1, pred);
l2 := stable!-sortip(l2, pred);
% Now I merge the sorted fragments, giving priority to item from
% the earlier part of the original list.
l := w := list nil;
while l1 and l2 do <<
if apply2(pred, car l2, car l1) then <<
rplacd(w, l2); w := l2; l2 := cdr l2 >>
else <<rplacd(w, l1); w := l1; l1 := cdr l1>>>>;
if l1 then l2 := l1;
rplacd(w,l2);
return cdr l
end;
symbolic procedure idsort u;
% lexicographically sort list of ids.
sort(u,function idcompare);
symbolic procedure idcompare(u,v);
% compare lexicographical ordering of two ids.
idcomp1(explode2 u,explode2 v);
symbolic procedure idcomp1(u,v);
if null u then t
else if null v then nil
else if car u eq car v then idcomp1(cdr u,cdr v)
else orderp(car u,car v);
% Comparison functions and special cases for sorting.
symbolic procedure lesspcar(a,b); car a < car b;
symbolic procedure lesspcdr(a,b); cdr a < cdr b;
symbolic procedure lessppair(a,b);
if car a = car b then cdr a<cdr b else car a<car b;
symbolic procedure greaterpcdr(a,b); cdr a > cdr b;
symbolic procedure lesspcdadr(a,b); cdadr a < cdadr b;
symbolic procedure lesspdeg(a,b);
if domainp b then nil else if domainp a then t else ldeg a<ldeg b;
symbolic procedure ordopcar(a,b); ordop(car a,car b);
symbolic procedure orderfactors(a,b);
if cdr a = cdr b then ordp(car a,car b) else cdr a < cdr b;
symbolic procedure sort!-factors l;
% Sort factors as found into some sort of standard order. The order
% used here is more or less random, but will be self-consistent.
sort(l,function orderfactors);
endmodule;
end;