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 sort 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 sorting functions for SIMPLE-VECTOR and miscellaneous other VECTORs.
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,
48 ;; percolates the root element through the sons to form a
49 ;; heap at root. Root and max are zero based coordinates,
50 ;; but the heap algorithm only works on arrays indexed from
51 ;; 1 through N (not 0 through N-1); This is because a root
52 ;; at I has sons at 2*I and 2*I+1 which does not work for a
53 ;; root at 0. Because of this, boundaries, roots, and
54 ;; termination are computed using 1..N indexes.
55 (heapify (seq vector-ref root max pred key)
56 (let ((heap-root (gensym))
63 (one-son-ele (gensym))
64 (one-son-key (gensym))
68 `(let* ((,var-root ,root) ; (necessary to not clobber calling
70 (,heap-root (1+ ,root))
72 (,root-ele (,vector-ref ,seq ,root))
73 (,root-key (apply-key ,key ,root-ele))
74 (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
75 (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
77 (if (> ,heap-root ,heap-max/2) (return))
78 (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
79 ;; l-son index in seq (0..N-1) is one less than heap
81 (,one-son (1- ,heap-l-son))
82 (,one-son-ele (,vector-ref ,seq ,one-son))
83 (,one-son-key (apply-key ,key ,one-son-ele)))
84 (declare (fixnum ,heap-l-son ,one-son))
85 (if (< ,heap-l-son ,heap-max)
86 ;; There is a right son.
87 (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
88 (,r-son-key (apply-key ,key ,r-son-ele)))
89 ;; Choose the greater of the two sons.
90 (when (funcall ,pred ,one-son-key ,r-son-key)
91 (setf ,one-son ,heap-l-son)
92 (setf ,one-son-ele ,r-son-ele)
93 (setf ,one-son-key ,r-son-key))))
94 ;; If greater son is less than root, then we've
95 ;; formed a heap again..
96 (if (funcall ,pred ,one-son-key ,root-key) (return))
97 ;; ..else put greater son at root and make
98 ;; greater son node be the root.
99 (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
100 (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates)
101 (setf ,var-root ,one-son))) ; actual index into vector for root ele
102 ;; Now really put percolated value into heap at the
103 ;; appropriate root node.
104 (setf (,vector-ref ,seq ,var-root) ,root-ele))))
105 (def-vector-sort-fun (fun-name vector-ref)
106 `(defun ,fun-name (seq pred key)
107 (let ((len-1 (1- (length (the vector seq)))))
108 (declare (fixnum len-1))
109 (build-heap seq ,vector-ref len-1 pred key)
111 (i-1 (1- i) (1- i-1)))
113 (declare (fixnum i i-1))
114 (rotatef (,vector-ref seq 0) (,vector-ref seq i))
115 (heapify seq ,vector-ref 0 i-1 pred key))))))
116 (def-vector-sort-fun sort-vector aref)
117 (def-vector-sort-fun sort-simple-vector svref))
121 (defun stable-sort (sequence predicate &key key)
123 "Destructively sorts sequence. Predicate should return non-Nil if
124 Arg1 is to precede Arg2."
127 (stable-sort-simple-vector sequence predicate key))
129 (sort-list sequence predicate key))
131 (stable-sort-vector sequence predicate key))
133 (error 'simple-type-error
135 :expected-type 'sequence
136 :format-control "~S is not a sequence."
137 :format-arguments (list sequence)))))
139 ;;; stable sort of lists
141 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
142 ;;; the list grabbing one element at a time and merging it with the
143 ;;; next one form pairs of sorted elements. Then n is doubled, and
144 ;;; elements are taken in runs of two, merging one run with the next
145 ;;; to form quadruples of sorted elements. This continues until n is
146 ;;; large enough that the inner loop only runs for one iteration; that
147 ;;; is, there are only two runs that can be merged, the first run
148 ;;; starting at the beginning of the list, and the second being the
149 ;;; remaining elements.
151 (defun sort-list (list pred key)
152 (let ((head (cons :header list)) ; head holds on to everything
153 (n 1) ; bottom-up size of lists to be merged
154 unsorted ; unsorted is the remaining list to be
155 ; broken into n size lists and merged
156 list-1 ; list-1 is one length n list to be merged
157 last) ; last points to the last visited cell
160 ;; start collecting runs of n at the first element
161 (setf unsorted (cdr head))
162 ;; tack on the first merge of two n-runs to the head holder
165 (declare (fixnum n-1))
167 (setf list-1 unsorted)
168 (let ((temp (nthcdr n-1 list-1))
171 ;; there are enough elements for a second run
172 (setf list-2 (cdr temp))
173 (setf (cdr temp) nil)
174 (setf temp (nthcdr n-1 list-2))
176 (setf unsorted (cdr temp))
177 (setf (cdr temp) nil))
178 ;; the second run goes off the end of the list
179 (t (setf unsorted nil)))
180 (multiple-value-bind (merged-head merged-last)
181 (merge-lists* list-1 list-2 pred key)
182 (setf (cdr last) merged-head)
183 (setf last merged-last))
184 (if (null unsorted) (return)))
185 ;; if there is only one run, then tack it on to the end
186 (t (setf (cdr last) list-1)
188 (setf n (ash n 1)) ; (+ n n)
189 ;; If the inner loop only executed once, then there were only
190 ;; enough elements for two runs given n, so all the elements
191 ;; have been merged into one list. This may waste one outer
192 ;; 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)))))