0.7.11.5:
[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 (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 sorts 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      (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
68 ;;; stable sort of lists
69
70 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
71 ;;; the list grabbing one element at a time and merging it with the
72 ;;; next one form pairs of sorted elements. Then n is doubled, and
73 ;;; elements are taken in runs of two, merging one run with the next
74 ;;; to form quadruples of sorted elements. This continues until n is
75 ;;; large enough that the inner loop only runs for one iteration; that
76 ;;; is, there are only two runs that can be merged, the first run
77 ;;; starting at the beginning of the list, and the second being the
78 ;;; remaining elements.
79
80 (defun sort-list (list pred key)
81   (let ((head (cons :header list))  ; head holds on to everything
82         (n 1)                       ; bottom-up size of lists to be merged
83         unsorted                    ; unsorted is the remaining list to be
84                                     ;   broken into n size lists and merged
85         list-1                      ; list-1 is one length n list to be merged
86         last)                       ; last points to the last visited cell
87     (declare (fixnum n))
88     (loop
89      ;; start collecting runs of n at the first element
90      (setf unsorted (cdr head))
91      ;; tack on the first merge of two n-runs to the head holder
92      (setf last head)
93      (let ((n-1 (1- n)))
94        (declare (fixnum n-1))
95        (loop
96         (setf list-1 unsorted)
97         (let ((temp (nthcdr n-1 list-1))
98               list-2)
99           (cond (temp
100                  ;; there are enough elements for a second run
101                  (setf list-2 (cdr temp))
102                  (setf (cdr temp) nil)
103                  (setf temp (nthcdr n-1 list-2))
104                  (cond (temp
105                         (setf unsorted (cdr temp))
106                         (setf (cdr temp) nil))
107                        ;; the second run goes off the end of the list
108                        (t (setf unsorted nil)))
109                  (multiple-value-bind (merged-head merged-last)
110                      (merge-lists* list-1 list-2 pred key)
111                    (setf (cdr last) merged-head)
112                    (setf last merged-last))
113                  (if (null unsorted) (return)))
114                 ;; if there is only one run, then tack it on to the end
115                 (t (setf (cdr last) list-1)
116                    (return)))))
117        (setf n (ash n 1)) ; (+ n n)
118        ;; If the inner loop only executed once, then there were only
119        ;; enough elements for two runs given n, so all the elements
120        ;; have been merged into one list. This may waste one outer
121        ;; iteration to realize.
122        (if (eq list-1 (cdr head))
123            (return list-1))))))
124
125 ;;; APPLY-PRED saves us a function call sometimes.
126 (eval-when (:compile-toplevel :execute)
127   (sb!xc:defmacro apply-pred (one two pred key)
128     `(if ,key
129          (funcall ,pred (funcall ,key ,one)
130                   (funcall ,key  ,two))
131          (funcall ,pred ,one ,two)))
132 ) ; EVAL-WHEN
133
134 (defvar *merge-lists-header* (list :header))
135
136 ;;; MERGE-LISTS*   originally written by Jim Large.
137 ;;;                modified to return a pointer to the end of the result
138 ;;;                   and to not cons header each time its called.
139 ;;; It destructively merges list-1 with list-2. In the resulting
140 ;;; list, elements of list-2 are guaranteed to come after equal elements
141 ;;; of list-1.
142 (defun merge-lists* (list-1 list-2 pred key)
143   (let* ((result *merge-lists-header*)
144          (merge-lists-trailer (cdr *merge-lists-header*)))
145     (unwind-protect
146          (do ((P result))             ; points to last cell of result
147              ((or (null list-1) (null list-2)) ; done when either list used up
148               (if (null list-1)        ; in which case, append the
149                   (rplacd p list-2)    ;   other list
150                   (rplacd p list-1))
151               (do ((drag p lead)
152                    (lead (cdr p) (cdr lead)))
153                   ((null lead)
154                    (values (cdr result) ; Return the result sans header
155                            drag)))) ; and return pointer to last element.
156            (cond ((apply-pred (car list-2) (car list-1) pred key)
157                   (rplacd p list-2) ; Append the lesser list to last cell of
158                   (setq p (cdr p)) ; result. Note: test must be done for
159                   (pop list-2))     ; LIST-2 < LIST-1 so merge will be
160                  (T (rplacd p list-1)   ; stable for LIST-1.
161                     (setq p (cdr p))
162                     (pop list-1))))
163       (setf (cdr result) merge-lists-trailer) ; (free memory, be careful)
164       )))
165
166 ;;; stable sort of vectors
167
168 ;;; Stable sorting vectors is done with the same algorithm used for
169 ;;; lists, using a temporary vector to merge back and forth between it
170 ;;; and the given vector to sort.
171
172 (eval-when (:compile-toplevel :execute)
173
174 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
175 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
176 ;;;    end-1 (inclusive) ... end-2 (exclusive),
177 ;;; and merges them into a target vector starting at index start-1.
178
179 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
180                                                      pred key source-ref
181                                                      target-ref)
182   (let ((i (gensym))
183         (j (gensym))
184         (target-i (gensym)))
185     `(let ((,i ,start-1)
186            (,j ,end-1) ; start-2
187            (,target-i ,start-1))
188        (declare (fixnum ,i ,j ,target-i))
189        (loop
190         (cond ((= ,i ,end-1)
191                (loop (if (= ,j ,end-2) (return))
192                      (setf (,target-ref ,target ,target-i)
193                            (,source-ref ,source ,j))
194                      (incf ,target-i)
195                      (incf ,j))
196                (return))
197               ((= ,j ,end-2)
198                (loop (if (= ,i ,end-1) (return))
199                      (setf (,target-ref ,target ,target-i)
200                            (,source-ref ,source ,i))
201                      (incf ,target-i)
202                      (incf ,i))
203                (return))
204               ((apply-pred (,source-ref ,source ,j)
205                            (,source-ref ,source ,i)
206                            ,pred ,key)
207                (setf (,target-ref ,target ,target-i)
208                      (,source-ref ,source ,j))
209                (incf ,j))
210               (t (setf (,target-ref ,target ,target-i)
211                        (,source-ref ,source ,i))
212                  (incf ,i)))
213         (incf ,target-i)))))
214
215 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
216 ;;; but it uses a temporary vector. DIRECTION determines whether we
217 ;;; are merging into the temporary (T) or back into the given vector
218 ;;; (NIL).
219 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
220   (let ((vector-len (gensym)) (n (gensym))
221         (direction (gensym))  (unsorted (gensym))
222         (start-1 (gensym))    (end-1 (gensym))
223         (end-2 (gensym))      (temp-len (gensym))
224         (i (gensym)))
225     `(let ((,vector-len (length (the vector ,vector)))
226            (,n 1)        ; bottom-up size of contiguous runs to be merged
227            (,direction t) ; t vector --> temp    nil temp --> vector
228            (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
229            (,unsorted 0)  ; unsorted..vector-len are the elements that need
230                           ; to be merged for a given n
231            (,start-1 0))  ; one n-len subsequence to be merged with the next
232        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
233        (if (> ,vector-len ,temp-len)
234            (setf *merge-sort-temp-vector*
235                  (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
236        (loop
237         ;; for each n, we start taking n-runs from the start of the vector
238         (setf ,unsorted 0)
239         (loop
240          (setf ,start-1 ,unsorted)
241          (let ((,end-1 (+ ,start-1 ,n)))
242            (declare (fixnum ,end-1))
243            (cond ((< ,end-1 ,vector-len)
244                   ;; there are enough elements for a second run
245                   (let ((,end-2 (+ ,end-1 ,n)))
246                     (declare (fixnum ,end-2))
247                     (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
248                     (setf ,unsorted ,end-2)
249                     (if ,direction
250                         (stable-sort-merge-vectors*
251                          ,vector *merge-sort-temp-vector*
252                          ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
253                         (stable-sort-merge-vectors*
254                          *merge-sort-temp-vector* ,vector
255                          ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
256                     (if (= ,unsorted ,vector-len) (return))))
257                  ;; if there is only one run, copy those elements to the end
258                  (t (if ,direction
259                         (do ((,i ,start-1 (1+ ,i)))
260                             ((= ,i ,vector-len))
261                           (declare (fixnum ,i))
262                           (setf (svref *merge-sort-temp-vector* ,i)
263                                 (,vector-ref ,vector ,i)))
264                         (do ((,i ,start-1 (1+ ,i)))
265                             ((= ,i ,vector-len))
266                           (declare (fixnum ,i))
267                           (setf (,vector-ref ,vector ,i)
268                                 (svref *merge-sort-temp-vector* ,i))))
269                     (return)))))
270         ;; If the inner loop only executed once, then there were only enough
271         ;; elements for two subsequences given n, so all the elements have
272         ;; been merged into one list. Start-1 will have remained 0 upon exit.
273         (when (zerop ,start-1)
274           (if ,direction
275               ;; if we just merged into the temporary, copy it all back
276               ;; to the given vector.
277               (dotimes (,i ,vector-len)
278                 (setf (,vector-ref ,vector ,i)
279                       (svref *merge-sort-temp-vector* ,i))))
280           (return ,vector))
281         (setf ,n (ash ,n 1)) ; (* 2 n)
282         (setf ,direction (not ,direction))))))
283
284 ) ; EVAL-when
285
286 ;;; temporary vector for stable sorting vectors
287 (defvar *merge-sort-temp-vector*
288   (make-array 50))
289
290 (declaim (simple-vector *merge-sort-temp-vector*))
291
292 (defun stable-sort-simple-vector (vector pred key)
293   (declare (simple-vector vector))
294   (vector-merge-sort vector pred key svref))
295
296 (defun stable-sort-vector (vector pred key)
297   (vector-merge-sort vector pred key aref))
298
299 ;;;; merging
300
301 (eval-when (:compile-toplevel :execute)
302
303 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
304 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
305 ;;; are chosen only if they are strictly less than elements of
306 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
307 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
308                                result-vector pred key access)
309   (let ((result-i (gensym))
310         (i (gensym))
311         (j (gensym)))
312     `(let* ((,result-i 0)
313             (,i 0)
314             (,j 0))
315        (declare (fixnum ,result-i ,i ,j))
316        (loop
317         (cond ((= ,i ,length-1)
318                (loop (if (= ,j ,length-2) (return))
319                      (setf (,access ,result-vector ,result-i)
320                            (,access ,vector-2 ,j))
321                      (incf ,result-i)
322                      (incf ,j))
323                (return ,result-vector))
324               ((= ,j ,length-2)
325                (loop (if (= ,i ,length-1) (return))
326                      (setf (,access ,result-vector ,result-i)
327                            (,access ,vector-1 ,i))
328                      (incf ,result-i)
329                      (incf ,i))
330                (return ,result-vector))
331               ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
332                            ,pred ,key)
333                (setf (,access ,result-vector ,result-i)
334                      (,access ,vector-2 ,j))
335                (incf ,j))
336               (t (setf (,access ,result-vector ,result-i)
337                        (,access ,vector-1 ,i))
338                  (incf ,i)))
339         (incf ,result-i)))))
340
341 ) ; EVAL-WHEN
342
343 (defun merge (result-type sequence1 sequence2 predicate &key key)
344   #!+sb-doc
345   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
346    sequence of type RESULT-TYPE using PREDICATE to order the elements."
347   (let ((type (specifier-type result-type)))
348     (cond
349       ((csubtypep type (specifier-type 'list))
350        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
351        ;; benefits from the error checking there. Short of
352        ;; reimplementing everything, we can't do the same for the LIST
353        ;; case, so do relevant length checking here:
354        (let ((s1 (coerce sequence1 'list))
355              (s2 (coerce sequence2 'list)))
356          (when (type= type (specifier-type 'list))
357            (return-from merge (values (merge-lists* s1 s2 predicate key))))
358          (when (eq type *empty-type*)
359            (bad-sequence-type-error nil))
360          (when (type= type (specifier-type 'null))
361            (if (and (null s1) (null s2))
362                (return-from merge 'nil)
363                ;; FIXME: This will break on circular lists (as,
364                ;; indeed, will the whole MERGE function).
365                (sequence-type-length-mismatch-error type
366                                                     (+ (length s1)
367                                                        (length s2)))))
368          (if (csubtypep (specifier-type '(cons nil t)) type)
369              (if (and (null s1) (null s2))
370                  (sequence-type-length-mismatch-error type 0)
371                  (values (merge-lists* s1 s2 predicate key)))
372              (sequence-type-too-hairy result-type))))
373       ((csubtypep type (specifier-type 'vector))
374        (let* ((vector-1 (coerce sequence1 'vector))
375               (vector-2 (coerce sequence2 'vector))
376               (length-1 (length vector-1))
377               (length-2 (length vector-2))
378               (result (make-sequence result-type
379                                      (+ length-1 length-2))))
380          (declare (vector vector-1 vector-2)
381                   (fixnum length-1 length-2))
382          (if (and (simple-vector-p result)
383                   (simple-vector-p vector-1)
384                   (simple-vector-p vector-2))
385              (merge-vectors vector-1 length-1 vector-2 length-2
386                             result predicate key svref)
387              (merge-vectors vector-1 length-1 vector-2 length-2
388                             result predicate key aref))))
389       (t (bad-sequence-type-error result-type)))))