0.7.13.3
[sbcl.git] / src / code / sort.lisp
1 ;;;; SORT and friends
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13
14 ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
15 ;;; isn't really related to the CMU CL code, since instead of trying
16 ;;; to generalize the CMU CL code to allow START and END values, this
17 ;;; code has been written from scratch following Chapter 7 of
18 ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
19 (defun sort-vector (vector start end predicate key)
20   (sort-vector vector start end predicate key))
21
22 ;;; This is MAYBE-INLINE because it's not too hard to have an
23 ;;; application where sorting is a major bottleneck, and inlining it
24 ;;; allows the compiler to make enough optimizations that it might be
25 ;;; worth the (large) cost in space.
26 (declaim (maybe-inline sort))
27 (defun sort (sequence predicate &key key)
28   #!+sb-doc
29   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
30    ARG1 is to precede ARG2."
31   (let ((predicate-function (%coerce-callable-to-fun predicate))
32         (key-function (and key (%coerce-callable-to-fun key))))
33     (typecase sequence
34       (list (stable-sort-list sequence predicate-function key-function))
35       (vector
36        (with-array-data ((vector (the vector sequence))
37                          (start 0)
38                          (end (length sequence)))
39          (sort-vector vector start end predicate-function key-function))
40        sequence)
41       (t
42        (error 'simple-type-error
43               :datum sequence
44               :expected-type 'sequence
45               :format-control "~S is not a sequence."
46               :format-arguments (list sequence))))))
47 \f
48 ;;;; stable sorting
49
50 (defun stable-sort (sequence predicate &key key)
51   #!+sb-doc
52   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
53    ARG1 is to precede ARG2."
54   (typecase sequence
55     (simple-vector
56      (stable-sort-simple-vector sequence predicate key))
57     (list
58      (stable-sort-list sequence predicate key))
59     (vector
60      (stable-sort-vector sequence predicate key))
61     (t
62      (error 'simple-type-error
63             :datum sequence
64             :expected-type 'sequence
65             :format-control "~S is not a sequence."
66             :format-arguments (list sequence)))))
67 \f
68 ;;; APPLY-KEYED-PRED saves us a function call sometimes.
69 (eval-when (:compile-toplevel :execute)
70   (sb!xc:defmacro apply-keyed-pred (one two pred key)
71     `(if ,key
72          (funcall ,pred (funcall ,key ,one)
73                   (funcall ,key  ,two))
74          (funcall ,pred ,one ,two)))
75 ) ; EVAL-WHEN
76 \f
77 ;;;; stable sort of lists
78
79 (defun last-cons-of (list)
80   (loop (let ((rest (rest list)))
81           (if rest
82               (setf list rest)
83               (return list)))))
84
85 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
86 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
87 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
88 ;;; come before equal elements of LIST-2.
89 ;;;
90 ;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
91 ;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
92 ;;; the last cons in the list which NRECONC calls TAIL).
93 (defun merge-lists* (list-1 list-2 pred-fun key-fun)
94   (declare (type list list-1 list-2))
95   (declare (type function pred-fun key-fun))
96   (cond ((null list-1) (values list-2 (last-cons-of list-2)))
97         ((null list-2) (values list-1 (last-cons-of list-1)))
98         (t (let* ((reversed-result-so-far nil)
99                   (key-1 (funcall key-fun (car list-1)))
100                   (key-2 (funcall key-fun (car list-2))))
101              (loop
102               (macrolet ((frob (list-i key-i other-list)
103                            `(progn
104                               ;; basically
105                               ;;   (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
106                               ;; except doing some fancy footwork to
107                               ;; reuse the cons cell:
108                               (psetf (cdr ,list-i) reversed-result-so-far
109                                      reversed-result-so-far ,list-i
110                                      ,list-i (cdr ,list-i))
111                               ;; Now maybe we're done.
112                               (if (endp ,list-i)
113                                   (return (values (nreconc
114                                                    reversed-result-so-far
115                                                    ,other-list)
116                                                   (last-cons-of
117                                                    ,other-list)))
118                                   (setf ,key-i
119                                         (funcall key-fun (car ,list-i)))))))
120                 ;; Note that by making KEY-2 the first arg to
121                 ;; PRED-FUN, we arrange that if PRED-FUN is a function
122                 ;; in the #'< style, the outcome is stably sorted.
123                 (if (funcall pred-fun key-2 key-1)
124                     (frob list-2 key-2 list-1)
125                     (frob list-1 key-1 list-2))))))))
126
127 ;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
128 ;;; over the list grabbing one element at a time and merging it with
129 ;;; the next one to form pairs of sorted elements. Then N is doubled,
130 ;;; and elements are taken in runs of two, merging one run with the
131 ;;; next to form quadruples of sorted elements. This continues until N
132 ;;; is large enough that the inner loop only runs for one iteration;
133 ;;; that is, there are only two runs that can be merged, the first run
134 ;;; starting at the beginning of the list, and the second being the
135 ;;; remaining elements.
136 (defun stable-sort-list (list pred key)
137   (let ((head (cons :header list))  ; head holds on to everything
138         (n 1)                       ; bottom-up size of lists to be merged
139         unsorted                    ; unsorted is the remaining list to be
140                                     ;   broken into n size lists and merged
141         list-1                      ; list-1 is one length n list to be merged
142         last                        ; last points to the last visited cell
143         (pred-fun (%coerce-callable-to-fun pred))
144         (key-fun (if key
145                      (%coerce-callable-to-fun key)
146                      #'identity)))
147     (declare (fixnum n))
148     (loop
149      ;; Start collecting runs of N at the first element.
150      (setf unsorted (cdr head))
151      ;; Tack on the first merge of two N-runs to the head holder.
152      (setf last head)
153      (let ((n-1 (1- n)))
154        (declare (fixnum n-1))
155        (loop
156         (setf list-1 unsorted)
157         (let ((temp (nthcdr n-1 list-1))
158               list-2)
159           (cond (temp
160                  ;; There are enough elements for a second run.
161                  (setf list-2 (cdr temp))
162                  (setf (cdr temp) nil)
163                  (setf temp (nthcdr n-1 list-2))
164                  (cond (temp
165                         (setf unsorted (cdr temp))
166                         (setf (cdr temp) nil))
167                        ;; The second run goes off the end of the list.
168                        (t (setf unsorted nil)))
169                  (multiple-value-bind (merged-head merged-last)
170                      (merge-lists* list-1 list-2 pred-fun key-fun)
171                    (setf (cdr last) merged-head
172                          last merged-last))
173                  (if (null unsorted) (return)))
174                 ;; If there is only one run, then tack it on to the end.
175                 (t (setf (cdr last) list-1)
176                    (return)))))
177        (setf n (ash n 1)) ; (+ n n)
178        ;; If the inner loop only executed once, then there were only
179        ;; enough elements for two runs given n, so all the elements
180        ;; have been merged into one list. This may waste one outer
181        ;; iteration to realize.
182        (if (eq list-1 (cdr head))
183            (return list-1))))))
184 \f
185 ;;;; stable sort of vectors
186
187 ;;; Stable sorting vectors is done with the same algorithm used for
188 ;;; lists, using a temporary vector to merge back and forth between it
189 ;;; and the given vector to sort.
190
191 (eval-when (:compile-toplevel :execute)
192
193 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
194 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
195 ;;;    end-1 (inclusive) ... end-2 (exclusive),
196 ;;; and merges them into a target vector starting at index start-1.
197
198 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
199                                                      pred key source-ref
200                                                      target-ref)
201   (let ((i (gensym))
202         (j (gensym))
203         (target-i (gensym)))
204     `(let ((,i ,start-1)
205            (,j ,end-1) ; start-2
206            (,target-i ,start-1))
207        (declare (fixnum ,i ,j ,target-i))
208        (loop
209         (cond ((= ,i ,end-1)
210                (loop (if (= ,j ,end-2) (return))
211                      (setf (,target-ref ,target ,target-i)
212                            (,source-ref ,source ,j))
213                      (incf ,target-i)
214                      (incf ,j))
215                (return))
216               ((= ,j ,end-2)
217                (loop (if (= ,i ,end-1) (return))
218                      (setf (,target-ref ,target ,target-i)
219                            (,source-ref ,source ,i))
220                      (incf ,target-i)
221                      (incf ,i))
222                (return))
223               ((apply-keyed-pred (,source-ref ,source ,j)
224                                  (,source-ref ,source ,i)
225                                  ,pred ,key)
226                (setf (,target-ref ,target ,target-i)
227                      (,source-ref ,source ,j))
228                (incf ,j))
229               (t (setf (,target-ref ,target ,target-i)
230                        (,source-ref ,source ,i))
231                  (incf ,i)))
232         (incf ,target-i)))))
233
234 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
235 ;;; but it uses a temporary vector. DIRECTION determines whether we
236 ;;; are merging into the temporary (T) or back into the given vector
237 ;;; (NIL).
238 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
239   (let ((vector-len (gensym)) (n (gensym))
240         (direction (gensym))  (unsorted (gensym))
241         (start-1 (gensym))    (end-1 (gensym))
242         (end-2 (gensym))      (temp-len (gensym))
243         (i (gensym)))
244     `(let ((,vector-len (length (the vector ,vector)))
245            (,n 1)        ; bottom-up size of contiguous runs to be merged
246            (,direction t) ; t vector --> temp    nil temp --> vector
247            (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
248            (,unsorted 0)  ; unsorted..vector-len are the elements that need
249                           ; to be merged for a given n
250            (,start-1 0))  ; one n-len subsequence to be merged with the next
251        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
252        (if (> ,vector-len ,temp-len)
253            (setf *merge-sort-temp-vector*
254                  (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
255        (loop
256         ;; for each n, we start taking n-runs from the start of the vector
257         (setf ,unsorted 0)
258         (loop
259          (setf ,start-1 ,unsorted)
260          (let ((,end-1 (+ ,start-1 ,n)))
261            (declare (fixnum ,end-1))
262            (cond ((< ,end-1 ,vector-len)
263                   ;; there are enough elements for a second run
264                   (let ((,end-2 (+ ,end-1 ,n)))
265                     (declare (fixnum ,end-2))
266                     (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
267                     (setf ,unsorted ,end-2)
268                     (if ,direction
269                         (stable-sort-merge-vectors*
270                          ,vector *merge-sort-temp-vector*
271                          ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
272                         (stable-sort-merge-vectors*
273                          *merge-sort-temp-vector* ,vector
274                          ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
275                     (if (= ,unsorted ,vector-len) (return))))
276                  ;; if there is only one run, copy those elements to the end
277                  (t (if ,direction
278                         (do ((,i ,start-1 (1+ ,i)))
279                             ((= ,i ,vector-len))
280                           (declare (fixnum ,i))
281                           (setf (svref *merge-sort-temp-vector* ,i)
282                                 (,vector-ref ,vector ,i)))
283                         (do ((,i ,start-1 (1+ ,i)))
284                             ((= ,i ,vector-len))
285                           (declare (fixnum ,i))
286                           (setf (,vector-ref ,vector ,i)
287                                 (svref *merge-sort-temp-vector* ,i))))
288                     (return)))))
289         ;; If the inner loop only executed once, then there were only enough
290         ;; elements for two subsequences given n, so all the elements have
291         ;; been merged into one list. Start-1 will have remained 0 upon exit.
292         (when (zerop ,start-1)
293           (if ,direction
294               ;; if we just merged into the temporary, copy it all back
295               ;; to the given vector.
296               (dotimes (,i ,vector-len)
297                 (setf (,vector-ref ,vector ,i)
298                       (svref *merge-sort-temp-vector* ,i))))
299           (return ,vector))
300         (setf ,n (ash ,n 1)) ; (* 2 n)
301         (setf ,direction (not ,direction))))))
302
303 ) ; EVAL-when
304
305 ;;; temporary vector for stable sorting vectors
306 (defvar *merge-sort-temp-vector*
307   (make-array 50))
308
309 (declaim (simple-vector *merge-sort-temp-vector*))
310
311 (defun stable-sort-simple-vector (vector pred key)
312   (declare (simple-vector vector))
313   (vector-merge-sort vector pred key svref))
314
315 (defun stable-sort-vector (vector pred key)
316   (vector-merge-sort vector pred key aref))
317 \f
318 ;;;; merging
319
320 (eval-when (:compile-toplevel :execute)
321
322 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
323 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
324 ;;; are chosen only if they are strictly less than elements of
325 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
326 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
327                                result-vector pred key access)
328   (let ((result-i (gensym))
329         (i (gensym))
330         (j (gensym)))
331     `(let* ((,result-i 0)
332             (,i 0)
333             (,j 0))
334        (declare (fixnum ,result-i ,i ,j))
335        (loop
336         (cond ((= ,i ,length-1)
337                (loop (if (= ,j ,length-2) (return))
338                      (setf (,access ,result-vector ,result-i)
339                            (,access ,vector-2 ,j))
340                      (incf ,result-i)
341                      (incf ,j))
342                (return ,result-vector))
343               ((= ,j ,length-2)
344                (loop (if (= ,i ,length-1) (return))
345                      (setf (,access ,result-vector ,result-i)
346                            (,access ,vector-1 ,i))
347                      (incf ,result-i)
348                      (incf ,i))
349                (return ,result-vector))
350               ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
351                                  ,pred ,key)
352                (setf (,access ,result-vector ,result-i)
353                      (,access ,vector-2 ,j))
354                (incf ,j))
355               (t (setf (,access ,result-vector ,result-i)
356                        (,access ,vector-1 ,i))
357                  (incf ,i)))
358         (incf ,result-i)))))
359
360 ) ; EVAL-WHEN
361
362 (defun merge (result-type sequence1 sequence2 predicate &key key)
363   #!+sb-doc
364   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
365    sequence of type RESULT-TYPE using PREDICATE to order the elements."
366   ;; FIXME: This implementation is remarkably inefficient in various
367   ;; ways. In decreasing order of estimated user astonishment, I note:
368   ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
369   ;; to lists before doing MERGE-LISTS*; and walking input lists
370   ;; (because of the call to MERGE-LISTS*, which walks the list to
371   ;; find the last element for its second return value) even in cases
372   ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
373   ;; can be largely ignored. -- WHN 2003-01-05
374   (let ((type (specifier-type result-type)))
375     (cond
376       ((csubtypep type (specifier-type 'list))
377        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
378        ;; benefits from the error checking there. Short of
379        ;; reimplementing everything, we can't do the same for the LIST
380        ;; case, so do relevant length checking here:
381        (let ((s1 (coerce sequence1 'list))
382              (s2 (coerce sequence2 'list))
383              (pred-fun (%coerce-callable-to-fun predicate))
384              (key-fun (if key
385                           (%coerce-callable-to-fun key)
386                           #'identity)))
387          (when (type= type (specifier-type 'list))
388            (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun))))
389          (when (eq type *empty-type*)
390            (bad-sequence-type-error nil))
391          (when (type= type (specifier-type 'null))
392            (if (and (null s1) (null s2))
393                (return-from merge 'nil)
394                ;; FIXME: This will break on circular lists (as,
395                ;; indeed, will the whole MERGE function).
396                (sequence-type-length-mismatch-error type
397                                                     (+ (length s1)
398                                                        (length s2)))))
399          (if (csubtypep (specifier-type '(cons nil t)) type)
400              (if (and (null s1) (null s2))
401                  (sequence-type-length-mismatch-error type 0)
402                  (values (merge-lists* s1 s2 pred-fun key-fun)))
403              (sequence-type-too-hairy result-type))))
404       ((csubtypep type (specifier-type 'vector))
405        (let* ((vector-1 (coerce sequence1 'vector))
406               (vector-2 (coerce sequence2 'vector))
407               (length-1 (length vector-1))
408               (length-2 (length vector-2))
409               (result (make-sequence result-type
410                                      (+ length-1 length-2))))
411          (declare (vector vector-1 vector-2)
412                   (fixnum length-1 length-2))
413          (if (and (simple-vector-p result)
414                   (simple-vector-p vector-1)
415                   (simple-vector-p vector-2))
416              (merge-vectors vector-1 length-1 vector-2 length-2
417                             result predicate key svref)
418              (merge-vectors vector-1 length-1 vector-2 length-2
419                             result predicate key aref))))
420       (t (bad-sequence-type-error result-type)))))