source: src/code/sort.lisp

20f-branchfile-attributerearrange-dirremove-long-floatrtoy-clm-oidsrtoy-clm-text-callbackrtoy-extern-alien-namertoy-lisp-trigrtoy-netbsd-64-bit-time-trtoy-search-list-as-hostrtoy-simp-dd-trigrtoy-unicode-6.2rtoy-update-unicode-6.3tcall-convention
Last change on this file was a99612, checked in by Raymond Toy <toy.raymond@…>, 3 years ago

Rearrange directory structure.

  • Property mode set to 100644
File size: 16.4 KB
Line 
1;;; -*- Log: code.log; Package: Lisp -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7(ext:file-comment
8  "$Header: src/code/sort.lisp $")
9;;;
10;;; **********************************************************************
11;;;
12;;; Sort functions for Spice Lisp
13;;;   these functions are part of the standard spice lisp environment. 
14;;;
15;;; Written by Jim Large
16;;; Hacked on and maintained by Skef Wholey
17;;; Rewritten by Bill Chiles
18;;;
19;;; *******************************************************************
20
21(in-package "LISP")
22(intl:textdomain "cmucl")
23
24(export '(sort stable-sort merge))
25
26
27
28(defun sort (sequence predicate &key key)
29  "Destructively sorts sequence.  Predicate should returns non-Nil if
30   Arg1 is to precede Arg2."
31  (typecase sequence
32    (simple-vector
33     (if (> (the fixnum (length (the simple-vector sequence))) 0)
34         (sort-simple-vector sequence predicate key)
35         sequence))
36    (list
37     (sort-list sequence predicate key))
38    (vector
39     (if (> (the fixnum (length sequence)) 0)
40         (sort-vector sequence predicate key)
41         sequence))
42    (t
43     (error 'simple-type-error
44            :datum sequence
45            :expected-type 'sequence
46            :format-control (intl:gettext "~S is not a sequence.")
47            :format-arguments (list sequence)))))
48
49
50
51;;; Sorting Vectors
52
53;;; Sorting is done with a heap sort.
54
55(eval-when (compile eval)
56
57;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element
58;;; through the sons to form a heap at root.  Root and max are zero based
59;;; coordinates, but the heap algorithm only works on arrays indexed from 1
60;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I
61;;; and 2*I+1 which does not work for a root at 0.  Because of this, boundaries,
62;;; roots, and termination are computed using 1..N indexes.
63
64(defmacro heapify (seq vector-ref root max pred key)
65  (let ((heap-root (gensym))   (heap-max (gensym))     (root-ele (gensym))
66        (root-key (gensym))    (heap-max/2 (gensym))   (heap-l-son (gensym))
67        (one-son (gensym))     (one-son-ele (gensym))  (one-son-key (gensym))
68        (r-son-ele (gensym))   (r-son-key (gensym))    (var-root (gensym)))
69    `(let* ((,var-root ,root) ; necessary to not clobber calling root var.
70            (,heap-root (1+ ,root))
71            (,heap-max (1+ ,max))
72            (,root-ele (,vector-ref ,seq ,root))
73            (,root-key (apply-key ,key ,root-ele))
74            (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
75       (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
76       (loop
77        (if (> ,heap-root ,heap-max/2) (return))
78        (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
79               ;; l-son index in seq (0..N-1) is one less than heap computation
80               (,one-son (1- ,heap-l-son))
81               (,one-son-ele (,vector-ref ,seq ,one-son))
82               (,one-son-key (apply-key ,key ,one-son-ele)))
83          (declare (fixnum ,heap-l-son ,one-son))
84          (if (< ,heap-l-son ,heap-max)
85              ;; there is a right son.
86              (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
87                     (,r-son-key (apply-key ,key ,r-son-ele)))
88                ;; choose the greater of the two sons.
89                (when (funcall ,pred ,one-son-key ,r-son-key)
90                  (setf ,one-son ,heap-l-son)
91                  (setf ,one-son-ele ,r-son-ele)
92                  (setf ,one-son-key ,r-son-key))))
93          ;; if greater son is less than root, then we've formed a heap again.
94          (if (funcall ,pred ,one-son-key ,root-key) (return))
95          ;; else put greater son at root and make greater son node be the root.
96          (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
97          (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates.
98          (setf ,var-root ,one-son)))     ; actual index into vector for root ele.
99       ;; now really put percolated value into heap at the appropriate root node.
100       (setf (,vector-ref ,seq ,var-root) ,root-ele))))
101
102
103;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting.
104(defmacro build-heap (seq type len-1 pred key)
105  (let ((i (gensym)))
106    `(do ((,i (floor ,len-1 2) (1- ,i)))
107         ((minusp ,i) ,seq)
108       (declare (fixnum ,i))
109       (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
110
111) ; eval-when
112
113
114;;; Make simple-vector and miscellaneous vector sorting functions.
115(macrolet ((frob-rob (fun-name vector-ref)
116             `(defun ,fun-name (seq pred key)
117                (let ((len-1 (1- (length (the vector seq)))))
118                  (declare (fixnum len-1))
119                  (build-heap seq ,vector-ref len-1 pred key)
120                  (do* ((i len-1 i-1)
121                        (i-1 (1- i) (1- i-1)))
122                       ((zerop i) seq)
123                    (declare (fixnum i i-1))
124                    (rotatef (,vector-ref seq 0) (,vector-ref seq i))
125                    (heapify seq ,vector-ref 0 i-1 pred key))))))
126
127  (frob-rob sort-vector aref)
128
129  (frob-rob sort-simple-vector svref))
130
131
132
133;;;; Stable Sorting
134
135(defun stable-sort (sequence predicate &key key)
136  "Destructively sorts sequence.  Predicate should returns non-Nil if
137   Arg1 is to precede Arg2."
138  (typecase sequence
139    (simple-vector
140     (stable-sort-simple-vector sequence predicate key))
141    (list
142     (sort-list sequence predicate key))
143    (vector
144     (stable-sort-vector sequence predicate key))
145    (t
146     (error 'simple-type-error
147            :datum sequence
148            :expected-type 'sequence
149            :format-control (intl:gettext "~S is not a sequence.")
150            :format-arguments (list sequence)))))
151
152
153;;; Stable Sorting Lists
154
155
156;;; APPLY-PRED saves us a function call sometimes.
157(eval-when (compile eval)
158  (defmacro apply-pred (one two pred key)
159    `(if ,key
160         (funcall ,pred (funcall ,key ,one)
161                  (funcall ,key  ,two))
162         (funcall ,pred ,one ,two)))
163) ; eval-when
164
165
166;;; MERGE-LISTS*   originally written by Jim Large.
167;;;                modified to return a pointer to the end of the result
168;;;                   and to not cons header each time its called.
169;;; It destructively merges list-1 with list-2.  In the resulting
170;;; list, elements of list-2 are guaranteed to come after equal elements
171;;; of list-1.
172(defun merge-lists* (list-1 list-2 pred key
173                            &optional (merge-lists-header (list :header)))
174  (do* ((result merge-lists-header)
175        (P result))                            ; P points to last cell of result
176       ((or (null list-1) (null list-2))       ; done when either list used up 
177        (if (null list-1)                      ; in which case, append the
178            (rplacd p list-2)                  ;   other list
179            (rplacd p list-1))
180        (do ((drag p lead)
181             (lead (cdr p) (cdr lead)))
182            ((null lead)
183             (values (prog1 (cdr result)       ; return the result sans header
184                            (rplacd result nil)) ; (free memory, be careful)
185                     drag))))                  ; and return pointer to last element
186    (cond ((apply-pred (car list-2) (car list-1) pred key)
187           (rplacd p list-2)           ; append the lesser list to last cell of
188           (setq p (cdr p))            ;   result.  Note: test must bo done for
189           (pop list-2))               ;   list-2 < list-1 so merge will be
190          (T (rplacd p list-1)         ;   stable for list-1
191             (setq p (cdr p))
192             (pop list-1)))))
193
194
195;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
196;;; the list grabbing one element at a time and merging it with the next one
197;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
198;;; in runs of two, merging one run with the next to form quadruples of sorted
199;;; elements.  This continues until n is large enough that the inner loop only
200;;; runs for one iteration; that is, there are only two runs that can be merged,
201;;; the first run starting at the beginning of the list, and the second being
202;;; the remaining elements.
203
204(defun sort-list (list pred key)
205  (let ((head (cons :header list))  ; head holds on to everything
206        (n 1)                       ; bottom-up size of lists to be merged
207        unsorted                    ; unsorted is the remaining list to be
208                                    ;   broken into n size lists and merged
209        list-1                      ; list-1 is one length n list to be merged
210        last                        ; last points to the last visited cell
211        (merge-lists-header (list :header)))
212    (declare (fixnum n))
213    (loop
214     ;; start collecting runs of n at the first element
215     (setf unsorted (cdr head))
216     ;; tack on the first merge of two n-runs to the head holder
217     (setf last head)
218     (let ((n-1 (1- n)))
219       (declare (fixnum n-1))
220       (loop
221        (setf list-1 unsorted)
222        (let ((temp (nthcdr n-1 list-1))
223              list-2)
224          (cond (temp
225                 ;; there are enough elements for a second run
226                 (setf list-2 (cdr temp))
227                 (setf (cdr temp) nil)
228                 (setf temp (nthcdr n-1 list-2))
229                 (cond (temp
230                        (setf unsorted (cdr temp))
231                        (setf (cdr temp) nil))
232                       ;; the second run goes off the end of the list
233                       (t (setf unsorted nil)))
234                 (multiple-value-bind (merged-head merged-last)
235                                      (merge-lists* list-1 list-2 pred key
236                                                    merge-lists-header)
237                   (setf (cdr last) merged-head)
238                   (setf last merged-last))
239                 (if (null unsorted) (return)))
240                ;; if there is only one run, then tack it on to the end
241                (t (setf (cdr last) list-1)
242                   (return)))))
243       (setf n (ash n 1)) ; (+ n n)
244       ;; If the inner loop only executed once, then there were only enough
245       ;; elements for two runs given n, so all the elements have been merged
246       ;; into one list.  This may waste one outer iteration to realize.
247       (if (eq list-1 (cdr head))
248           (return list-1))))))
249
250
251
252;;; Stable Sort Vectors
253
254;;; Stable sorting vectors is done with the same algorithm used for lists,
255;;; using a temporary vector to merge back and forth between it and the
256;;; given vector to sort.
257
258
259(eval-when (compile eval)
260
261;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
262;;;    start-1 (inclusive) ... end-1 (exclusive) and
263;;;    end-1 (inclusive) ... end-2 (exclusive),
264;;; and merges them into a target vector starting at index start-1.
265
266(defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
267                                             pred key source-ref target-ref)
268  (let ((i (gensym))
269        (j (gensym))
270        (target-i (gensym)))
271    `(let ((,i ,start-1)
272           (,j ,end-1) ; start-2
273           (,target-i ,start-1))
274       (declare (fixnum ,i ,j ,target-i))
275       (loop
276        (cond ((= ,i ,end-1)
277               (loop (if (= ,j ,end-2) (return))
278                     (setf (,target-ref ,target ,target-i)
279                           (,source-ref ,source ,j))
280                     (incf ,target-i)
281                     (incf ,j))
282               (return))
283              ((= ,j ,end-2)
284               (loop (if (= ,i ,end-1) (return))
285                     (setf (,target-ref ,target ,target-i)
286                           (,source-ref ,source ,i))
287                     (incf ,target-i)
288                     (incf ,i))
289               (return))
290              ((apply-pred (,source-ref ,source ,j)
291                           (,source-ref ,source ,i)
292                           ,pred ,key)
293               (setf (,target-ref ,target ,target-i)
294                     (,source-ref ,source ,j))
295               (incf ,j))
296              (t (setf (,target-ref ,target ,target-i)
297                       (,source-ref ,source ,i))
298                 (incf ,i)))
299        (incf ,target-i)))))
300
301
302;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
303;;; it uses a temporary vector.  Direction determines whether we are merging
304;;; into the temporary (T) or back into the given vector (NIL).
305
306(defmacro vector-merge-sort (vector pred key vector-ref)
307  (let ((vector-len (gensym))           (n (gensym))
308        (direction (gensym))            (unsorted (gensym))
309        (start-1 (gensym))              (end-1 (gensym))
310        (end-2 (gensym))                (i (gensym))
311        (temp-vector (gensym)))
312    `(let* ((,vector-len (length (the vector ,vector)))
313            (,n 1)         ; bottom-up size of contiguous runs to be merged
314            (,direction t) ; t vector --> temp    nil temp --> vector
315            (,temp-vector (make-array ,vector-len))
316            (,unsorted 0)  ; unsorted..vector-len are the elements that need
317                           ; to be merged for a given n
318            (,start-1 0))  ; one n-len subsequence to be merged with the next
319       (declare (fixnum ,vector-len ,n ,unsorted ,start-1)     
320                (type simple-vector ,temp-vector))
321       (loop
322        ;; for each n, we start taking n-runs from the start of the vector
323        (setf ,unsorted 0)
324        (loop
325         (setf ,start-1 ,unsorted)
326         (let ((,end-1 (+ ,start-1 ,n)))
327           (declare (fixnum ,end-1))
328           (cond ((< ,end-1 ,vector-len)
329                  ;; there are enough elements for a second run
330                  (let ((,end-2 (+ ,end-1 ,n)))
331                    (declare (fixnum ,end-2))
332                    (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
333                    (setf ,unsorted ,end-2)
334                    (if ,direction
335                        (stable-sort-merge-vectors*
336                         ,vector ,temp-vector
337                         ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
338                        (stable-sort-merge-vectors*
339                         ,temp-vector ,vector
340                         ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
341                    (if (= ,unsorted ,vector-len) (return))))
342                 ;; if there is only one run, copy those elements to the end
343                 (t (if ,direction
344                        (do ((,i ,start-1 (1+ ,i)))
345                            ((= ,i ,vector-len))
346                          (declare (fixnum ,i))
347                          (setf (svref ,temp-vector ,i)
348                                (,vector-ref ,vector ,i)))
349                        (do ((,i ,start-1 (1+ ,i)))
350                            ((= ,i ,vector-len))
351                          (declare (fixnum ,i))
352                          (setf (,vector-ref ,vector ,i)
353                                (svref ,temp-vector ,i))))
354                    (return)))))
355        ;; If the inner loop only executed once, then there were only enough
356        ;; elements for two subsequences given n, so all the elements have
357        ;; been merged into one list.  Start-1 will have remained 0 upon exit.
358        (when (zerop ,start-1)
359          (if ,direction
360              ;; if we just merged into the temporary, copy it all back
361              ;; to the given vector.
362              (dotimes (,i ,vector-len)
363                (setf (,vector-ref ,vector ,i)
364                      (svref ,temp-vector ,i))))
365          (return ,vector))
366        (setf ,n (ash ,n 1)) ; (* 2 n)
367        (setf ,direction (not ,direction))))))
368
369) ; eval-when
370
371
372(defun stable-sort-simple-vector (vector pred key)
373  (declare (simple-vector vector))
374  (vector-merge-sort vector pred key svref))
375
376(defun stable-sort-vector (vector pred key)
377  (vector-merge-sort vector pred key aref))
378
379
380
381;;;; Merge
382
383(eval-when (compile eval)
384
385;;; MERGE-VECTORS returns a new vector which contains an interleaving
386;;; of the elements of vector-1 and vector-2.  Elements from vector-2 are
387;;; chosen only if they are strictly less than elements of vector-1,
388;;; (pred elt-2 elt-1), as specified in the manual.
389
390(defmacro merge-vectors (vector-1 length-1 vector-2 length-2
391                         result-vector pred key access)
392  (let ((result-i (gensym))
393        (i (gensym))
394        (j (gensym)))
395    `(let* ((,result-i 0)
396            (,i 0)
397            (,j 0))
398       (declare (fixnum ,result-i ,i ,j))
399       (loop
400        (cond ((= ,i ,length-1)
401               (loop (if (= ,j ,length-2) (return))
402                     (setf (,access ,result-vector ,result-i)
403                           (,access ,vector-2 ,j))
404                     (incf ,result-i)
405                     (incf ,j))
406               (return ,result-vector))
407              ((= ,j ,length-2)
408               (loop (if (= ,i ,length-1) (return))
409                     (setf (,access ,result-vector ,result-i)
410                           (,access ,vector-1 ,i))
411                     (incf ,result-i)
412                     (incf ,i))
413               (return ,result-vector))
414              ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
415                           ,pred ,key)
416               (setf (,access ,result-vector ,result-i)
417                     (,access ,vector-2 ,j))
418               (incf ,j))
419              (t (setf (,access ,result-vector ,result-i)
420                       (,access ,vector-1 ,i))
421                 (incf ,i)))
422        (incf ,result-i)))))
423
424) ; eval-when
425
426(defun merge (result-type sequence1 sequence2 predicate &key key)
427  "The sequences Sequence1 and Sequence2 are destructively merged into
428   a sequence of type Result-Type using the Predicate to order the elements."
429  (cond ((or (eq result-type 'list)
430             (subtypep result-type 'list))
431         ;; Check the length of result-type and the sequence for
432         ;; consistency
433         (let ((s1 (coerce sequence1 'list))
434               (s2 (coerce sequence2 'list))
435               (type (specifier-type result-type)))
436           (cond ((type= type (specifier-type 'list))
437                  (values (merge-lists* s1 s2 predicate key)))
438                 ((eq type *empty-type*)
439                  (bad-sequence-type-error nil))
440                 ((type= type (specifier-type 'null))
441                  (if (and (null s1) (null s2))
442                      nil
443                      (sequence-length-error type
444                                             (+ (length s1) (length s2)))))
445                 ((csubtypep (specifier-type '(cons nil t)) type)
446                  (if (and (null s1) (null s2))
447                      (sequence-length-error type 0)
448                      (values (merge-lists* s1 s2 predicate key))))
449                 (t
450                  (values (merge-lists* s1 s2 predicate key))))))
451               
452        ((subtypep result-type 'vector)
453         (let* ((vector-1 (coerce sequence1 'vector))
454                (vector-2 (coerce sequence2 'vector))
455                (length-1 (length vector-1))
456                (length-2 (length vector-2))
457                (result (make-sequence result-type (+ length-1 length-2))))
458           (declare (vector vector-1 vector-2)
459                    (fixnum length-1 length-2))
460           (if (and (simple-vector-p result)
461                    (simple-vector-p vector-1)
462                    (simple-vector-p vector-2))
463               (merge-vectors vector-1 length-1 vector-2 length-2
464                              result predicate key svref)
465               (merge-vectors vector-1 length-1 vector-2 length-2
466                              result predicate key aref))))
467        (t
468         (bad-sequence-type-error result-type))))
Note: See TracBrowser for help on using the repository browser.