/[cmucl]/src/code/sort.lisp
ViewVC logotype

Contents of /src/code/sort.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Tue Apr 20 17:57:45 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.12: +3 -3 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sort.lisp,v 1.13 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Sort functions for Spice Lisp
13 ;;; these functions are part of the standard spice lisp environment.
14 ;;;
15 ;;; Written by Jim Large
16 ;;; Hacked on and maintained by Skef Wholey
17 ;;; Rewritten by Bill Chiles
18 ;;;
19 ;;; *******************************************************************
20
21 (in-package "LISP")
22 (intl:textdomain "cmucl")
23
24 (export '(sort stable-sort merge))
25
26
27
28 (defun sort (sequence predicate &key key)
29 "Destructively sorts sequence. Predicate should returns non-Nil if
30 Arg1 is to precede Arg2."
31 (typecase sequence
32 (simple-vector
33 (if (> (the fixnum (length (the simple-vector sequence))) 0)
34 (sort-simple-vector sequence predicate key)
35 sequence))
36 (list
37 (sort-list sequence predicate key))
38 (vector
39 (if (> (the fixnum (length sequence)) 0)
40 (sort-vector sequence predicate key)
41 sequence))
42 (t
43 (error 'simple-type-error
44 :datum sequence
45 :expected-type 'sequence
46 :format-control (intl:gettext "~S is not a sequence.")
47 :format-arguments (list sequence)))))
48
49
50
51 ;;; Sorting Vectors
52
53 ;;; Sorting is done with a heap sort.
54
55 (eval-when (compile eval)
56
57 ;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element
58 ;;; through the sons to form a heap at root. Root and max are zero based
59 ;;; coordinates, but the heap algorithm only works on arrays indexed from 1
60 ;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I
61 ;;; and 2*I+1 which does not work for a root at 0. Because of this, boundaries,
62 ;;; roots, and termination are computed using 1..N indexes.
63
64 (defmacro heapify (seq vector-ref root max pred key)
65 (let ((heap-root (gensym)) (heap-max (gensym)) (root-ele (gensym))
66 (root-key (gensym)) (heap-max/2 (gensym)) (heap-l-son (gensym))
67 (one-son (gensym)) (one-son-ele (gensym)) (one-son-key (gensym))
68 (r-son-ele (gensym)) (r-son-key (gensym)) (var-root (gensym)))
69 `(let* ((,var-root ,root) ; necessary to not clobber calling root var.
70 (,heap-root (1+ ,root))
71 (,heap-max (1+ ,max))
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))
76 (loop
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 computation
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 heap again.
94 (if (funcall ,pred ,one-son-key ,root-key) (return))
95 ;; else put greater son at root and make greater son node be the root.
96 (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
97 (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates.
98 (setf ,var-root ,one-son))) ; actual index into vector for root ele.
99 ;; now really put percolated value into heap at the appropriate root node.
100 (setf (,vector-ref ,seq ,var-root) ,root-ele))))
101
102
103 ;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting.
104 (defmacro build-heap (seq type len-1 pred key)
105 (let ((i (gensym)))
106 `(do ((,i (floor ,len-1 2) (1- ,i)))
107 ((minusp ,i) ,seq)
108 (declare (fixnum ,i))
109 (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
110
111 ) ; eval-when
112
113
114 ;;; Make simple-vector and miscellaneous vector sorting functions.
115 (macrolet ((frob-rob (fun-name vector-ref)
116 `(defun ,fun-name (seq pred key)
117 (let ((len-1 (1- (length (the vector seq)))))
118 (declare (fixnum len-1))
119 (build-heap seq ,vector-ref len-1 pred key)
120 (do* ((i len-1 i-1)
121 (i-1 (1- i) (1- i-1)))
122 ((zerop i) seq)
123 (declare (fixnum i i-1))
124 (rotatef (,vector-ref seq 0) (,vector-ref seq i))
125 (heapify seq ,vector-ref 0 i-1 pred key))))))
126
127 (frob-rob sort-vector aref)
128
129 (frob-rob sort-simple-vector svref))
130
131
132
133 ;;;; Stable Sorting
134
135 (defun stable-sort (sequence predicate &key key)
136 "Destructively sorts sequence. Predicate should returns non-Nil if
137 Arg1 is to precede Arg2."
138 (typecase sequence
139 (simple-vector
140 (stable-sort-simple-vector sequence predicate key))
141 (list
142 (sort-list sequence predicate key))
143 (vector
144 (stable-sort-vector sequence predicate key))
145 (t
146 (error 'simple-type-error
147 :datum sequence
148 :expected-type 'sequence
149 :format-control (intl:gettext "~S is not a sequence.")
150 :format-arguments (list sequence)))))
151
152
153 ;;; Stable Sorting Lists
154
155
156 ;;; APPLY-PRED saves us a function call sometimes.
157 (eval-when (compile eval)
158 (defmacro apply-pred (one two pred key)
159 `(if ,key
160 (funcall ,pred (funcall ,key ,one)
161 (funcall ,key ,two))
162 (funcall ,pred ,one ,two)))
163 ) ; eval-when
164
165
166 ;;; MERGE-LISTS* originally written by Jim Large.
167 ;;; modified to return a pointer to the end of the result
168 ;;; and to not cons header each time its called.
169 ;;; It destructively merges list-1 with list-2. In the resulting
170 ;;; list, elements of list-2 are guaranteed to come after equal elements
171 ;;; of list-1.
172 (defun merge-lists* (list-1 list-2 pred key
173 &optional (merge-lists-header (list :header)))
174 (do* ((result merge-lists-header)
175 (P result)) ; P points to last cell of result
176 ((or (null list-1) (null list-2)) ; done when either list used up
177 (if (null list-1) ; in which case, append the
178 (rplacd p list-2) ; other list
179 (rplacd p list-1))
180 (do ((drag p lead)
181 (lead (cdr p) (cdr lead)))
182 ((null lead)
183 (values (prog1 (cdr result) ; return the result sans header
184 (rplacd result nil)) ; (free memory, be careful)
185 drag)))) ; and return pointer to last element
186 (cond ((apply-pred (car list-2) (car list-1) pred key)
187 (rplacd p list-2) ; append the lesser list to last cell of
188 (setq p (cdr p)) ; result. Note: test must bo done for
189 (pop list-2)) ; list-2 < list-1 so merge will be
190 (T (rplacd p list-1) ; stable for list-1
191 (setq p (cdr p))
192 (pop list-1)))))
193
194
195 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
196 ;;; the list grabbing one element at a time and merging it with the next one
197 ;;; form pairs of sorted elements. Then n is doubled, and elements are taken
198 ;;; in runs of two, merging one run with the next to form quadruples of sorted
199 ;;; elements. This continues until n is large enough that the inner loop only
200 ;;; runs for one iteration; that is, there are only two runs that can be merged,
201 ;;; the first run starting at the beginning of the list, and the second being
202 ;;; the remaining elements.
203
204 (defun sort-list (list pred key)
205 (let ((head (cons :header list)) ; head holds on to everything
206 (n 1) ; bottom-up size of lists to be merged
207 unsorted ; unsorted is the remaining list to be
208 ; broken into n size lists and merged
209 list-1 ; list-1 is one length n list to be merged
210 last ; last points to the last visited cell
211 (merge-lists-header (list :header)))
212 (declare (fixnum n))
213 (loop
214 ;; start collecting runs of n at the first element
215 (setf unsorted (cdr head))
216 ;; tack on the first merge of two n-runs to the head holder
217 (setf last head)
218 (let ((n-1 (1- n)))
219 (declare (fixnum n-1))
220 (loop
221 (setf list-1 unsorted)
222 (let ((temp (nthcdr n-1 list-1))
223 list-2)
224 (cond (temp
225 ;; there are enough elements for a second run
226 (setf list-2 (cdr temp))
227 (setf (cdr temp) nil)
228 (setf temp (nthcdr n-1 list-2))
229 (cond (temp
230 (setf unsorted (cdr temp))
231 (setf (cdr temp) nil))
232 ;; the second run goes off the end of the list
233 (t (setf unsorted nil)))
234 (multiple-value-bind (merged-head merged-last)
235 (merge-lists* list-1 list-2 pred key
236 merge-lists-header)
237 (setf (cdr last) merged-head)
238 (setf last merged-last))
239 (if (null unsorted) (return)))
240 ;; if there is only one run, then tack it on to the end
241 (t (setf (cdr last) list-1)
242 (return)))))
243 (setf n (ash n 1)) ; (+ n n)
244 ;; If the inner loop only executed once, then there were only enough
245 ;; elements for two runs given n, so all the elements have been merged
246 ;; into one list. This may waste one outer iteration to realize.
247 (if (eq list-1 (cdr head))
248 (return list-1))))))
249
250
251
252 ;;; Stable Sort Vectors
253
254 ;;; Stable sorting vectors is done with the same algorithm used for lists,
255 ;;; using a temporary vector to merge back and forth between it and the
256 ;;; given vector to sort.
257
258
259 (eval-when (compile eval)
260
261 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
262 ;;; start-1 (inclusive) ... end-1 (exclusive) and
263 ;;; end-1 (inclusive) ... end-2 (exclusive),
264 ;;; and merges them into a target vector starting at index start-1.
265
266 (defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
267 pred key source-ref target-ref)
268 (let ((i (gensym))
269 (j (gensym))
270 (target-i (gensym)))
271 `(let ((,i ,start-1)
272 (,j ,end-1) ; start-2
273 (,target-i ,start-1))
274 (declare (fixnum ,i ,j ,target-i))
275 (loop
276 (cond ((= ,i ,end-1)
277 (loop (if (= ,j ,end-2) (return))
278 (setf (,target-ref ,target ,target-i)
279 (,source-ref ,source ,j))
280 (incf ,target-i)
281 (incf ,j))
282 (return))
283 ((= ,j ,end-2)
284 (loop (if (= ,i ,end-1) (return))
285 (setf (,target-ref ,target ,target-i)
286 (,source-ref ,source ,i))
287 (incf ,target-i)
288 (incf ,i))
289 (return))
290 ((apply-pred (,source-ref ,source ,j)
291 (,source-ref ,source ,i)
292 ,pred ,key)
293 (setf (,target-ref ,target ,target-i)
294 (,source-ref ,source ,j))
295 (incf ,j))
296 (t (setf (,target-ref ,target ,target-i)
297 (,source-ref ,source ,i))
298 (incf ,i)))
299 (incf ,target-i)))))
300
301
302 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
303 ;;; it uses a temporary vector. Direction determines whether we are merging
304 ;;; into the temporary (T) or back into the given vector (NIL).
305
306 (defmacro vector-merge-sort (vector pred key vector-ref)
307 (let ((vector-len (gensym)) (n (gensym))
308 (direction (gensym)) (unsorted (gensym))
309 (start-1 (gensym)) (end-1 (gensym))
310 (end-2 (gensym)) (i (gensym))
311 (temp-vector (gensym)))
312 `(let* ((,vector-len (length (the vector ,vector)))
313 (,n 1) ; bottom-up size of contiguous runs to be merged
314 (,direction t) ; t vector --> temp nil temp --> vector
315 (,temp-vector (make-array ,vector-len))
316 (,unsorted 0) ; unsorted..vector-len are the elements that need
317 ; to be merged for a given n
318 (,start-1 0)) ; one n-len subsequence to be merged with the next
319 (declare (fixnum ,vector-len ,n ,unsorted ,start-1)
320 (type simple-vector ,temp-vector))
321 (loop
322 ;; for each n, we start taking n-runs from the start of the vector
323 (setf ,unsorted 0)
324 (loop
325 (setf ,start-1 ,unsorted)
326 (let ((,end-1 (+ ,start-1 ,n)))
327 (declare (fixnum ,end-1))
328 (cond ((< ,end-1 ,vector-len)
329 ;; there are enough elements for a second run
330 (let ((,end-2 (+ ,end-1 ,n)))
331 (declare (fixnum ,end-2))
332 (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
333 (setf ,unsorted ,end-2)
334 (if ,direction
335 (stable-sort-merge-vectors*
336 ,vector ,temp-vector
337 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
338 (stable-sort-merge-vectors*
339 ,temp-vector ,vector
340 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
341 (if (= ,unsorted ,vector-len) (return))))
342 ;; if there is only one run, copy those elements to the end
343 (t (if ,direction
344 (do ((,i ,start-1 (1+ ,i)))
345 ((= ,i ,vector-len))
346 (declare (fixnum ,i))
347 (setf (svref ,temp-vector ,i)
348 (,vector-ref ,vector ,i)))
349 (do ((,i ,start-1 (1+ ,i)))
350 ((= ,i ,vector-len))
351 (declare (fixnum ,i))
352 (setf (,vector-ref ,vector ,i)
353 (svref ,temp-vector ,i))))
354 (return)))))
355 ;; If the inner loop only executed once, then there were only enough
356 ;; elements for two subsequences given n, so all the elements have
357 ;; been merged into one list. Start-1 will have remained 0 upon exit.
358 (when (zerop ,start-1)
359 (if ,direction
360 ;; if we just merged into the temporary, copy it all back
361 ;; to the given vector.
362 (dotimes (,i ,vector-len)
363 (setf (,vector-ref ,vector ,i)
364 (svref ,temp-vector ,i))))
365 (return ,vector))
366 (setf ,n (ash ,n 1)) ; (* 2 n)
367 (setf ,direction (not ,direction))))))
368
369 ) ; eval-when
370
371
372 (defun stable-sort-simple-vector (vector pred key)
373 (declare (simple-vector vector))
374 (vector-merge-sort vector pred key svref))
375
376 (defun stable-sort-vector (vector pred key)
377 (vector-merge-sort vector pred key aref))
378
379
380
381 ;;;; Merge
382
383 (eval-when (compile eval)
384
385 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
386 ;;; of the elements of vector-1 and vector-2. Elements from vector-2 are
387 ;;; chosen only if they are strictly less than elements of vector-1,
388 ;;; (pred elt-2 elt-1), as specified in the manual.
389
390 (defmacro merge-vectors (vector-1 length-1 vector-2 length-2
391 result-vector pred key access)
392 (let ((result-i (gensym))
393 (i (gensym))
394 (j (gensym)))
395 `(let* ((,result-i 0)
396 (,i 0)
397 (,j 0))
398 (declare (fixnum ,result-i ,i ,j))
399 (loop
400 (cond ((= ,i ,length-1)
401 (loop (if (= ,j ,length-2) (return))
402 (setf (,access ,result-vector ,result-i)
403 (,access ,vector-2 ,j))
404 (incf ,result-i)
405 (incf ,j))
406 (return ,result-vector))
407 ((= ,j ,length-2)
408 (loop (if (= ,i ,length-1) (return))
409 (setf (,access ,result-vector ,result-i)
410 (,access ,vector-1 ,i))
411 (incf ,result-i)
412 (incf ,i))
413 (return ,result-vector))
414 ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
415 ,pred ,key)
416 (setf (,access ,result-vector ,result-i)
417 (,access ,vector-2 ,j))
418 (incf ,j))
419 (t (setf (,access ,result-vector ,result-i)
420 (,access ,vector-1 ,i))
421 (incf ,i)))
422 (incf ,result-i)))))
423
424 ) ; eval-when
425
426 (defun merge (result-type sequence1 sequence2 predicate &key key)
427 "The sequences Sequence1 and Sequence2 are destructively merged into
428 a sequence of type Result-Type using the Predicate to order the elements."
429 (cond ((or (eq result-type 'list)
430 (subtypep result-type 'list))
431 ;; Check the length of result-type and the sequence for
432 ;; consistency
433 (let ((s1 (coerce sequence1 'list))
434 (s2 (coerce sequence2 'list))
435 (type (specifier-type result-type)))
436 (cond ((type= type (specifier-type 'list))
437 (values (merge-lists* s1 s2 predicate key)))
438 ((eq type *empty-type*)
439 (bad-sequence-type-error nil))
440 ((type= type (specifier-type 'null))
441 (if (and (null s1) (null s2))
442 nil
443 (sequence-length-error type
444 (+ (length s1) (length s2)))))
445 ((csubtypep (specifier-type '(cons nil t)) type)
446 (if (and (null s1) (null s2))
447 (sequence-length-error type 0)
448 (values (merge-lists* s1 s2 predicate key))))
449 (t
450 (values (merge-lists* s1 s2 predicate key))))))
451
452 ((subtypep result-type 'vector)
453 (let* ((vector-1 (coerce sequence1 'vector))
454 (vector-2 (coerce sequence2 'vector))
455 (length-1 (length vector-1))
456 (length-2 (length vector-2))
457 (result (make-sequence result-type (+ length-1 length-2))))
458 (declare (vector vector-1 vector-2)
459 (fixnum length-1 length-2))
460 (if (and (simple-vector-p result)
461 (simple-vector-p vector-1)
462 (simple-vector-p vector-2))
463 (merge-vectors vector-1 length-1 vector-2 length-2
464 result predicate key svref)
465 (merge-vectors vector-1 length-1 vector-2 length-2
466 result predicate key aref))))
467 (t
468 (bad-sequence-type-error result-type))))

  ViewVC Help
Powered by ViewVC 1.1.5