3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
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))
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)
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))))
34 (list (sort-list sequence predicate-function key-function))
36 (with-array-data ((vector (the vector sequence))
38 (end (length sequence)))
39 (sort-vector vector start end predicate-function key-function))
42 (error 'simple-type-error
44 :expected-type 'sequence
45 :format-control "~S is not a sequence."
46 :format-arguments (list sequence))))))
50 (defun stable-sort (sequence predicate &key key)
52 "Destructively sorts sequence. Predicate should return non-Nil if
53 Arg1 is to precede Arg2."
56 (stable-sort-simple-vector sequence predicate key))
58 (sort-list sequence predicate key))
60 (stable-sort-vector sequence predicate key))
62 (error 'simple-type-error
64 :expected-type 'sequence
65 :format-control "~S is not a sequence."
66 :format-arguments (list sequence)))))
68 ;;; stable sort of lists
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.
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
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
94 (declare (fixnum n-1))
96 (setf list-1 unsorted)
97 (let ((temp (nthcdr n-1 list-1))
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))
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)
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))
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)
129 (funcall ,pred (funcall ,key ,one)
131 (funcall ,pred ,one ,two)))
134 (defvar *merge-lists-header* (list :header))
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
142 (defun merge-lists* (list-1 list-2 pred key)
143 (do* ((result *merge-lists-header*)
144 (P result)) ; points to last cell of result
145 ((or (null list-1) (null list-2)) ; done when either list used up
146 (if (null list-1) ; in which case, append the
147 (rplacd p list-2) ; other list
150 (lead (cdr p) (cdr lead)))
152 (values (prog1 (cdr result) ; Return the result sans header
153 (rplacd result nil)) ; (free memory, be careful)
154 drag)))) ; and return pointer to last element.
155 (cond ((apply-pred (car list-2) (car list-1) pred key)
156 (rplacd p list-2) ; Append the lesser list to last cell of
157 (setq p (cdr p)) ; result. Note: test must be done for
158 (pop list-2)) ; LIST-2 < LIST-1 so merge will be
159 (T (rplacd p list-1) ; stable for LIST-1.
163 ;;; stable sort of vectors
165 ;;; Stable sorting vectors is done with the same algorithm used for
166 ;;; lists, using a temporary vector to merge back and forth between it
167 ;;; and the given vector to sort.
169 (eval-when (:compile-toplevel :execute)
171 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
172 ;;; start-1 (inclusive) ... end-1 (exclusive) and
173 ;;; end-1 (inclusive) ... end-2 (exclusive),
174 ;;; and merges them into a target vector starting at index start-1.
176 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
183 (,j ,end-1) ; start-2
184 (,target-i ,start-1))
185 (declare (fixnum ,i ,j ,target-i))
188 (loop (if (= ,j ,end-2) (return))
189 (setf (,target-ref ,target ,target-i)
190 (,source-ref ,source ,j))
195 (loop (if (= ,i ,end-1) (return))
196 (setf (,target-ref ,target ,target-i)
197 (,source-ref ,source ,i))
201 ((apply-pred (,source-ref ,source ,j)
202 (,source-ref ,source ,i)
204 (setf (,target-ref ,target ,target-i)
205 (,source-ref ,source ,j))
207 (t (setf (,target-ref ,target ,target-i)
208 (,source-ref ,source ,i))
212 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
213 ;;; but it uses a temporary vector. DIRECTION determines whether we
214 ;;; are merging into the temporary (T) or back into the given vector
216 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
217 (let ((vector-len (gensym)) (n (gensym))
218 (direction (gensym)) (unsorted (gensym))
219 (start-1 (gensym)) (end-1 (gensym))
220 (end-2 (gensym)) (temp-len (gensym))
222 `(let ((,vector-len (length (the vector ,vector)))
223 (,n 1) ; bottom-up size of contiguous runs to be merged
224 (,direction t) ; t vector --> temp nil temp --> vector
225 (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
226 (,unsorted 0) ; unsorted..vector-len are the elements that need
227 ; to be merged for a given n
228 (,start-1 0)) ; one n-len subsequence to be merged with the next
229 (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
230 (if (> ,vector-len ,temp-len)
231 (setf *merge-sort-temp-vector*
232 (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
234 ;; for each n, we start taking n-runs from the start of the vector
237 (setf ,start-1 ,unsorted)
238 (let ((,end-1 (+ ,start-1 ,n)))
239 (declare (fixnum ,end-1))
240 (cond ((< ,end-1 ,vector-len)
241 ;; there are enough elements for a second run
242 (let ((,end-2 (+ ,end-1 ,n)))
243 (declare (fixnum ,end-2))
244 (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
245 (setf ,unsorted ,end-2)
247 (stable-sort-merge-vectors*
248 ,vector *merge-sort-temp-vector*
249 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
250 (stable-sort-merge-vectors*
251 *merge-sort-temp-vector* ,vector
252 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
253 (if (= ,unsorted ,vector-len) (return))))
254 ;; if there is only one run, copy those elements to the end
256 (do ((,i ,start-1 (1+ ,i)))
258 (declare (fixnum ,i))
259 (setf (svref *merge-sort-temp-vector* ,i)
260 (,vector-ref ,vector ,i)))
261 (do ((,i ,start-1 (1+ ,i)))
263 (declare (fixnum ,i))
264 (setf (,vector-ref ,vector ,i)
265 (svref *merge-sort-temp-vector* ,i))))
267 ;; If the inner loop only executed once, then there were only enough
268 ;; elements for two subsequences given n, so all the elements have
269 ;; been merged into one list. Start-1 will have remained 0 upon exit.
270 (when (zerop ,start-1)
272 ;; if we just merged into the temporary, copy it all back
273 ;; to the given vector.
274 (dotimes (,i ,vector-len)
275 (setf (,vector-ref ,vector ,i)
276 (svref *merge-sort-temp-vector* ,i))))
278 (setf ,n (ash ,n 1)) ; (* 2 n)
279 (setf ,direction (not ,direction))))))
283 ;;; temporary vector for stable sorting vectors
284 (defvar *merge-sort-temp-vector*
287 (declaim (simple-vector *merge-sort-temp-vector*))
289 (defun stable-sort-simple-vector (vector pred key)
290 (declare (simple-vector vector))
291 (vector-merge-sort vector pred key svref))
293 (defun stable-sort-vector (vector pred key)
294 (vector-merge-sort vector pred key aref))
298 (eval-when (:compile-toplevel :execute)
300 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
301 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
302 ;;; are chosen only if they are strictly less than elements of
303 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
304 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
305 result-vector pred key access)
306 (let ((result-i (gensym))
309 `(let* ((,result-i 0)
312 (declare (fixnum ,result-i ,i ,j))
314 (cond ((= ,i ,length-1)
315 (loop (if (= ,j ,length-2) (return))
316 (setf (,access ,result-vector ,result-i)
317 (,access ,vector-2 ,j))
320 (return ,result-vector))
322 (loop (if (= ,i ,length-1) (return))
323 (setf (,access ,result-vector ,result-i)
324 (,access ,vector-1 ,i))
327 (return ,result-vector))
328 ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
330 (setf (,access ,result-vector ,result-i)
331 (,access ,vector-2 ,j))
333 (t (setf (,access ,result-vector ,result-i)
334 (,access ,vector-1 ,i))
340 (defun merge (result-type sequence1 sequence2 predicate &key key)
342 "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
343 sequence of type RESULT-TYPE using PREDICATE to order the elements."
344 (let ((type (specifier-type result-type)))
346 ((csubtypep type (specifier-type 'list))
347 ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
348 ;; benefits from the error checking there. Short of
349 ;; reimplementing everything, we can't do the same for the LIST
350 ;; case, so do relevant length checking here:
351 (let ((s1 (coerce sequence1 'list))
352 (s2 (coerce sequence2 'list)))
353 (when (type= type (specifier-type 'list))
354 (return-from merge (values (merge-lists* s1 s2 predicate key))))
355 (when (eq type *empty-type*)
356 (bad-sequence-type-error nil))
357 (when (type= type (specifier-type 'null))
358 (if (and (null s1) (null s2))
359 (return-from merge 'nil)
360 ;; FIXME: This will break on circular lists (as,
361 ;; indeed, will the whole MERGE function).
362 (sequence-type-length-mismatch-error type
365 (if (csubtypep (specifier-type '(cons nil t)) type)
366 (if (and (null s1) (null s2))
367 (sequence-type-length-mismatch-error type 0)
368 (values (merge-lists* s1 s2 predicate key)))
369 (sequence-type-too-hairy result-type))))
370 ((csubtypep type (specifier-type 'vector))
371 (let* ((vector-1 (coerce sequence1 'vector))
372 (vector-2 (coerce sequence2 'vector))
373 (length-1 (length vector-1))
374 (length-2 (length vector-2))
375 (result (make-sequence result-type
376 (+ length-1 length-2))))
377 (declare (vector vector-1 vector-2)
378 (fixnum length-1 length-2))
379 (if (and (simple-vector-p result)
380 (simple-vector-p vector-1)
381 (simple-vector-p vector-2))
382 (merge-vectors vector-1 length-1 vector-2 length-2
383 result predicate key svref)
384 (merge-vectors vector-1 length-1 vector-2 length-2
385 result predicate key aref))))
386 (t (bad-sequence-type-error result-type)))))