(FILECREATED " 4-Jun-86 23:22:16" {ERIS}<LISPCORE>LIBRARY>CMLSORT.;10 28370
changes to: (VARS CMLSORTCOMS)
(FNS CL:SORT %%SORT-SIMPLE-VECTOR %%SORT-VECTOR %%SORT-LIST STABLE-SORT
%%STABLE-SORT-SIMPLE-VECTOR %%STABLE-SORT-VECTOR CL:MERGE %%MERGE-LISTS*
%%MERGE-VECTORS* %%MERGE-SIMPLE-VECTORS %%MERGE-NON-SIMPLE-VECTORS
%%STABLE-%%SORT-SIMPLE-VECTOR %%STABLE-%%SORT-VECTOR MERGE-VECTORS*
MERGE-NON-SIMPLE-VECTORS MERGE-LISTS* MERGE-SIMPLE-VECTORS)
previous date: " 4-Jun-86 23:17:12" {ERIS}<LISPCORE>LIBRARY>CMLSORT.;8)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSORTCOMS)
(RPAQQ CMLSORTCOMS
((* * Section 14.5 Merging and Sorting -- By Kelly Roach. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE (MACROS APPLY-KEY APPLY-PRED SORT-PREFIX))
(FNS CL:SORT %%SORT-SIMPLE-VECTOR %%SORT-VECTOR %%SORT-LIST)
(FNS STABLE-SORT %%STABLE-SORT-SIMPLE-VECTOR %%STABLE-SORT-VECTOR)
(FNS CL:MERGE %%MERGE-LISTS* %%MERGE-VECTORS* %%MERGE-SIMPLE-VECTORS
%%MERGE-NON-SIMPLE-VECTORS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA %%MERGE-NON-SIMPLE-VECTORS %%MERGE-SIMPLE-VECTORS %%MERGE-VECTORS*
%%MERGE-LISTS* CL:MERGE %%STABLE-SORT-VECTOR %%STABLE-SORT-SIMPLE-VECTOR
STABLE-SORT %%SORT-LIST %%SORT-VECTOR %%SORT-SIMPLE-VECTOR CL:SORT)))))
(* * Section 14.5 Merging and Sorting -- By Kelly Roach. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE
(DECLARE: EVAL@COMPILE
(DEFMACRO APPLY-KEY (KEY CL:ELT) (* Apply-key applies the key to elt,
or if key is NIL %%, then returns elt.
*) (BQUOTE (CL:IF (\, KEY)
(FUNCALL (\, KEY)
(\, CL:ELT))
(\, CL:ELT))))
(DEFMACRO APPLY-PRED (ONE TWO PRED KEY)
(* apply-pred applies the predicate and the key functions to two arguments.
if the key function is NIL then apply-pred calls only the predicate function.
*)
(* Internal Macro *)
(BQUOTE (CL:IF (\, KEY)
(FUNCALL (\, PRED)
(FUNCALL (\, KEY)
(\, ONE))
(FUNCALL (\, KEY)
(\, TWO)))
(FUNCALL (\, PRED)
(\, ONE)
(\, TWO)))))
(DEFMACRO SORT-PREFIX NIL (* The slightly more complicated
version which follows eliminates the
function call overhead, and eliminates
the need to make LIST a special
variable *)
(QUOTE (PROG ((STACK NIL)
(RES NIL))
CALL
(CL:WHEN (NULL LIST)
(SETQ RES NIL)
(GO RETURN))
(CL:WHEN (< HEIGHT 1)
(SETQ RES (RPLACD (PROG1 LIST (SETQ LIST (CDR LIST)))
NIL))
(GO RETURN))
(CL:PUSH HEIGHT STACK)
(SETQ HEIGHT (1- HEIGHT))
(CL:PUSH (QUOTE S1)
STACK)
(GO CALL)
S1
(SETQ HEIGHT (1- (CAR STACK)))
(CL:PUSH RES STACK)
(CL:PUSH (QUOTE S2)
STACK)
(GO CALL)
S2
(SETQ RES (%%MERGE-LISTS* (POP STACK)
RES PRED KEY))
(SETQ HEIGHT (POP STACK))
(GO RETURN)
RETURN
(LET ((FLAG (POP STACK)))
(CASE FLAG (S1 (GO S1))
(S2 (GO S2))
(T (RETURN RES)))))))
)
)
(DEFINEQ
(CL:SORT
(CL:LAMBDA (SEQUENCE PREDICATE &KEY KEY) (* kbr: " 4-Jun-86 22:23")
(* Destructively sorts sequence.
Predicate should returns non-NIL if
Arg1 is to precede Arg2.
*)
(* Sort dispatches to type specific
sorting routines. *)
(CL:IF (ARRAYP SEQUENCE)
(CL:IF (> (CL:LENGTH SEQUENCE)
0)
(%%SORT-VECTOR SEQUENCE PREDICATE KEY)
SEQUENCE)
(CL:IF (VECTORP SEQUENCE)
(CL:IF (> (CL:LENGTH (THE SIMPLE-VECTOR SEQUENCE))
0)
(%%SORT-SIMPLE-VECTOR SEQUENCE PREDICATE KEY)
SEQUENCE)
(CL:IF (LISTP SEQUENCE)
(%%SORT-LIST SEQUENCE PREDICATE KEY)
(CL:ERROR "~S is not a sequence." SEQUENCE))))))
(%%SORT-SIMPLE-VECTOR
(CL:LAMBDA (VECTOR PRED KEY) (* kbr: " 4-Jun-86 17:21")
(* %%SORT-SIMPLE-VECTOR sorts vector using the Quicksort algorithm.
Subranges (from bottom through top inclusive) of vector are partitioned by
selecting the first element of the subrange as a pivot, and then rearranging
the elements of the subrange so that those less than the pivot come before it,
and the others come after. First, the whole vector is partitioned, then each of
the two partitions is partitioned. When a parition is trivial
(0 or 1 elt) we don't bother to do it. Pending partitions are remembered on a
stack. When the stack becomes empty, then the array has been sorted.
*)
(PROG (STACK PIVOT PIVKEY TOP BOTTOM TT BB)
(* STACK = stack of pending top/bottom pairs * PIVOT = initial pair for whole
vector. * PIVKEY = The pivot element for a partition pass.
The extracted key for pivot. * TOP BOTTOM = The range being partitioned
(inclusive) * TT BB = Working indices. *)
(SETQ STACK (LIST (1- (CL:LENGTH VECTOR))
0))
START-PARTITION
(SETQ TT (SETQ TOP (POP STACK)))
(SETQ BB (SETQ BOTTOM (POP STACK)))
(SETQ PIVKEY (APPLY-KEY KEY (SETQ PIVOT (AREF VECTOR BOTTOM))))
DOWN
(CL:WHEN (= BB TT)
(GO END-PARTITION))
(LET ((TOP-ELT (AREF VECTOR TT)))
(COND
((FUNCALL PRED (APPLY-KEY KEY TOP-ELT)
PIVKEY)
(SETF (AREF VECTOR BB)
TOP-ELT)
(SETQ BB (1+ BB))
(GO UP))
(T (SETQ TT (1- TT))
(GO DOWN))))
UP (CL:WHEN (= BB TT)
(GO END-PARTITION))
(LET ((BOT-ELT (AREF VECTOR BB)))
(COND
((FUNCALL PRED PIVKEY (APPLY-KEY KEY BOT-ELT))
(SETF (AREF VECTOR TT)
BOT-ELT)
(SETQ TT (1- TT))
(GO DOWN))
(T (SETQ BB (1+ BB))
(GO UP))))
END-PARTITION
(SETF (AREF VECTOR BB)
PIVOT)
(CL:WHEN (< BOTTOM (1- BB))
(CL:PUSH BOTTOM STACK)
(CL:PUSH (1- BB)
STACK))
(CL:WHEN (> TOP (1+ TT))
(CL:PUSH (1+ TT)
STACK)
(CL:PUSH TOP STACK))
(CL:WHEN (NULL STACK)
(RETURN VECTOR))
(GO START-PARTITION))))
(%%SORT-VECTOR
(CL:LAMBDA (VECTOR PRED KEY) (* kbr: " 4-Jun-86 17:24")
(* %%SORT-VECTOR is the same as
sort-simple-vector except that vector
is a "complex" array instead of a
"simple" array. *)
(PROG (STACK PIVOT PIVKEY TOP BOTTOM TT BB)
(* STACK = stack of pending top/bottom pairs * PIVOT = initial pair for whole
vector. * PIVKEY = The pivot element for a partition pass.
The extracted key for pivot. * TOP BOTTOM = The range being partitioned
(inclusive) * TT BB = Working indices. *)
(SETQ STACK (LIST (1- (CL:LENGTH VECTOR))
0))
START-PARTITION
(SETQ TT (SETQ TOP (POP STACK)))
(SETQ BB (SETQ BOTTOM (POP STACK)))
(SETQ PIVKEY (APPLY-KEY KEY (SETQ PIVOT (AREF VECTOR BOTTOM))))
DOWN
(CL:WHEN (= BB TT)
(GO END-PARTITION))
(LET ((TOP-ELT (AREF VECTOR TT)))
(COND
((FUNCALL PRED (APPLY-KEY KEY TOP-ELT)
PIVKEY)
(SETF (AREF VECTOR BB)
TOP-ELT)
(SETQ BB (1+ BB))
(GO UP))
(T (SETQ TT (1- TT))
(GO DOWN))))
UP (CL:WHEN (= BB TT)
(GO END-PARTITION))
(LET ((BOT-ELT (AREF VECTOR BB)))
(COND
((FUNCALL PRED PIVKEY (APPLY-KEY KEY BOT-ELT))
(SETF (AREF VECTOR TT)
BOT-ELT)
(SETQ TT (1- TT))
(GO DOWN))
(T (SETQ BB (1+ BB))
(GO UP))))
END-PARTITION
(SETF (AREF VECTOR BB)
PIVOT)
(CL:WHEN (< BOTTOM (1- BB))
(CL:PUSH BOTTOM STACK)
(CL:PUSH (1- BB)
STACK))
(CL:WHEN (> TOP (1+ TT))
(CL:PUSH (1+ TT)
STACK)
(CL:PUSH TOP STACK))
(CL:WHEN (NULL STACK)
(RETURN VECTOR))
(GO START-PARTITION))))
(%%SORT-LIST
(CL:LAMBDA (LIST PRED KEY)
(* Sort-List returns a list containing the elements of LIST in sort.
The original list is destroyed. Based on an algorithm described as:
(BQUOTE a) "traditional" list merge sort' by Guy Steele in AI memo 587
(aug (QUOTE 80)) %%. This sort is stable.
*)
(CL:DO ((HEIGHT 0 (1+ HEIGHT))
(RESULT NIL (%%MERGE-LISTS* RESULT (SORT-PREFIX)
PRED KEY)))
((NULL LIST)
RESULT))))
)
(DEFINEQ
(STABLE-SORT
(CL:LAMBDA (SEQUENCE PREDICATE &KEY KEY) (* kbr: " 4-Jun-86 22:34")
(* Stable sort is the same as sort, but it guarantees that equal elements will
not change places. For lists, use the normal sort-list function, but vectors
must use a less efficient algorithm. *)
(* Destructively sorts Sequence.
Predicate should return non-Nil if
Arg1 is to precede Arg2.
*)
(CL:IF (ARRAYP SEQUENCE)
(%%STABLE-SORT-SIMPLE-VECTOR SEQUENCE PREDICATE KEY)
(CL:IF (VECTORP SEQUENCE)
(%%STABLE-SORT-VECTOR SEQUENCE PREDICATE KEY)
(CL:IF (LISTP SEQUENCE)
(%%SORT-LIST SEQUENCE PREDICATE KEY)
(CL:ERROR "~S is not a sequence."))))))
(%%STABLE-SORT-SIMPLE-VECTOR
(CL:LAMBDA (VECTOR PRED KEY) (* kbr: " 4-Jun-86 17:26")
(* Stable sorting arrays is hard. Knuth seems to think that finding an
algorithm which can stably sort a vector in n log n time without using gobs of
extra storage is a 47 point problem. We handle the problem by coercing the
vector into a list, sorting that, and then copying the list back into the
original vector. *)
(* This is an internal function.
Use STABLE-SORT instead.
*)
(LET* ((HEADER (CONS (QUOTE HEADER)
NIL))
(CL:LENGTH (CL:LENGTH VECTOR))
(LIST (CL:DO ((I 0 (1+ I))
(TAIL HEADER (CDR (RPLACD TAIL (CONS (AREF VECTOR I)
NIL)))))
((= I CL:LENGTH)
(CDR HEADER)))))
(CL:DO ((SORTED-LIST (%%SORT-LIST LIST PRED KEY)
(CDR SORTED-LIST))
(I 0 (1+ I)))
((NULL SORTED-LIST)
VECTOR)
(SETF (AREF VECTOR I)
(CAR SORTED-LIST))))))
(%%STABLE-SORT-VECTOR
(CL:LAMBDA (VECTOR PRED KEY) (* kbr: " 4-Jun-86 17:27")
(* %%STABLE-SORT-VECTOR is the same as
%%STABLE-SORT-SIMPLE-VECTOR except
that the vector is a slisp array
instead of a slisp vector.
*)
(LET* ((HEADER (CONS (QUOTE HEADER)
NIL))
(CL:LENGTH (CL:LENGTH VECTOR))
(LIST (CL:DO ((I 0 (1+ I))
(TAIL HEADER (CDR (RPLACD TAIL (CONS (AREF VECTOR I)
NIL)))))
((= I CL:LENGTH)
(CDR HEADER)))))
(CL:DO ((SORTED-LIST (%%SORT-LIST LIST PRED KEY)
(CDR SORTED-LIST))
(I 0 (1+ I)))
((NULL SORTED-LIST)
VECTOR)
(SETF (AREF VECTOR I)
(CAR SORTED-LIST))))))
)
(DEFINEQ
(CL:MERGE
(CL:LAMBDA (RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY (KEY (FUNCTION IDENTITY)))
(* kbr: " 4-Jun-86 22:04")
(* The sequences SEQUENCE1 and
SEQUENCE2 are destructively merged
into a sequence of type RESULT-TYPE
using the PREDICATE to order the
elements. *)
(CASE (TYPE-SPECIFIER RESULT-TYPE)
(LIST (TYPECASE SEQUENCE1 (LIST (TYPECASE SEQUENCE2 (LIST (%%MERGE-LISTS* SEQUENCE1
SEQUENCE2 PREDICATE
KEY))
(ARRAY (%%MERGE-LISTS* SEQUENCE1 (
VECTOR-TO-LIST*
SEQUENCE2)
PREDICATE KEY))
(T (CL:ERROR "~S is not a sequence." SEQUENCE2)
)))
(ARRAY (TYPECASE SEQUENCE2 (LIST (%%MERGE-LISTS* (VECTOR-TO-LIST*
SEQUENCE1)
SEQUENCE2 PREDICATE KEY))
(ARRAY (%%MERGE-LISTS* (VECTOR-TO-LIST* SEQUENCE1)
(VECTOR-TO-LIST* SEQUENCE2)
PREDICATE KEY))
(T (CL:ERROR "~S is not a sequence." SEQUENCE2))))
(T (CL:ERROR "~S is not a sequence." SEQUENCE1))))
((VECTOR ARRAY STRING)
(TYPECASE SEQUENCE1 (LIST (TYPECASE SEQUENCE2 (LIST (%%MERGE-VECTORS*
(LIST-TO-VECTOR* SEQUENCE1
(QUOTE VECTOR))
(LIST-TO-VECTOR* SEQUENCE2
(QUOTE VECTOR))
PREDICATE KEY))
(ARRAY (%%MERGE-VECTORS* (LIST-TO-VECTOR*
SEQUENCE1
(QUOTE VECTOR))
SEQUENCE2 PREDICATE KEY))
(T (CL:ERROR "~S is not a sequence." SEQUENCE2))))
(ARRAY (TYPECASE SEQUENCE2 (LIST (%%MERGE-VECTORS* SEQUENCE1
(LIST-TO-VECTOR* SEQUENCE2
(QUOTE VECTOR))
PREDICATE KEY))
(ARRAY (%%MERGE-VECTORS* SEQUENCE1 SEQUENCE2 PREDICATE KEY))
(T (CL:ERROR "~S is not a sequence." SEQUENCE2))))
(T (CL:ERROR "~S is not a sequence." SEQUENCE1))))
(T (CL:ERROR "~S is not a subtype of SEQUENCE." RESULT-TYPE)))))
(%%MERGE-LISTS*
(CL:LAMBDA (LIST1 LIST2 PRED KEY) (* kbr: " 4-Jun-86 22:14")
(* %%MERGE-LISTS* destructively merges
LIST1 with LIST2 In the resulting
list, elements of LIST2 are guaranteed
to come after equal elements of LIST1
*)
(CL:DO* ((RESULT (LIST (QUOTE HEADER)))
(P RESULT))
((OR (NULL LIST1)
(NULL LIST2))
(CL:IF (NULL LIST1)
(RPLACD P LIST2)
(RPLACD P LIST1))
(CDR RESULT))
(* P = pointer to last cell of result. Done when either list used up in which
case, append the other list. Returns the result sans header.
*)
(COND
((APPLY-PRED (CAR LIST2)
(CAR LIST1)
PRED KEY)
(RPLACD P LIST2)
(* Append the lesser list to last cell of result.
Note: test must bo done for LIST2 < LIST1 so merge will be stable for LIST1 *)
(SETQ P (CDR P))
(pop LIST2))
(T (RPLACD P LIST1)
(SETQ P (CDR P))
(pop LIST1))))))
(%%MERGE-VECTORS*
(CL:LAMBDA (VECTOR1 VECTOR2 PRED KEY) (* kbr: " 4-Jun-86 22:33")
(* %%MERGE-VECTORS* dispatches to
either %%MERGE-SIMPLE-VECTORS or
%%MERGE-NON-SIMPLE-VECTORS *)
(CL:IF (OR (ARRAYP VECTOR1)
(ARRAYP VECTOR2))
(%%MERGE-NON-SIMPLE-VECTORS VECTOR1 VECTOR2 PRED KEY)
(%%MERGE-SIMPLE-VECTORS VECTOR1 VECTOR2 PRED KEY))))
(%%MERGE-SIMPLE-VECTORS
(CL:LAMBDA (VECTOR1 VECTOR2 PRED KEY) (* kbr: " 4-Jun-86 22:13")
(* Merge-simple-vectors returns a new vector which contains an interleaving of
the elements of VECTOR1 and VECTOR2 Elements from VECTOR2 are chosen only if
they are strictly less than elements of VECTOR1
(PRED ELT2 ELT1) %%, as specified in the manual.
*)
(CL:DECLARE (SIMPLE-VECTOR VECTOR1 VECTOR2))
(CL:DO* ((LENGTH1 (CL:LENGTH VECTOR1))
(LENGTH2 (CL:LENGTH VECTOR2))
(RESULTLENGTH (+ LENGTH1 LENGTH2))
(RESULT (MAKE-ARRAY RESULTLENGTH :ELEMENT-TYPE (ARRAY-ELEMENT-TYPE VECTOR1)))
(FILL 0 (1+ FILL))
(I 0)
(J 0))
((>= FILL RESULTLENGTH)
RESULT) (* FILL = index into result vector * I
= index into VECTOR1 * J = index into
VECTOR2 *)
(COND
((= I LENGTH1)
(CL:DO NIL ((= FILL RESULTLENGTH)
RESULT)
(SETF (AREF RESULT FILL)
(AREF VECTOR2 J))
(SETQ FILL (1+ FILL))
(SETQ J (1+ J))))
((= J LENGTH2)
(CL:DO NIL ((= FILL RESULTLENGTH)
RESULT)
(SETF (AREF RESULT FILL)
(AREF VECTOR1 I))
(SETQ FILL (1+ FILL))
(SETQ I (1+ I))))
((APPLY-PRED (AREF VECTOR2 J)
(AREF VECTOR1 I)
PRED KEY)
(SETF (AREF RESULT FILL)
(AREF VECTOR2 J))
(SETQ J (1+ J)))
(T (SETF (AREF RESULT FILL)
(AREF VECTOR1 I))
(SETQ I (1+ I)))))))
(%%MERGE-NON-SIMPLE-VECTORS
(CL:LAMBDA (VECTOR1 VECTOR2 PRED KEY) (* kbr: " 4-Jun-86 22:27")
(* %%MERGE-NON-SIMPLE-VECTORS is like
%%MERGE-SIMPLE-VECTORS except that the
vectors are either slisp arrays or
slisp vectors. *)
(CL:DO* ((LENGTH1 (CL:LENGTH VECTOR1))
(LENGTH2 (CL:LENGTH VECTOR2))
(RESULTLENGTH (+ (CL:LENGTH VECTOR1)
(CL:LENGTH VECTOR2)))
(RESULT (MAKE-ARRAY RESULTLENGTH :ELEMENT-TYPE (ARRAY-ELEMENT-TYPE VECTOR1)))
(FILL 0 (1+ FILL))
(I 0)
(J 0))
((>= FILL RESULTLENGTH)
RESULT)
(CL:DECLARE (VECTOR RESULT)) (* FILL = index into result vector * I
= index into VECTOR1 * J = index into
VECTOR2 *)
(COND
((= I LENGTH1)
(CL:DO NIL ((= FILL RESULTLENGTH)
RESULT)
(SETF (AREF RESULT FILL)
(AREF VECTOR2 J))
(SETQ FILL (1+ FILL))
(SETQ J (1+ J))))
((= J LENGTH2)
(CL:DO NIL ((= FILL RESULTLENGTH)
RESULT)
(SETF (AREF RESULT FILL)
(AREF VECTOR1 I))
(SETQ FILL (1+ FILL))
(SETQ I (1+ I))))
((APPLY-PRED (AREF VECTOR2 J)
(AREF VECTOR1 I)
PRED KEY)
(SETF (AREF RESULT FILL)
(AREF VECTOR2 J))
(SETQ J (1+ J)))
(T (SETF (AREF RESULT FILL)
(AREF VECTOR1 I))
(SETQ I (1+ I)))))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA %%MERGE-NON-SIMPLE-VECTORS %%MERGE-SIMPLE-VECTORS %%MERGE-VECTORS* %%MERGE-LISTS*
CL:MERGE %%STABLE-SORT-VECTOR %%STABLE-SORT-SIMPLE-VECTOR STABLE-SORT
%%SORT-LIST %%SORT-VECTOR %%SORT-SIMPLE-VECTOR CL:SORT)
)
(PUTPROPS CMLSORT COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5363 13049 (CL:SORT 5373 . 6705) (%%SORT-SIMPLE-VECTOR 6707 . 9755) (%%SORT-VECTOR 9757
. 12450) (%%SORT-LIST 12452 . 13047)) (13050 17060 (STABLE-SORT 13060 . 14190) (
%%STABLE-SORT-SIMPLE-VECTOR 14192 . 15725) (%%STABLE-SORT-VECTOR 15727 . 17058)) (17061 27910 (
CL:MERGE 17071 . 21070) (%%MERGE-LISTS* 21072 . 22708) (%%MERGE-VECTORS* 22710 . 23343) (
%%MERGE-SIMPLE-VECTORS 23345 . 25582) (%%MERGE-NON-SIMPLE-VECTORS 25584 . 27908)))))
STOP