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