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")
17 (defun sort (sequence predicate &key key)
19 "Destructively sorts sequence. Predicate should return non-Nil if
20 Arg1 is to precede Arg2."
23 (if (> (the fixnum (length (the simple-vector sequence))) 0)
24 (sort-simple-vector sequence predicate key)
27 (sort-list sequence predicate key))
29 (if (> (the fixnum (length sequence)) 0)
30 (sort-vector sequence predicate key)
33 (error 'simple-type-error
35 :expected-type 'sequence
36 :format-control "~S is not a sequence."
37 :format-arguments (list sequence)))))
41 ;;; Make simple-vector and miscellaneous vector sorting functions.
42 (macrolet (;; BUILD-HEAP rearranges seq elements into a heap to start heap
44 (build-heap (seq type len-1 pred key)
46 `(do ((,i (floor ,len-1 2) (1- ,i)))
49 (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
50 ;; HEAPIFY, assuming both sons of root are heaps, percolates the
51 ;; root element through the sons to form a heap at root. Root and
52 ;; max are zero based coordinates, but the heap algorithm only works
53 ;; on arrays indexed from 1 through N (not 0 through N-1); This is
54 ;; because a root at I has sons at 2*I and 2*I+1 which does not work
55 ;; for a root at 0. Because of this, boundaries, roots, and
56 ;; termination are computed using 1..N indexes.
57 (heapify (seq vector-ref root max pred key)
58 (let ((heap-root (gensym))
65 (one-son-ele (gensym))
66 (one-son-key (gensym))
70 `(let* ((,var-root ,root) ; (necessary to not clobber calling
72 (,heap-root (1+ ,root))
74 (,root-ele (,vector-ref ,seq ,root))
75 (,root-key (apply-key ,key ,root-ele))
76 (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
77 (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
79 (if (> ,heap-root ,heap-max/2) (return))
80 (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
81 ;; l-son index in seq (0..N-1) is one less than heap
83 (,one-son (1- ,heap-l-son))
84 (,one-son-ele (,vector-ref ,seq ,one-son))
85 (,one-son-key (apply-key ,key ,one-son-ele)))
86 (declare (fixnum ,heap-l-son ,one-son))
87 (if (< ,heap-l-son ,heap-max)
88 ;; There is a right son.
89 (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
90 (,r-son-key (apply-key ,key ,r-son-ele)))
91 ;; Choose the greater of the two sons.
92 (when (funcall ,pred ,one-son-key ,r-son-key)
93 (setf ,one-son ,heap-l-son)
94 (setf ,one-son-ele ,r-son-ele)
95 (setf ,one-son-key ,r-son-key))))
96 ;; If greater son is less than root, then we've formed a
98 (if (funcall ,pred ,one-son-key ,root-key) (return))
99 ;; ..else put greater son at root and make greater son
101 (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
102 (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates)
103 (setf ,var-root ,one-son))) ; actual index into vector for root ele
104 ;; Now really put percolated value into heap at the
105 ;; appropriate root node.
106 (setf (,vector-ref ,seq ,var-root) ,root-ele))))
107 (def-vector-sort-fun (fun-name vector-ref)
108 `(defun ,fun-name (seq pred key)
109 (let ((len-1 (1- (length (the vector seq)))))
110 (declare (fixnum len-1))
111 (build-heap seq ,vector-ref len-1 pred key)
113 (i-1 (1- i) (1- i-1)))
115 (declare (fixnum i i-1))
116 (rotatef (,vector-ref seq 0) (,vector-ref seq i))
117 (heapify seq ,vector-ref 0 i-1 pred key))))))
118 (def-vector-sort-fun sort-vector aref)
119 (def-vector-sort-fun sort-simple-vector svref))
123 (defun stable-sort (sequence predicate &key key)
125 "Destructively sorts sequence. Predicate should return non-Nil if
126 Arg1 is to precede Arg2."
129 (stable-sort-simple-vector sequence predicate key))
131 (sort-list sequence predicate key))
133 (stable-sort-vector sequence predicate key))
135 (error 'simple-type-error
137 :expected-type 'sequence
138 :format-control "~S is not a sequence."
139 :format-arguments (list sequence)))))
141 ;;; stable sort of lists
143 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over the list
144 ;;; grabbing one element at a time and merging it with the next one form pairs
145 ;;; of sorted elements. Then n is doubled, and elements are taken in runs of
146 ;;; two, merging one run with the next to form quadruples of sorted elements.
147 ;;; This continues until n is large enough that the inner loop only runs for
148 ;;; one iteration; that is, there are only two runs that can be merged, the
149 ;;; first run starting at the beginning of the list, and the second being the
150 ;;; remaining elements.
152 (defun sort-list (list pred key)
153 (let ((head (cons :header list)) ; head holds on to everything
154 (n 1) ; bottom-up size of lists to be merged
155 unsorted ; unsorted is the remaining list to be
156 ; broken into n size lists and merged
157 list-1 ; list-1 is one length n list to be merged
158 last) ; last points to the last visited cell
161 ;; start collecting runs of n at the first element
162 (setf unsorted (cdr head))
163 ;; tack on the first merge of two n-runs to the head holder
166 (declare (fixnum n-1))
168 (setf list-1 unsorted)
169 (let ((temp (nthcdr n-1 list-1))
172 ;; there are enough elements for a second run
173 (setf list-2 (cdr temp))
174 (setf (cdr temp) nil)
175 (setf temp (nthcdr n-1 list-2))
177 (setf unsorted (cdr temp))
178 (setf (cdr temp) nil))
179 ;; the second run goes off the end of the list
180 (t (setf unsorted nil)))
181 (multiple-value-bind (merged-head merged-last)
182 (merge-lists* list-1 list-2 pred key)
183 (setf (cdr last) merged-head)
184 (setf last merged-last))
185 (if (null unsorted) (return)))
186 ;; if there is only one run, then tack it on to the end
187 (t (setf (cdr last) list-1)
189 (setf n (ash n 1)) ; (+ n n)
190 ;; If the inner loop only executed once, then there were only enough
191 ;; elements for two runs given n, so all the elements have been merged
192 ;; into one list. This may waste one outer iteration to realize.
193 (if (eq list-1 (cdr head))
196 ;;; APPLY-PRED saves us a function call sometimes.
197 (eval-when (:compile-toplevel :execute)
198 (sb!xc:defmacro apply-pred (one two pred key)
200 (funcall ,pred (funcall ,key ,one)
202 (funcall ,pred ,one ,two)))
205 (defvar *merge-lists-header* (list :header))
207 ;;; MERGE-LISTS* originally written by Jim Large.
208 ;;; modified to return a pointer to the end of the result
209 ;;; and to not cons header each time its called.
210 ;;; It destructively merges list-1 with list-2. In the resulting
211 ;;; list, elements of list-2 are guaranteed to come after equal elements
213 (defun merge-lists* (list-1 list-2 pred key)
214 (do* ((result *merge-lists-header*)
215 (P result)) ; points to last cell of result
216 ((or (null list-1) (null list-2)) ; done when either list used up
217 (if (null list-1) ; in which case, append the
218 (rplacd p list-2) ; other list
221 (lead (cdr p) (cdr lead)))
223 (values (prog1 (cdr result) ; Return the result sans header
224 (rplacd result nil)) ; (free memory, be careful)
225 drag)))) ; and return pointer to last element.
226 (cond ((apply-pred (car list-2) (car list-1) pred key)
227 (rplacd p list-2) ; Append the lesser list to last cell of
228 (setq p (cdr p)) ; result. Note: test must bo done for
229 (pop list-2)) ; LIST-2 < LIST-1 so merge will be
230 (T (rplacd p list-1) ; stable for LIST-1.
234 ;;; stable sort of vectors
236 ;;; Stable sorting vectors is done with the same algorithm used for
237 ;;; lists, using a temporary vector to merge back and forth between it
238 ;;; and the given vector to sort.
240 (eval-when (:compile-toplevel :execute)
242 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
243 ;;; start-1 (inclusive) ... end-1 (exclusive) and
244 ;;; end-1 (inclusive) ... end-2 (exclusive),
245 ;;; and merges them into a target vector starting at index start-1.
247 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
254 (,j ,end-1) ; start-2
255 (,target-i ,start-1))
256 (declare (fixnum ,i ,j ,target-i))
259 (loop (if (= ,j ,end-2) (return))
260 (setf (,target-ref ,target ,target-i)
261 (,source-ref ,source ,j))
266 (loop (if (= ,i ,end-1) (return))
267 (setf (,target-ref ,target ,target-i)
268 (,source-ref ,source ,i))
272 ((apply-pred (,source-ref ,source ,j)
273 (,source-ref ,source ,i)
275 (setf (,target-ref ,target ,target-i)
276 (,source-ref ,source ,j))
278 (t (setf (,target-ref ,target ,target-i)
279 (,source-ref ,source ,i))
283 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
284 ;;; it uses a temporary vector. Direction determines whether we are merging
285 ;;; into the temporary (T) or back into the given vector (NIL).
287 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
288 (let ((vector-len (gensym)) (n (gensym))
289 (direction (gensym)) (unsorted (gensym))
290 (start-1 (gensym)) (end-1 (gensym))
291 (end-2 (gensym)) (temp-len (gensym))
293 `(let ((,vector-len (length (the vector ,vector)))
294 (,n 1) ; bottom-up size of contiguous runs to be merged
295 (,direction t) ; t vector --> temp nil temp --> vector
296 (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
297 (,unsorted 0) ; unsorted..vector-len are the elements that need
298 ; to be merged for a given n
299 (,start-1 0)) ; one n-len subsequence to be merged with the next
300 (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
301 (if (> ,vector-len ,temp-len)
302 (setf *merge-sort-temp-vector*
303 (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
305 ;; for each n, we start taking n-runs from the start of the vector
308 (setf ,start-1 ,unsorted)
309 (let ((,end-1 (+ ,start-1 ,n)))
310 (declare (fixnum ,end-1))
311 (cond ((< ,end-1 ,vector-len)
312 ;; there are enough elements for a second run
313 (let ((,end-2 (+ ,end-1 ,n)))
314 (declare (fixnum ,end-2))
315 (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
316 (setf ,unsorted ,end-2)
318 (stable-sort-merge-vectors*
319 ,vector *merge-sort-temp-vector*
320 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
321 (stable-sort-merge-vectors*
322 *merge-sort-temp-vector* ,vector
323 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
324 (if (= ,unsorted ,vector-len) (return))))
325 ;; if there is only one run, copy those elements to the end
327 (do ((,i ,start-1 (1+ ,i)))
329 (declare (fixnum ,i))
330 (setf (svref *merge-sort-temp-vector* ,i)
331 (,vector-ref ,vector ,i)))
332 (do ((,i ,start-1 (1+ ,i)))
334 (declare (fixnum ,i))
335 (setf (,vector-ref ,vector ,i)
336 (svref *merge-sort-temp-vector* ,i))))
338 ;; If the inner loop only executed once, then there were only enough
339 ;; elements for two subsequences given n, so all the elements have
340 ;; been merged into one list. Start-1 will have remained 0 upon exit.
341 (when (zerop ,start-1)
343 ;; if we just merged into the temporary, copy it all back
344 ;; to the given vector.
345 (dotimes (,i ,vector-len)
346 (setf (,vector-ref ,vector ,i)
347 (svref *merge-sort-temp-vector* ,i))))
349 (setf ,n (ash ,n 1)) ; (* 2 n)
350 (setf ,direction (not ,direction))))))
354 ;;; Temporary vector for stable sorting vectors.
355 (defvar *merge-sort-temp-vector*
358 (declaim (simple-vector *merge-sort-temp-vector*))
360 (defun stable-sort-simple-vector (vector pred key)
361 (declare (simple-vector vector))
362 (vector-merge-sort vector pred key svref))
364 (defun stable-sort-vector (vector pred key)
365 (vector-merge-sort vector pred key aref))
369 (eval-when (:compile-toplevel :execute)
371 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
372 ;;; of the elements of vector-1 and vector-2. Elements from vector-2 are
373 ;;; chosen only if they are strictly less than elements of vector-1,
374 ;;; (pred elt-2 elt-1), as specified in the manual.
376 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
377 result-vector pred key access)
378 (let ((result-i (gensym))
381 `(let* ((,result-i 0)
384 (declare (fixnum ,result-i ,i ,j))
386 (cond ((= ,i ,length-1)
387 (loop (if (= ,j ,length-2) (return))
388 (setf (,access ,result-vector ,result-i)
389 (,access ,vector-2 ,j))
392 (return ,result-vector))
394 (loop (if (= ,i ,length-1) (return))
395 (setf (,access ,result-vector ,result-i)
396 (,access ,vector-1 ,i))
399 (return ,result-vector))
400 ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
402 (setf (,access ,result-vector ,result-i)
403 (,access ,vector-2 ,j))
405 (t (setf (,access ,result-vector ,result-i)
406 (,access ,vector-1 ,i))
412 (defun merge (result-type sequence1 sequence2 predicate &key key)
414 "The sequences Sequence1 and Sequence2 are destructively merged into
415 a sequence of type Result-Type using the Predicate to order the elements."
416 (if (eq result-type 'list)
417 (let ((result (merge-lists* (coerce sequence1 'list)
418 (coerce sequence2 'list)
421 (let* ((vector-1 (coerce sequence1 'vector))
422 (vector-2 (coerce sequence2 'vector))
423 (length-1 (length vector-1))
424 (length-2 (length vector-2))
425 (result (make-sequence-of-type result-type (+ length-1 length-2))))
426 (declare (vector vector-1 vector-2)
427 (fixnum length-1 length-2))
430 (check-type-var result result-type)
431 (if (and (simple-vector-p result)
432 (simple-vector-p vector-1)
433 (simple-vector-p vector-2))
434 (merge-vectors vector-1 length-1 vector-2 length-2
435 result predicate key svref)
436 (merge-vectors vector-1 length-1 vector-2 length-2
437 result predicate key aref)))))