LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031539. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "SORT" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758657486. :AUTHOR "REL3" :LENGTH-IN-BYTES 25080. :LENGTH-IN-BLOCKS 25. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ;SORT PACKAGE   -*- Mode:Common-Lisp; Package:SI; Base:8; Cold-Load:T -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **;ENTRIES;  SORT <list or array> <lessp predicate>;  SORTCAR  ..  ..;  SORT-SHORT-LIST <list> <lessp predicate>;     A simple exchange sort, good for short lists.  Need not be contiguous.;  SORTCAR-SHORT-LIST .. ..;  STABLE-SORT -- slower version of SORT which is guaranteed to be stable;     Note that SORT itself is stable on non-cdr-coded lists.;  SORT-GROUPED-ARRAY <array-only> <group-size> <lessp predicate>;     Assumes logical records come in groups of <group-size> entries.;             the key is the first entry of the group.;     Uses ARRAY-ACTIVE-LENGTH to determine portion of array to be sorted.;  SORT-GROUPED-ARRAY-GROUP-KEY <array-only> <group-size> <lessp predicate>;     Similar to SORT-GROUPED-ARRAY, but <lessp predicate> should be a function;     of four arguments, <array1> <idx1> <array2> <idx2>.  Thus, it can;     reference the entire group, if desired, not just the first element.;INTERNAL FUNCTIONS;  SORT-ARRAY-QUICK <array> <left index> <right index>;       Uses insertion sort if small, otherwise Quicksort;Indices are inclusive.;  SORT-GROUPED-ARRAY-QUICK <array> <left index> <right index> <group-size>;       Analogous to above for use by SORT-GROUPED-ARRAY.;  SORT-GROUPED-ARRAY-GROUP-KEY-QUICK <array> <left index> <right index> <group-size>;       Analogous for SORT-GROUPED-ARRAY-GROUP-KEY.;  SORT-CONTIG-LIST-QUICK <list> <length> ;  SORT-LIST <list>;Hacks contiguous lists, does combined merge and quick sort;  SORT-LIST-PREFIX <height>;  SORT-LIST-MERGE <list1> <list2>;  SORT-LIST-MERGE-CONTIG <list1> <length1> <list2> <length2>;SUBROUTINE (SHOULD BE PUT INTO THE NUCLEUS IN SOME FORM);  CONTIGUOUS-LIST-INFO <list>;     Returns 2 values:;Number of contiguous CDR-NEXTs in <list> (1- the number of contiguous CAR cells);"last" of the contiguous part.  CAR of this is last CAR cell, CDR is link;the non-contiguous part of the list.;     If you call this with an argument of NIL, it will either loop or err out.(DEFVAR SORT-LESSP-PREDICATE)(DEFVAR SORT-KEY-FUNCTION)(DEFVAR SORT-INPUT-LIST)(DEFVAR SORT-DUMMY-ARRAY-HEADER)(DEFVAR SORT-QS-BREAKEVEN 10)(DEFVAR SORT-ARRAY-TEMP-V)(eval-when (compile)  (DEFMACRO APPLY-PREDICATE-AND-KEY (LPRED KEYFUN ARG1 ARG2)    `(COND ((NULL ,KEYFUN) (FUNCALL ,LPRED ,ARG1 ,ARG2))   ((EQ ,KEYFUN #'CAR) (FUNCALL ,LPRED (CAR ,ARG1) (CAR ,ARG2)))   (T (FUNCALL ,LPRED (FUNCALL ,KEYFUN ,ARG1)       (FUNCALL ,KEYFUN ,ARG2)))))  );Special Considerations;; GC must never de-linearize lists.;  The hairy version of NRECONC (NREVERSE) depends on this too.; Note that a list can get de-linearized by the GC finding a pointer;  to the middle and copying from there.  One way around this is to;  set up an arrangement to be interrupted, signalled, thrown-through,;  or whatever when a flip happens, then at the time the size of a;  contiguous segment of list is counted, ensure that everything is;  in newspace (already copied).  Great care is required.(DEFUN STABLE-SORT (X LESSP-PREDICATE &KEY &OPTIONAL KEY    &AUX TEM (SORT-KEY-FUNCTION KEY))  "Sort the list or array X by comparing the elements, not rearranging \"equal\" elements.SORT-LESSP-PREDICATE is applied to a pair of elementsand should return non-NIL if the first element is \"less\" than the second.Two elements are \"equal\" if the predicate returns NILwhen given those two elements in either order.If KEY is non-NIL, it is a function to apply to each elementto get the thing to pass to the predicate; using CAR for KEYgets the effect of STABLE-SORTCAR.The list or array is modified destructively."  (COND ((NULL X) NIL)((CONSP X) (COND ((< (LENGTH X) 20.) (SORT-SHORT-LIST X LESSP-PREDICATE KEY))       (T (SORT-LIST-STABLE X LESSP-PREDICATE KEY))))((ARRAYP X) (SORT-ARRAY-STABLE X LESSP-PREDICATE KEY) X)((AND (SYMBOLP X)      (ARRAYP (SETQ TEM (SYMBOL-FUNCTION X)))) (SORT-ARRAY-STABLE TEM LESSP-PREDICATE KEY) X)((ERROR T "ARG MUST BE A LIST OR AN ARRAY - STABLE-SORT" X))))(DEFUN STABLE-SORTCAR (X PREDICATE)  "Sort the list or array X by comparing the cars of the elements, not rearranging \"equal\" elements.PREDICATE is applied to two elements' cars.Two elements are \"equal\" if the predicate returns NILwhen given those two elements in either order.The list or array is modified destructively."  (STABLE-SORT X PREDICATE :KEY #'CAR))(DEFUN SORT-LIST-STABLE (L LESSP-PREDICATE KEY)  (LET ((TEMP (MAKE-ARRAY (* 2 (LENGTH L)) :TYPE ART-Q-LIST))SORTED)    ;; Make the contents of TEMP be a totally non-cdr-coded list    ;; whose elements are those of A.    (DO ((TAIL L (CDR TAIL)) (I 0 (+ I 2)))((NULL TAIL))      (SETF (AREF TEMP I) (CAR TAIL))      (%P-STORE-CDR-CODE (ALOC TEMP I) CDR-NORMAL)      (IF (NULL (CDR TAIL))  (RETURN))      (SETF (AREF TEMP (1+ I)) (%MAKE-POINTER DTP-LIST (ALOC TEMP (+ 2 I)))))    ;; SORT is stable on totally non-cdr-coded lists.    (SETQ SORTED (SORT (G-L-P TEMP) LESSP-PREDICATE :KEY KEY))    ;; Copy the data back into L.    (DO ((TAIL L (CDR TAIL)) (STAIL SORTED (CDR STAIL)))((NULL TAIL))      (SETF (CAR TAIL) (CAR STAIL)))    (RETURN-STORAGE TEMP)    L));Barbarian cunning, not so slow, and works.(DEFUN SORT-ARRAY-STABLE (A LESSP-PREDICATE KEY)  (UNLESS (<= (LENGTH A) 1)    (LET ((TEMP (MAKE-ARRAY (* 2 (LENGTH A)) :TYPE ART-Q-LIST)))      ;; Make the contents of TEMP be a totally non-cdr-coded list      ;; whose elements are those of A.      (DO ((J 0 (1+ J))   (I 0 (+ I 2))   (LEN (LENGTH A)))  ((= J LEN))(SETF (AREF TEMP I) (AREF A J))(%P-STORE-CDR-CODE (ALOC TEMP I) CDR-NORMAL)(IF (= J (1- LEN))    (RETURN))(SETF (AREF TEMP (1+ I)) (%MAKE-POINTER DTP-LIST (ALOC TEMP (+ 2 I)))))      ;; SORT is stable on totally non-cdr-coded lists.      (ZLC:FILLARRAY A (SORT (G-L-P TEMP) LESSP-PREDICATE :KEY KEY))      (RETURN-STORAGE TEMP))))(DEFUN SORTCAR (X PREDICATE)  "Sort the list or array X, whose elements should be lists, by comparing their cars.PREDICATE is applied to two elements' cars.The list or array is modified destructively."  (SORT X PREDICATE :KEY #'CAR))(DEFUN SORT (X SORT-LESSP-PREDICATE &KEY &OPTIONAL KEY     &AUX TEM (SORT-KEY-FUNCTION KEY))  "Sort the list or array X by comparing the elements.SORT-LESSP-PREDICATE is applied to a pair of elementsand should return non-NIL if the first element is \"less\" than the second.If KEY is non-NIL, it is a function to apply to each elementto get the thing to pass to the predicate; using CAR for KEYgets the effect of SORTCAR.The list or array is modified destructively."  (COND ((CONSP X) (COND ((< (LENGTH X) 12.) (SORT-SHORT-LIST X SORT-LESSP-PREDICATE KEY))       (T (SORT-LIST X))))((NULL X);NIL IS A LIST, SORT OF X)((ARRAYP X) (SORT-ARRAY-QUICK X 0 (1- (ARRAY-ACTIVE-LENGTH X))) X)((AND (SYMBOLP X)      (ARRAYP (SETQ TEM (SYMBOL-FUNCTION X)))) (SORT-ARRAY-QUICK TEM 0 (1- (ARRAY-TOTAL-SIZE TEM))) X)((ERROR T "ARG MUST BE A LIST OR AN ARRAY - SORT" X))));; Just a bubble sort.(DEFUN SORT-SHORT-LIST (L LPRED KEYFUN)  (COND ((CDR L) (DO ((I (1- (LENGTH L)) (1- I))      (SWITCH NIL))     ((OR (ZEROP I) SWITCH))   (SETQ SWITCH T)   (DO ((LP L (CDR LP)))       ((NULL (CDR LP)))     (WHEN (APPLY-PREDICATE-AND-KEY LPRED KEYFUN (CADR LP) (CAR LP))       (RPLACA LP (PROG1 (CADR LP) (RPLACA (CDR LP) (CAR LP))))       (SETQ SWITCH NIL))))))  L)(DEFUN SORTCAR-SHORT-LIST (L LPRED) (PROG (LP SWITCH)       (COND ((NULL (CDR L))      (RETURN L)))   L0  (SETQ LP L)   L1  (COND ((FUNCALL LPRED (CAADR LP) (CAAR LP))      (RPLACA LP (PROG1 (CADR LP) (RPLACA (CDR LP) (CAR LP))))      (SETQ SWITCH T)))   (SETQ LP (CDR LP))(COND ((CDR LP) (GO L1))      (SWITCH (SETQ SWITCH NIL)      (GO L0)))(RETURN L)))(DEFUN CONTIGUOUS-LIST-INFO (LIST)  "The first value is the number of CDR-NEXT cells in LIST.The second is the non-cdr-next tail of LIST, whose cdris either NIL or not contiguous with that cell.It is not very meaningful to supply NIL as the argument."  (DECLARE (VALUES NUMBER-OF-CDR-NEXT NON-CDR-NEXT-CELL))  (PROG ((N 0))     (IF (NULL LIST) (RETURN 0 NIL))LOOP (OR (AND (= (%P-CDR-CODE LIST) CDR-NEXT)      (NEQ (%P-DATA-TYPE LIST) DTP-HEADER-FORWARD)) (RETURN N LIST))     (SETQ N (1+ N) LIST (CDR LIST))     (GO LOOP)));;; Note, LENGTH is 1- real length(DEFUN SORT-CONTIG-LIST-QUICK (LIST LENGTH &AUX LLOC FLOC)  (SETQ LLOC (%MAKE-POINTER DTP-LOCATIVE LIST))  (IF SORT-DUMMY-ARRAY-HEADER      (CHANGE-INDIRECT-ARRAY SORT-DUMMY-ARRAY-HEADER 'ART-Q-LIST (1+ LENGTH)     LLOC NIL)      (SETQ SORT-DUMMY-ARRAY-HEADER (MAKE-ARRAY (1+ LENGTH):TYPE 'ART-Q-LIST:DISPLACED-TO LLOC)))  (SETQ LLOC (%MAKE-POINTER-OFFSET DTP-LIST LIST LENGTH))  (COND ((= DTP-HEADER-FORWARD (%P-DATA-TYPE LLOC)) (SETQ FLOC (%P-CONTENTS-AS-LOCATIVE LLOC)) ;; Replace the RPLACD forwarding pointer with the CAR it points to (%P-STORE-TAG-AND-POINTER LLOC (%P-DATA-TYPE FLOC) (%P-POINTER FLOC)) (%P-STORE-CDR-CODE CDR-NIL LLOC)));; TGC (%P-DPB CDR-NIL %%Q-CDR-CODE LLOC)))  (SORT-ARRAY-QUICK SORT-DUMMY-ARRAY-HEADER 0 LENGTH);Call array quicksort on it  (COND (FLOC ;; Update the CAR pointed to with the correct element of the sorted partial list (RPLACA FLOC (CAR LLOC)) (%P-STORE-TAG-AND-POINTER LLOC DTP-HEADER-FORWARD FLOC) (%P-STORE-CDR-CODE CDR-NORMAL LLOC))));; TGC (%P-DPB CDR-NORMAL %%Q-CDR-CODE LLOC)))); List sorting algorithm;; Due to MJF and GLS.;; The basic idea is to do a merge sort, which gets the list into; order by doing RPLACDs.  (This is the same algorithm as is; used for sorting lists in Maclisp.)  It operates by considering; the given list to be the frontier of a binary tree (which may be; incomplete if the length of the list is not a power of two).; At each node, the two nodes below it are merged.  The frontier; nodes are one-element lists, these are then merged into bigger lists.; Instead of the usual method of merging all pairs, then all pairs; of pairs, etc., this implementation effectively does a suffix walk; over the binary tree (thus it can grab items sequentially off the given list.); Warning: like DELQ and others, the safe way to use this; function is (SETQ FOO (ALPHASORT FOO)) or whatever.;; On the lisp machine, the above algorithm does not work well, because; cdr-coded (contiguous) lists cannot be RPLACD'ed without implicit CONSing.; Instead, contiguous chunks of the list are sorted in place.; The idea is to use a merge sort on the list of contiguous chunks; and to be a little hairy when comparing two chunks; in the merge.  First, on encountering each chunk it is sorted; (using quicksort).  Then, when two chunks meet during a merge,; they are merged together in place, one getting all the low elements; and one all thee high elements.  Deciding which one to use for the; high chunk is a little tricky; note the code carefully.; The two chunks are combined by a straight insertion technique; there may be; better ways to combine two already sorted chunks.  Another approach; not used here would be not to sort each chunk using quicksort except; the first, and then to be hairier about the insertion technique.(DEFUN SORT-LIST (SORT-INPUT-LIST &AUX SORT-DUMMY-ARRAY-HEADER)  (DO ((HEIGHT -1 (1+ HEIGHT))       (SOFAR NIL))      ((NULL SORT-INPUT-LIST)       (AND SORT-DUMMY-ARRAY-HEADER    (RETURN-STORAGE (PROG1 SORT-DUMMY-ARRAY-HEADER   (SETQ SORT-DUMMY-ARRAY-HEADER NIL))))       SOFAR)    (SETQ SOFAR (SORT-LIST-MERGE SOFAR (SORT-LIST-PREFIX HEIGHT)))))(DEFUN SORT-LIST-PREFIX (HEIGHT &AUX LENGTH LAST);GET MERGED BINARY TREE, SPECD HEIGHT  (COND ((NULL SORT-INPUT-LIST) NIL);INPUT EXHAUSTED, INCOMPLETE TREE((< HEIGHT 1) (MULTIPLE-VALUE-SETQ (LENGTH LAST);PULL OFF A CONTIGUOUS SEGMENT OF LIST       (CONTIGUOUS-LIST-INFO SORT-INPUT-LIST)) (AND (> LENGTH 0);IF MORE THAN A SINGLE CELL, SORT IT.      (SORT-CONTIG-LIST-QUICK SORT-INPUT-LIST LENGTH)) (PROG1 SORT-INPUT-LIST;RETURN THAT SEGMENT(AND (SETQ SORT-INPUT-LIST (CDR LAST));ADVANCE TO NEXT     (RPLACD LAST NIL))));MAKE SURE RETURNED SEGMENT ENDS((SORT-LIST-MERGE (SORT-LIST-PREFIX (1- HEIGHT))  (SORT-LIST-PREFIX (1- HEIGHT))))))(DEFUN SORT-LIST-MERGE (L1 L2 &AUX R);MERGE TWO SORTED LISTS, HACKING CONTIG  (DO ((P (LOCF R));R ACCUMULATES RESULT, P POINTS TO TAIL       (LAST1) (LENGTH1) (LAST2) (LENGTH2) (HIGH1) (HIGH2))      ((COND ((NULL L1);IF AN INPUT IS EXHAUSTED, DONE      (RPLACD P L2)      (RETURN R))     ((NULL L2)      (RPLACD P L1)      (RETURN R))))    (MULTIPLE-VALUE-SETQ (LENGTH1 LAST1) (CONTIGUOUS-LIST-INFO L1));PULL OFF A CONTIGUOUS CHUNK    (MULTIPLE-VALUE-SETQ (LENGTH2 LAST2) (CONTIGUOUS-LIST-INFO L2));OF EACH LIST    (SETQ HIGH1 (CAR LAST1) HIGH2 (CAR LAST2))    (COND ((APPLY-PREDICATE-AND-KEY SORT-LESSP-PREDICATE SORT-KEY-FUNCTION    HIGH2 (CAR L1));SEE IF CHUNK2 ALL < CHUNK1   (RPLACD P L2)   (SETQ P LAST2 L2 (CDR LAST2)))  ((OR (AND (= LENGTH1 0) (= LENGTH2 0));SMALL CHUNKS, BYPASS HAIR       (APPLY-PREDICATE-AND-KEY SORT-LESSP-PREDICATE SORT-KEY-FUNCTIONHIGH1 (CAR L2)));SEE IF CHUNK1 ALL < CHUNK2   (RPLACD P L1)   (SETQ P LAST1 L1 (CDR LAST1)))  ;; GOT TO MERGE CHUNKS, CHOOSE HIGHER.  BUT CORRECT THE LENGTHS FIRST.  ((APPLY-PREDICATE-AND-KEY SORT-LESSP-PREDICATE SORT-KEY-FUNCTION    HIGH1 HIGH2)   (SORT-LIST-MERGE-CONTIG L1 LENGTH1 L2 LENGTH2)   (RPLACD P L1)   (SETQ P LAST1 L1 (CDR LAST1)))  (T   (SORT-LIST-MERGE-CONTIG L2 LENGTH2 L1 LENGTH1)   (RPLACD P L2)   (SETQ P LAST2 L2 (CDR LAST2))))));MACROS FOR NEXT FUNCTION, ALLOW HACKING OF THE TWO LISTS AS ONE ARRAY.;ALSO NOTE THE EVALUATION OF THE SUBSCRIPT SHOULD NOT HAVE SIDE-EFFECTS.(eval-when (compile)(DEFMACRO SORT-LIST-AREF (I)  `(COND ((< ,I N1) (%P-CONTENTS-OFFSET L1 ,I)) ((= ,I N1) (IF (ZEROP N1) (CAR L1)(CADR (%MAKE-POINTER-OFFSET DTP-LIST L1 (1- N1))))) ((= ,I N1+N2+1) (IF (ZEROP N2) (CAR L2)     (CADR (%MAKE-POINTER-OFFSET DTP-LIST L2 (1- N2))))) (T (%P-CONTENTS-OFFSET L2 (- ,I (1+ N1))))))(DEFMACRO SORT-LIST-ASET (X I)  `(COND ((< ,I N1) (%P-STORE-CONTENTS-OFFSET ,X L1 ,I)) ((= ,I N1) (IF (ZEROP N1) (RPLACA L1 ,X)(RPLACA (CDR (%MAKE-POINTER-OFFSET DTP-LIST L1 (1- N1))) ,X))) ((= ,I N1+N2+1) (IF (ZEROP N2) (RPLACA L2 ,X)     (RPLACA (CDR (%MAKE-POINTER-OFFSET DTP-LIST L2 (1- N2))) ,X))) (T (%P-STORE-CONTENTS-OFFSET ,X L2 (- ,I (1+ N1)))))));SIMPLE-MINDED INSERTION-SORT TAIL-END TO MERGE TWO SORTED ARRAYS(DEFUN SORT-LIST-MERGE-CONTIG (L1 N1 L2 N2 &AUX (N1+N2+1 (+ N1 N2 1)))  (DO ((I (1+ N1) (1+ I)))      ((> I N1+N2+1))    (DO ((J (1- I) (1- J)) (X (SORT-LIST-AREF I)))((OR (< J 0)     (NOT (APPLY-PREDICATE-AND-KEY SORT-LESSP-PREDICATE SORT-KEY-FUNCTION   X (SORT-LIST-AREF J)))) (SORT-LIST-ASET X (1+ J)))      (SORT-LIST-ASET (SORT-LIST-AREF J) (1+ J)))));Quicksort for arrays.  If the array is small, does an insertion sort instead.(DEFUN SORT-ARRAY-QUICK (A L R)  (COND     ((> L (- R SORT-QS-BREAKEVEN));SEE IF SHOULD DO AN INSERTION SORT     (DO ((I (1+ L) (1+ I)));THIS CLAUSE ALSO APPLIES WHEN L>R ((> I R))       (DO ((J (1- I) (1- J))    (X (AREF a i)))   ((OR (< J L)(NOT (APPLY-PREDICATE-AND-KEY       SORT-LESSP-PREDICATE SORT-KEY-FUNCTION       X (AREF a j))))    (SETF (AREF a (1+ j)) x)) (SETF (AREF a (1+ j)) (AREF a j)))))    (T ((LAMBDA (N);RANDOMLY CHOSEN POINT BETWEEN L AND R  ((LAMBDA (M);BREAK-POINT BETWEEN LOW AND HIGH     (SORT-ARRAY-QUICK A L (1- M));SORT THE LOW ELEMENTS     (SORT-ARRAY-QUICK A (1+ M) R));SORT THE HIGH ELEMENTS   (DO ((K (PROG1 (AREF a n);K WILL BE M'TH ELEMENT  (SETF (AREF a n) (AREF a L))))(I L);A[...I-1] < K(J R));K < A[J+1...]       (NIL)     DECRJ;DECREASE J UNTIL K NOT LT A[J]     (COND ((= J I)    (SETF (AREF A I) K)    (RETURN I))   ((APPLY-PREDICATE-AND-KEY      SORT-LESSP-PREDICATE SORT-KEY-FUNCTION      K (AREF a j))    (SETQ J (1- J))    (GO DECRJ)))     (SETF (AREF A I) (AREF a j))     (SETQ I (1+ I))     INCRI;INCREASE I UNTIL K NOT GT A[I]     (COND ((= I J)    (SETF (AREF A J) K)    (RETURN J))   ((APPLY-PREDICATE-AND-KEY      SORT-LESSP-PREDICATE SORT-KEY-FUNCTION      (AREF a i) K)    (SETQ I (1+ I))    (GO INCRI)))     (SETF (AREF A J) (AREF a i))     (SETQ J (1- J)))));(+ L (RANDOM (+ (- R L) 1)))(+ L (TRUNCATE (- R L) 2));USE THIS UNTIL HAVE RANDOM FUNCTION))))(DEFUN SORT-GROUPED-ARRAY (ARRAY GROUP-SIZE SORT-LESSP-PREDICATE)  "Sort ARRAY, grouping elements into records of size GROUP-SIZE.The first GROUP-SIZE elements are the first record, etc.The first elements of two records are compared using the predicate,and entire records are reshuffled."  (PROG (SORT-ARRAY-TEMP-V)(SETQ SORT-ARRAY-TEMP-V (MAKE-ARRAY GROUP-SIZE))(SORT-GROUPED-ARRAY-QUICK ARRAY 0 (- (ARRAY-ACTIVE-LENGTH ARRAY) GROUP-SIZE) GROUP-SIZE)(RETURN-STORAGE (PROG1 SORT-ARRAY-TEMP-V (SETQ SORT-ARRAY-TEMP-V NIL)))(RETURN ARRAY)))(DEFUN SORT-GROUPED-ARRAY-QUICK (A L R GS)  (COND     ((> L (- R (* GS SORT-QS-BREAKEVEN)));SEE IF SHOULD DO AN INSERTION SORT     (DO ((I (+ L GS) (+ I GS)));THIS CLAUSE ALSO APPLIES WHEN L>R ((> I R))       (DO ((C 0 (1+ C)))   ((= C GS));COPY GUY OUT (SETF (AREF SORT-ARRAY-TEMP-V C)        (AREF A (+ I C))))       (DO ((J (- I GS) (- J GS))    (X (AREF A I)))   ((OR (< J L) (NOT (FUNCALL SORT-LESSP-PREDICATE X (AREF A J))))    (DO ((C 0 (1+ C)))((= C GS));ON EXIT, STICK THAT ENTRY      (SETF (AREF A (+ J GS C))    (AREF SORT-ARRAY-TEMP-V C))));BACK IN (DO ((C 0 (1+ C)))     ((= C GS))   (SETF (AREF A (+ J GS C)) (AREF A (+ C J)))))))    (T ((LAMBDA (N);RANDOMLY CHOSEN POINT BETWEEN L AND R  ((LAMBDA (M);BREAK-POINT BETWEEN LOW AND HIGH     (SORT-GROUPED-ARRAY-QUICK A L (- M GS) GS);SORT THE LOW ELEMENTS     (SORT-GROUPED-ARRAY-QUICK A (+ M GS) R GS));SORT THE HIGH ELEMENTS   (DO ((K (PROG1 (AREF A N);K WILL BE M'TH ELEMENT  (DO ((C 0 (1+ C)))      ((= C GS))    (SETF (AREF SORT-ARRAY-TEMP-V C);SAVE N IN TEMP  (AREF A (+ N C)))    (SETF (AREF A (+ N C)) (AREF A (+ L C))))));PUT;L WHERE N WAS(I L);A[...I-1] < K(J R));K < A[J+1...]       (NIL)     DECRJ;DECREASE J UNTIL K NOT LT A[J]     (COND ((= J I)    (DO ((C 0 (1+ C)))((= C GS))      (SETF (AREF A (+ I C))     (AREF SORT-ARRAY-TEMP-V C)))    (RETURN I))   ((FUNCALL SORT-LESSP-PREDICATE K (AREF A J))    (SETQ J (- J GS))    (GO DECRJ)))     (DO ((C 0 (1+ C))) ((= C GS))       (SETF (AREF A (+ I C)) (AREF A (+ J C))))     (SETQ I (+ I GS))     INCRI;INCREASE I UNTIL K NOT GT A[I]     (COND ((= I J)    (DO ((C 0 (1+ C)))((= C GS))      (SETF (AREF A (+ J C))    (AREF SORT-ARRAY-TEMP-V C)))    (RETURN J))   ((FUNCALL SORT-LESSP-PREDICATE (AREF A I) K)    (SETQ I (+ I GS))    (GO INCRI)))     (DO ((C 0 (1+ C))) ((= C GS))       (SETF (AREF A (+ J C)) (AREF A (+ I C))))     (SETQ J (- J GS)))));(+ L (RANDOM (+ (- R L) 1)))(+ L (* GS (FLOOR (FLOOR (- R L) 2) GS)));USE THIS UNTIL HAVE RANDOM FUNCTION;MAKE SURE RESULT IS A MULTIPLE OF GS))));SORT-LESSP-PREDICATE HERE MUST BE A FUNCTION OF FOUR ARGS,; <ARRAY1> <IDX1> <ARRAY2> <IDX2>.(DEFUN SORT-GROUPED-ARRAY-GROUP-KEY (ARRAY GROUP-SIZE SORT-LESSP-PREDICATE)  "Sort ARRAY, grouping elements into records of size GROUP-SIZE.The first GROUP-SIZE elements are the first record, etc.The predicate can compare entire records, since it is passedfour arguments, two array/index pairs each pointing at one records.Ultimately, entire records are reshuffled."  (PROG (SORT-ARRAY-TEMP-V)(SETQ SORT-ARRAY-TEMP-V (MAKE-ARRAY GROUP-SIZE))(SORT-GROUPED-ARRAY-GROUP-KEY-QUICK ARRAY 0 (- (ARRAY-ACTIVE-LENGTH ARRAY) GROUP-SIZE) GROUP-SIZE)(RETURN-STORAGE (PROG1 SORT-ARRAY-TEMP-V (SETQ SORT-ARRAY-TEMP-V NIL)))(RETURN ARRAY)))(DEFUN SORT-GROUPED-ARRAY-GROUP-KEY-QUICK (ARRAY L R GROUP-SIZE)  (COND     ((> L (- R (* GROUP-SIZE SORT-QS-BREAKEVEN)));SEE IF SHOULD DO AN INSERTION SORT     (DO ((I (+ L GROUP-SIZE) (+ I GROUP-SIZE)));THIS CLAUSE ALSO APPLIES WHEN L>R ((> I R))       (DO ((C 0 (1+ C)))   ((= C GROUP-SIZE));COPY GUY OUT (SETF (AREF SORT-ARRAY-TEMP-V C )       (AREF ARRAY (+ I C))))       (DO ((J (- I GROUP-SIZE) (- J GROUP-SIZE)))   ((OR (< J L) (NOT (FUNCALL SORT-LESSP-PREDICATE      SORT-ARRAY-TEMP-V 0 ARRAY J)))    (DO ((C 0 (1+ C)))((= C GROUP-SIZE));On exit, stick that entry back in.      (SETF (AREF ARRAY  (+ J GROUP-SIZE C))     (AREF SORT-ARRAY-TEMP-V C)))) (DO ((C 0 (1+ C)))     ((= C GROUP-SIZE))   (SETF (AREF ARRAY (+ J GROUP-SIZE C)) (AREF ARRAY (+ C J)))))))    ;; Divide the array into two halves, by exchanging elements, and sort them.    (T (LET ((N (+ L (* GROUP-SIZE (TRUNCATE (TRUNCATE (- R L) 2) GROUP-SIZE))))) ;;N is a randomly chosen point between L and R (actually not random) ;;Make sure result is a multiple of group-size (LET ((M (DO ((K;K WILL BE M'TH ELEMENT - K NOT USED IN THIS VERSION OF CODE; INSTEAD USE ARRAY SORT-ARRAY-TEMP-V, STARTING AT ELEMENT 0(DO ((C 0 (1+ C)))    ((= C GROUP-SIZE))  (SETF (AREF SORT-ARRAY-TEMP-V C);SAVE N IN TEMP(AREF ARRAY (+ N C)))  (SETF (AREF ARRAY (+ N C)) (AREF ARRAY (+ L C)))));PUT L WHERE N WAS      (I L);ARRAY[...I-1] < K      (J R));K < ARRAY[J+1...]     (NIL)   ;; Prevent warning about K.   (PROGN K)   DECRJ;DECREASE J UNTIL K NOT LT ARRAY[J]   (COND ((= J I)  (DO ((C 0 (1+ C)))      ((= C GROUP-SIZE))    (SETF (AREF ARRAY (+ I C) )  (AREF SORT-ARRAY-TEMP-V C)))  (RETURN I)) ((FUNCALL SORT-LESSP-PREDICATE SORT-ARRAY-TEMP-V 0 ARRAY J)  (SETQ J (- J GROUP-SIZE))  (GO DECRJ)))   (DO ((C 0 (1+ C)))       ((= C GROUP-SIZE))     (SETF (AREF ARRAY (+ I C)) (AREF ARRAY (+ J C))))   (SETQ I (+ I GROUP-SIZE))   INCRI;INCREASE I UNTIL K NOT GT ARRAY[I]   (COND ((= I J)  (DO ((C 0 (1+ C)))      ((= C GROUP-SIZE))    (SETF (AREF ARRAY (+ J C))  (AREF SORT-ARRAY-TEMP-V C)))  (RETURN J)) ((FUNCALL SORT-LESSP-PREDICATE ARRAY I SORT-ARRAY-TEMP-V 0)  (SETQ I (+ I GROUP-SIZE))  (GO INCRI)))   (DO ((C 0 (1+ C)))       ((= C GROUP-SIZE))     (SETF (AREF ARRAY (+ J C)) (AREF ARRAY (+ I C))))   (SETQ J (- J GROUP-SIZE)))))   ;; M is break-point between low and high   ;; Sort the low elements   (SORT-GROUPED-ARRAY-GROUP-KEY-QUICK     ARRAY L (- M GROUP-SIZE) GROUP-SIZE)   ;; Sort the high elements.   (SORT-GROUPED-ARRAY-GROUP-KEY-QUICK     ARRAY (+ M GROUP-SIZE) R GROUP-SIZE))))))(DEFUN MERGE (RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY KEY)  "Return a single sequence containing the elements of SEQUENCE1 and SEQUENCE2 interleaved.The interleaving is done by taking the next element of SEQUENCE1 unlessthe next element of SEQUENCE2 is \"less\" than it according to PREDICATE.KEY, if non-NIL, is applied to each element to get the object topass to PREDICATE, rather than the element itself.RESULT-TYPE specifies the type of sequence returned."  (LET ((INDEX-OR-TAIL-1 (SEQ-START SEQUENCE1))(INDEX-OR-TAIL-2 (SEQ-START SEQUENCE2))(END1 (SEQ-END SEQUENCE1))(END2 (SEQ-END SEQUENCE2)))    (DO ((RESULT (MAKE-SEQUENCE RESULT-TYPE (+ (LENGTH SEQUENCE1) (LENGTH SEQUENCE2)))) (STORE-INDEX 0 (1+ STORE-INDEX)))(())      (COND ((EQ INDEX-OR-TAIL-1 END1)     (IF (EQ INDEX-OR-TAIL-2 END2) (RETURN RESULT)       (SEQ-CONTIG-STORE RESULT STORE-INDEX (SEQ-FETCH SEQUENCE2 INDEX-OR-TAIL-2))       (SEQ-INC INDEX-OR-TAIL-2)))    ((EQ INDEX-OR-TAIL-2 END2)     (SEQ-CONTIG-STORE RESULT STORE-INDEX (SEQ-FETCH SEQUENCE1 INDEX-OR-TAIL-1))     (SEQ-INC INDEX-OR-TAIL-1))    (T (LET ((E1 (SEQ-FETCH SEQUENCE1 INDEX-OR-TAIL-1))     (E2 (SEQ-FETCH SEQUENCE2 INDEX-OR-TAIL-2))) (IF (APPLY-PREDICATE-AND-KEY PREDICATE KEY E2 E1)     (PROGN (SEQ-CONTIG-STORE RESULT STORE-INDEX E2)    (SEQ-INC INDEX-OR-TAIL-2))   (SEQ-CONTIG-STORE RESULT STORE-INDEX E1)   (SEQ-INC INDEX-OR-TAIL-1))))))))setf-methods  (mapcar #'(lambda (place)      (multiple-value-list (get-setf-method place)))  places)))    `(let* (,@(mapcan #'(lambda (setf-method) (mapcar #'list (first setf-method)  (second setf-method)))     setf-methods)    ,@(nreverse(maplist #'(lambda (setf-method-sublist)  `(,(first (third (car setf-method-sublist)))    ,(if (cdr setf-method-sublist) (fifth (second setf-method-sublist)) (fifth (first setf-methods)))))      setf-methods)))       ,@(mapcar #'(lambda