(FILECREATED " 2-Jul-86 17:17:04" {ERIS}<LISPCORE>LIBRARY>CMLSORT.;12 13689
changes to: (VARS CMLSORTCOMS)
(FUNCTIONS CL:SORT STABLE-SORT CL:MERGE APPLY-PRED %%SORT-VECTOR SORT-PREFIX
APPLY-KEY %%SORT-LIST %%STABLE-SORT-VECTOR %%MERGE-LISTS* %%MERGE-VECTORS*
%%MERGE-NON-SIMPLE-VECTORS)
(FNS STABLE-SORT %%STABLE-SORT-VECTOR %%MERGE-LISTS*)
(PROPS (CMLSORT FILETYPE))
previous date: " 1-Jul-86 18:09:23" {ERIS}<LISPCORE>LIBRARY>CMLSORT.;11)
(* 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 (FILES CMLSEQCOMMON)
(FUNCTIONS APPLY-KEY APPLY-PRED SORT-PREFIX))
(FUNCTIONS CL:SORT %%SORT-VECTOR %%SORT-LIST)
(FUNCTIONS STABLE-SORT %%STABLE-SORT-VECTOR)
(FUNCTIONS CL:MERGE %%MERGE-LISTS* %%MERGE-VECTORS* %%MERGE-NON-SIMPLE-VECTORS)
(PROP FILETYPE CMLSORT)))
(* * "Section 14.5 Merging and Sorting -- By Kelly Roach.")
(DECLARE: DONTCOPY DOEVAL@COMPILE
(FILESLOAD CMLSEQCOMMON)
(DEFMACRO APPLY-KEY (KEY ELT) "Apply-key applies the key to elt, or if key is NIL, then returns elt."
(BQUOTE (CL:IF (\, KEY)
(FUNCALL (\, KEY)
(\, ELT))
(\, 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 (CL:POP LIST))
NIL))
(GO RETURN))
(CL:PUSH HEIGHT STACK)
(DECF 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* (CL:POP STACK)
RES PRED KEY))
(SETQ HEIGHT (CL:POP STACK))
(GO RETURN)
RETURN
(CASE (CL:POP STACK)
(S1 (GO S1))
(S2 (GO S2))
(T (RETURN RES))))))
)
(DEFUN CL:SORT (SEQUENCE PREDICATE &KEY KEY)
"Destructively sorts sequence. Predicate should returns non-NIL if Arg1 is to precede Arg2."
(* kbr: " 4-Jun-86 22:23")
(* * "Sort dispatches to type specific sorting routines.")
(SEQ-DISPATCH SEQUENCE (%%SORT-LIST SEQUENCE PREDICATE KEY)
(%%SORT-VECTOR SEQUENCE PREDICATE KEY)))
(DEFUN %%SORT-VECTOR (VECTOR PRED KEY) (* kbr: " 4-Jun-86 17:24")
(* * "%%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 (CL:POP STACK)))
(SETQ BB (SETQ BOTTOM (CL: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)
(INCF BB)
(GO UP))
(T (DECF 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)
(DECF TT)
(GO DOWN))
(T (INCF 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)))
(DEFUN %%SORT-LIST (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: `a traditional list merge sort' by Guy Steele in AI memo 587 (aug '80). This sort is stable.")
(CL:DO ((HEIGHT 0 (1+ HEIGHT))
(RESULT NIL (%%MERGE-LISTS* RESULT (SORT-PREFIX)
PRED KEY)))
((NULL LIST)
RESULT)))
(DEFUN STABLE-SORT (SEQUENCE PREDICATE &KEY KEY) "Destructively sorts Sequence. Predicate should return non-Nil if Arg1 is to precede Arg2. 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."
(* kbr: " 4-Jun-86 22:34")
(SEQ-DISPATCH SEQUENCE (%%SORT-LIST SEQUENCE PREDICATE KEY)
(%%STABLE-SORT-VECTOR SEQUENCE PREDICATE KEY)))
(DEFUN %%STABLE-SORT-VECTOR (VECTOR PRED KEY)
"This is an internal function. Use STABLE-SORT instead."
(* 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.")
(SETF (SUBSEQ VECTOR 0)
(%%SORT-LIST (CL:COERCE VECTOR (QUOTE LIST))
PRED KEY))
(RETURN-FROM %%STABLE-SORT-VECTOR VECTOR))
(DEFUN CL:MERGE (RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY (KEY (FUNCTION IDENTITY))) "The sequences SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type RESULT-TYPE using the PREDICATE to order the elements."
(* kbr: " 4-Jun-86 22:04")
(CASE (TYPE-SPECIFIER RESULT-TYPE)
(LIST (%%MERGE-LISTS (SEQ-DISPATCH SEQUENCE1 SEQUENCE1 (VECTOR-TO-LIST* SEQUENCE1))
(SEQ-DISPATCH SEQUENCE2 SEQUENCE2 (VECTOR-TO-LIST* SEQUENCE2))
PREDICATE KEY))
((VECTOR ARRAY STRING)
(%%MERGE-VECTORS* (SEQ-DISPATCH SEQUENCE1 (LIST-TO-VECTOR* SEQUENCE1 (QUOTE VECTOR))
SEQUENCE1)
(SEQ-DISPATCH SEQUENCE2 (LIST-TO-VECTOR* SEQUENCE2 (QUOTE VECTOR))
SEQUENCE2)
PREDICATE KEY))))
(DEFUN %%MERGE-LISTS* (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 *")
(CL:POP P)
(CL:POP LIST2))
(T (RPLACD P LIST1)
(CL:POP P)
(CL:POP LIST1)))))
(DEFUN %%MERGE-VECTORS* (VECTOR1 VECTOR2 PRED KEY) (* kbr: " 4-Jun-86 22:33")
(* *
"Once you can take advantage of type information, consider splitting out the simple-vector case.")
(
%%MERGE-NON-SIMPLE-VECTORS
VECTOR1
VECTOR2 PRED
KEY))
(DEFUN %%MERGE-NON-SIMPLE-VECTORS (VECTOR1 VECTOR2 PRED KEY) "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."
(* kbr: " 4-Jun-86 22:27")
(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)
(DECLARE (TYPE 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))
(INCF FILL)
(INCF J)))
((= J LENGTH2)
(CL:DO NIL ((= FILL RESULTLENGTH)
RESULT)
(SETF (AREF RESULT FILL)
(AREF VECTOR1 I))
(INCF FILL)
(INCF I)))
((APPLY-PRED (AREF VECTOR2 J)
(AREF VECTOR1 I)
PRED KEY)
(SETF (AREF RESULT FILL)
(AREF VECTOR2 J))
(INCF J))
(T (SETF (AREF RESULT FILL)
(AREF VECTOR1 I))
(INCF I)))))
(PUTPROPS CMLSORT FILETYPE COMPILE-FILE)
(PUTPROPS CMLSORT COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP