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 (defun sort (sequence predicate &key key)
16 "Destructively sorts sequence. Predicate should return non-Nil if
17 Arg1 is to precede Arg2."
20 (if (> (the fixnum (length (the simple-vector sequence))) 0)
21 (sort-simple-vector sequence predicate key)
24 (sort-list sequence predicate key))
26 (if (> (the fixnum (length sequence)) 0)
27 (sort-vector sequence predicate key)
30 (error 'simple-type-error
32 :expected-type 'sequence
33 :format-control "~S is not a sequence."
34 :format-arguments (list sequence)))))
38 ;;; Make simple-vector and miscellaneous vector sorting functions.
39 (macrolet (;; BUILD-HEAP rearranges seq elements into a heap to start heap
41 (build-heap (seq type len-1 pred key)
43 `(do ((,i (floor ,len-1 2) (1- ,i)))
46 (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
47 ;; HEAPIFY, assuming both sons of root are heaps, percolates the
48 ;; root element through the sons to form a heap at root. Root and
49 ;; max are zero based coordinates, but the heap algorithm only works
50 ;; on arrays indexed from 1 through N (not 0 through N-1); This is
51 ;; because a root at I has sons at 2*I and 2*I+1 which does not work
52 ;; for a root at 0. Because of this, boundaries, roots, and
53 ;; termination are computed using 1..N indexes.
54 (heapify (seq vector-ref root max pred key)
55 (let ((heap-root (gensym))
62 (one-son-ele (gensym))
63 (one-son-key (gensym))
67 `(let* ((,var-root ,root) ; (necessary to not clobber calling
69 (,heap-root (1+ ,root))
71 (,root-ele (,vector-ref ,seq ,root))
72 (,root-key (apply-key ,key ,root-ele))
73 (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
74 (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
76 (if (> ,heap-root ,heap-max/2) (return))
77 (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
78 ;; l-son index in seq (0..N-1) is one less than heap
80 (,one-son (1- ,heap-l-son))
81 (,one-son-ele (,vector-ref ,seq ,one-son))
82 (,one-son-key (apply-key ,key ,one-son-ele)))
83 (declare (fixnum ,heap-l-son ,one-son))
84 (if (< ,heap-l-son ,heap-max)
85 ;; There is a right son.
86 (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
87 (,r-son-key (apply-key ,key ,r-son-ele)))
88 ;; Choose the greater of the two sons.
89 (when (funcall ,pred ,one-son-key ,r-son-key)
90 (setf ,one-son ,heap-l-son)
91 (setf ,one-son-ele ,r-son-ele)
92 (setf ,one-son-key ,r-son-key))))
93 ;; If greater son is less than root, then we've formed a
95 (if (funcall ,pred ,one-son-key ,root-key) (return))
96 ;; ..else put greater son at root and make greater son
98 (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
99 (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates)
100 (setf ,var-root ,one-son))) ; actual index into vector for root ele
101 ;; Now really put percolated value into heap at the
102 ;; appropriate root node.
103 (setf (,vector-ref ,seq ,var-root) ,root-ele))))
104 (def-vector-sort-fun (fun-name vector-ref)
105 `(defun ,fun-name (seq pred key)
106 (let ((len-1 (1- (length (the vector seq)))))
107 (declare (fixnum len-1))
108 (build-heap seq ,vector-ref len-1 pred key)
110 (i-1 (1- i) (1- i-1)))
112 (declare (fixnum i i-1))
113 (rotatef (,vector-ref seq 0) (,vector-ref seq i))
114 (heapify seq ,vector-ref 0 i-1 pred key))))))
115 (def-vector-sort-fun sort-vector aref)
116 (def-vector-sort-fun sort-simple-vector svref))
120 (defun stable-sort (sequence predicate &key key)
122 "Destructively sorts sequence. Predicate should return non-Nil if
123 Arg1 is to precede Arg2."
126 (stable-sort-simple-vector sequence predicate key))
128 (sort-list sequence predicate key))
130 (stable-sort-vector sequence predicate key))
132 (error 'simple-type-error
134 :expected-type 'sequence
135 :format-control "~S is not a sequence."
136 :format-arguments (list sequence)))))
138 ;;; stable sort of lists
140 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over the list
141 ;;; grabbing one element at a time and merging it with the next one form pairs
142 ;;; of sorted elements. Then n is doubled, and elements are taken in runs of
143 ;;; two, merging one run with the next to form quadruples of sorted elements.
144 ;;; This continues until n is large enough that the inner loop only runs for
145 ;;; one iteration; that is, there are only two runs that can be merged, the
146 ;;; first run starting at the beginning of the list, and the second being the
147 ;;; remaining elements.
149 (defun sort-list (list pred key)
150 (let ((head (cons :header list)) ; head holds on to everything
151 (n 1) ; bottom-up size of lists to be merged
152 unsorted ; unsorted is the remaining list to be
153 ; broken into n size lists and merged
154 list-1 ; list-1 is one length n list to be merged
155 last) ; last points to the last visited cell
158 ;; start collecting runs of n at the first element
159 (setf unsorted (cdr head))
160 ;; tack on the first merge of two n-runs to the head holder
163 (declare (fixnum n-1))
165 (setf list-1 unsorted)
166 (let ((temp (nthcdr n-1 list-1))
169 ;; there are enough elements for a second run
170 (setf list-2 (cdr temp))
171 (setf (cdr temp) nil)
172 (setf temp (nthcdr n-1 list-2))
174 (setf unsorted (cdr temp))
175 (setf (cdr temp) nil))
176 ;; the second run goes off the end of the list
177 (t (setf unsorted nil)))
178 (multiple-value-bind (merged-head merged-last)
179 (merge-lists* list-1 list-2 pred key)
180 (setf (cdr last) merged-head)
181 (setf last merged-last))
182 (if (null unsorted) (return)))
183 ;; if there is only one run, then tack it on to the end
184 (t (setf (cdr last) list-1)
186 (setf n (ash n 1)) ; (+ n n)
187 ;; If the inner loop only executed once, then there were only enough
188 ;; elements for two runs given n, so all the elements have been merged
189 ;; into one list. This may waste one outer iteration to realize.
190 (if (eq list-1 (cdr head))
193 ;;; APPLY-PRED saves us a function call sometimes.
194 (eval-when (:compile-toplevel :execute)
195 (sb!xc:defmacro apply-pred (one two pred key)
197 (funcall ,pred (funcall ,key ,one)
199 (funcall ,pred ,one ,two)))
202 (defvar *merge-lists-header* (list :header))
204 ;;; MERGE-LISTS* originally written by Jim Large.
205 ;;; modified to return a pointer to the end of the result
206 ;;; and to not cons header each time its called.
207 ;;; It destructively merges list-1 with list-2. In the resulting
208 ;;; list, elements of list-2 are guaranteed to come after equal elements
210 (defun merge-lists* (list-1 list-2 pred key)
211 (do* ((result *merge-lists-header*)
212 (P result)) ; points to last cell of result
213 ((or (null list-1) (null list-2)) ; done when either list used up
214 (if (null list-1) ; in which case, append the
215 (rplacd p list-2) ; other list
218 (lead (cdr p) (cdr lead)))
220 (values (prog1 (cdr result) ; Return the result sans header
221 (rplacd result nil)) ; (free memory, be careful)
222 drag)))) ; and return pointer to last element.
223 (cond ((apply-pred (car list-2) (car list-1) pred key)
224 (rplacd p list-2) ; Append the lesser list to last cell of
225 (setq p (cdr p)) ; result. Note: test must bo done for
226 (pop list-2)) ; LIST-2 < LIST-1 so merge will be
227 (T (rplacd p list-1) ; stable for LIST-1.
231 ;;; stable sort of vectors
233 ;;; Stable sorting vectors is done with the same algorithm used for
234 ;;; lists, using a temporary vector to merge back and forth between it
235 ;;; and the given vector to sort.
237 (eval-when (:compile-toplevel :execute)
239 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
240 ;;; start-1 (inclusive) ... end-1 (exclusive) and
241 ;;; end-1 (inclusive) ... end-2 (exclusive),
242 ;;; and merges them into a target vector starting at index start-1.
244 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
251 (,j ,end-1) ; start-2
252 (,target-i ,start-1))
253 (declare (fixnum ,i ,j ,target-i))
256 (loop (if (= ,j ,end-2) (return))
257 (setf (,target-ref ,target ,target-i)
258 (,source-ref ,source ,j))
263 (loop (if (= ,i ,end-1) (return))
264 (setf (,target-ref ,target ,target-i)
265 (,source-ref ,source ,i))
269 ((apply-pred (,source-ref ,source ,j)
270 (,source-ref ,source ,i)
272 (setf (,target-ref ,target ,target-i)
273 (,source-ref ,source ,j))
275 (t (setf (,target-ref ,target ,target-i)
276 (,source-ref ,source ,i))
280 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
281 ;;; it uses a temporary vector. Direction determines whether we are merging
282 ;;; into the temporary (T) or back into the given vector (NIL).
284 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
285 (let ((vector-len (gensym)) (n (gensym))
286 (direction (gensym)) (unsorted (gensym))
287 (start-1 (gensym)) (end-1 (gensym))
288 (end-2 (gensym)) (temp-len (gensym))
290 `(let ((,vector-len (length (the vector ,vector)))
291 (,n 1) ; bottom-up size of contiguous runs to be merged
292 (,direction t) ; t vector --> temp nil temp --> vector
293 (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
294 (,unsorted 0) ; unsorted..vector-len are the elements that need
295 ; to be merged for a given n
296 (,start-1 0)) ; one n-len subsequence to be merged with the next
297 (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
298 (if (> ,vector-len ,temp-len)
299 (setf *merge-sort-temp-vector*
300 (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
302 ;; for each n, we start taking n-runs from the start of the vector
305 (setf ,start-1 ,unsorted)
306 (let ((,end-1 (+ ,start-1 ,n)))
307 (declare (fixnum ,end-1))
308 (cond ((< ,end-1 ,vector-len)
309 ;; there are enough elements for a second run
310 (let ((,end-2 (+ ,end-1 ,n)))
311 (declare (fixnum ,end-2))
312 (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
313 (setf ,unsorted ,end-2)
315 (stable-sort-merge-vectors*
316 ,vector *merge-sort-temp-vector*
317 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
318 (stable-sort-merge-vectors*
319 *merge-sort-temp-vector* ,vector
320 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
321 (if (= ,unsorted ,vector-len) (return))))
322 ;; if there is only one run, copy those elements to the end
324 (do ((,i ,start-1 (1+ ,i)))
326 (declare (fixnum ,i))
327 (setf (svref *merge-sort-temp-vector* ,i)
328 (,vector-ref ,vector ,i)))
329 (do ((,i ,start-1 (1+ ,i)))
331 (declare (fixnum ,i))
332 (setf (,vector-ref ,vector ,i)
333 (svref *merge-sort-temp-vector* ,i))))
335 ;; If the inner loop only executed once, then there were only enough
336 ;; elements for two subsequences given n, so all the elements have
337 ;; been merged into one list. Start-1 will have remained 0 upon exit.
338 (when (zerop ,start-1)
340 ;; if we just merged into the temporary, copy it all back
341 ;; to the given vector.
342 (dotimes (,i ,vector-len)
343 (setf (,vector-ref ,vector ,i)
344 (svref *merge-sort-temp-vector* ,i))))
346 (setf ,n (ash ,n 1)) ; (* 2 n)
347 (setf ,direction (not ,direction))))))
351 ;;; Temporary vector for stable sorting vectors.
352 (defvar *merge-sort-temp-vector*
355 (declaim (simple-vector *merge-sort-temp-vector*))
357 (defun stable-sort-simple-vector (vector pred key)
358 (declare (simple-vector vector))
359 (vector-merge-sort vector pred key svref))
361 (defun stable-sort-vector (vector pred key)
362 (vector-merge-sort vector pred key aref))
366 (eval-when (:compile-toplevel :execute)
368 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
369 ;;; of the elements of vector-1 and vector-2. Elements from vector-2 are
370 ;;; chosen only if they are strictly less than elements of vector-1,
371 ;;; (pred elt-2 elt-1), as specified in the manual.
373 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
374 result-vector pred key access)
375 (let ((result-i (gensym))
378 `(let* ((,result-i 0)
381 (declare (fixnum ,result-i ,i ,j))
383 (cond ((= ,i ,length-1)
384 (loop (if (= ,j ,length-2) (return))
385 (setf (,access ,result-vector ,result-i)
386 (,access ,vector-2 ,j))
389 (return ,result-vector))
391 (loop (if (= ,i ,length-1) (return))
392 (setf (,access ,result-vector ,result-i)
393 (,access ,vector-1 ,i))
396 (return ,result-vector))
397 ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
399 (setf (,access ,result-vector ,result-i)
400 (,access ,vector-2 ,j))
402 (t (setf (,access ,result-vector ,result-i)
403 (,access ,vector-1 ,i))
409 (defun merge (result-type sequence1 sequence2 predicate &key key)
411 "The sequences Sequence1 and Sequence2 are destructively merged into
412 a sequence of type Result-Type using the Predicate to order the elements."
413 (if (eq result-type 'list)
414 (let ((result (merge-lists* (coerce sequence1 'list)
415 (coerce sequence2 'list)
418 (let* ((vector-1 (coerce sequence1 'vector))
419 (vector-2 (coerce sequence2 'vector))
420 (length-1 (length vector-1))
421 (length-2 (length vector-2))
422 (result (make-sequence-of-type result-type (+ length-1 length-2))))
423 (declare (vector vector-1 vector-2)
424 (fixnum length-1 length-2))
427 (check-type-var result result-type)
428 (if (and (simple-vector-p result)
429 (simple-vector-p vector-1)
430 (simple-vector-p vector-2))
431 (merge-vectors vector-1 length-1 vector-2 length-2
432 result predicate key svref)
433 (merge-vectors vector-1 length-1 vector-2 length-2
434 result predicate key aref)))))