source: trunk/source/lib/sort.lisp @ 14423

Last change on this file since 14423 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;; Sort
19
20;;; sorts a sequence destructively using a predicate which must be a
21;;;  of two arguments which returns non-() only if the first argument is
22;;;  strictly less than the second.  The keyfun (if present) must be a
23;;;  function of one argument.  The predicate is applied to keyfun of the
24;;;  sequence elements, or directly to the elements if the keyfun is not
25;;;  given.
26
27;;; Sort dispatches to type specific sorting routines.
28
29(in-package "CCL")
30
31(defun sort (sequence predicate &key key)
32  "Returns SEQUENCE, which has been modified to be in order.
33   If sequence is a displaced array, sorts just that portion of the
34   data-array which is part of SEQUENCE."
35  (if (< (length sequence) 2)
36    sequence
37    (if (listp sequence)
38      (sort-list sequence predicate key)
39      (quick-sort-vector sequence predicate key))))
40
41(defun stable-sort (sequence predicate &key key)
42  "Returns SEQUENCE, which has been modified to be in order.
43   If sequence is a displaced array, sorts just that portion of the
44   data-array which is part of SEQUENCE."
45  (if (< (length sequence) 2)
46    sequence
47    (if (listp sequence)
48      (sort-list sequence predicate key)
49      (merge-sort-vector sequence predicate key))))
50
51
52;;; Vector sorting.
53;;; The quick-sort is a little slower than the merge-sort, but it doesn't cons.
54;;; The merge-sort is stable.
55;;; Note that there are three version of each:
56;;;   AREF for non-simple (eventually) vectors.
57;;;   %SVREF with a key.
58;;;   %SVREF without a key.
59;;; Other than that, the three versions are duplicates.
60(defun merge-sort-vector (vector pred key)
61  (canonicalize-pred-and-key)
62  (let* ((end (length vector)))
63    (when (> end 1)
64      (multiple-value-bind (real-vector start) 
65                           (array-data-and-offset vector)
66        (incf end start)
67        (unless (fixnump end)
68          (error "Sorry, can't sort vectors larger than ~d." most-positive-fixnum))
69        (let* ((temp-array (make-array (the fixnum end))))
70          (declare (dynamic-extent temp-array))
71          (if (simple-vector-p real-vector)
72            (if key
73              (%merge-sort-simple-vector
74               real-vector start end pred key temp-array nil)
75              (%merge-sort-simple-vector-no-key
76               real-vector start end pred temp-array nil))
77            (%merge-sort-vector real-vector start end pred key temp-array nil))))))
78  vector)
79
80(defun quick-sort-vector (vector pred key)
81  (canonicalize-pred-and-key)
82  (let ((end (length vector)))
83    (when (> end 1)
84      (multiple-value-bind (real-vector start) 
85                           (array-data-and-offset vector)
86        (incf end (%i- start 1))
87; No vector should have a length that's not  a fixnum.
88        '(unless (fixnump end)
89          (error "Sorry, can't sort vectors larger than ~d." most-positive-fixnum))
90        (if (simple-vector-p real-vector)
91          (if key
92            (%quick-sort-simple-vector real-vector start end pred key)
93            (%quick-sort-simple-vector-no-key real-vector start end pred))
94          (%quick-sort-vector
95           real-vector start end pred (or key #'identity))))))
96  vector)
97
98;;; merge-sort internals
99
100(defun %merge-sort-vector (vector start end pred key
101                                  temp-vec res-temp?)
102  ;; If somebody wanted to do it, half of these arefs can be %svrefs,
103  ;; but you'd need two loops in the merge code
104  ;; (temp-vec is simple if res-temp? is false).
105  ;; But who sorts non-svref'able vectors anyway?
106  (let* ((mid (%ilsr 1 (%i+ start end))))
107    (if (%i<= (%i- mid 1) start)
108      (unless res-temp?
109        (setf (aref temp-vec start) (aref vector start)))
110      (%merge-sort-vector
111       vector start mid pred key temp-vec (not res-temp?)))
112    (if (%i>= (%i+ mid 1) end)
113      (unless res-temp?
114        (setf (aref temp-vec mid) (aref vector mid)))
115      (%merge-sort-vector 
116       vector mid end pred key temp-vec (not res-temp?)))
117   
118    (unless res-temp?
119      (psetq vector temp-vec temp-vec vector))
120   
121    (%merge-vectors vector start mid vector mid end temp-vec start pred key)))
122   
123(defun %merge-sort-simple-vector (vector start end pred key
124                                         temp-vec res-temp?)
125  (let* ((mid (%ilsr 1 (%i+ start end))))
126    (if (%i<= (%i- mid 1) start)
127      (unless res-temp?
128        (setf (%svref temp-vec start) (%svref vector start)))
129      (%merge-sort-simple-vector
130       vector start mid pred key temp-vec (not res-temp?)))
131    (if (%i>= (%i+ mid 1) end)
132      (unless res-temp?
133        (setf (%svref temp-vec mid) (%svref vector mid)))
134      (%merge-sort-simple-vector 
135       vector mid end pred key temp-vec (not res-temp?)))
136   
137    (unless res-temp?
138      (psetq vector temp-vec temp-vec vector))
139   
140    (%merge-simple-vectors
141     vector start mid vector mid end temp-vec start pred key)))
142
143(defun %merge-sort-simple-vector-no-key (vector start end pred
144                                                temp-vec res-temp?)
145  (let* ((mid (%ilsr 1 (%i+ start end))))
146    (if (%i<= (%i- mid 1) start)
147      (unless res-temp?
148        (setf (%svref temp-vec start) (%svref vector start)))
149      (%merge-sort-simple-vector-no-key
150       vector start mid pred temp-vec (not res-temp?)))
151    (if (%i>= (%i+ mid 1) end)
152      (unless res-temp?
153        (setf (%svref temp-vec mid) (%svref vector mid)))
154      (%merge-sort-simple-vector-no-key
155       vector mid end pred temp-vec (not res-temp?)))
156   
157    (unless res-temp?
158      (psetq vector temp-vec temp-vec vector))
159   
160    (%merge-simple-vectors-no-key
161     vector start mid vector mid end temp-vec start pred)))
162
163(defun %merge-vectors (a1 start1 end1 a2 start2 end2
164                          out start-out pred key)
165  (let* ((i1 start1)
166         (i2 start2)
167         (i-out start-out)
168         v1 v2 k1 k2)
169    (cond ((eq start1 end1)
170           (when (eq start2 end2)
171             (return-from %merge-vectors out))
172           (setq i1 start2
173                 end1 end2
174                 a1 a2
175                 v1 (aref a1 i1)))
176          ((eq start2 end2)
177           (setq i1 start1
178                 v1 (aref a1 i1)))
179          (t
180           (setq v1 (aref a1 i1)
181                 v2 (aref a2 i2)
182                 k1 (if key (funcall key v1) v1)
183                 k2 (if key (funcall key v2) v2))
184           (loop (if (funcall pred k2 k1)
185                   (progn (setf (aref out i-out) v2
186                                i-out (%i+ i-out 1)
187                                i2 (%i+ i2 1))
188                          (when (eq i2 end2)
189                            (return))
190                          (setq v2 (aref a2 i2)
191                                k2 (if key (funcall key v2) v2)))
192                   (progn (setf (aref out i-out) v1
193                                i-out (%i+ i-out 1)
194                                i1 (%i+ i1 1))
195                          (when (eq i1 end1)
196                            (setq a1 a2 i1 i2 end1 end2 v1 v2)
197                            (return))
198                          (setq v1 (aref a1 i1)
199                                k1 (if key (funcall key v1) v1)))))))
200    (loop
201      (setf (aref out i-out) v1
202            i1 (%i+ i1 1))
203      (if (eq i1 end1) 
204        (return out))
205      (setq v1 (aref a1 i1)
206            i-out (%i+ i-out 1)))))
207
208(defun %merge-simple-vectors (a1 start1 end1 a2 start2 end2
209                                 out start-out pred key)
210  (let* ((i1 start1)
211         (i2 start2)
212         (i-out start-out)
213         v1 v2 k1 k2)
214    (cond ((eq start1 end1)
215           (when (eq start2 end2)
216             (return-from %merge-simple-vectors out))
217           (setq i1 start2
218                 end1 end2
219                 a1 a2
220                 v1 (%svref a1 i1)))
221          ((eq start2 end2)
222           (setq i1 start1
223                 v1 (%svref a1 i1)))
224          (t
225           (setq v1 (%svref a1 i1)
226                 v2 (%svref a2 i2)
227                 k1 (if key (funcall key v1) v1)
228                 k2 (if key (funcall key v2) v2))
229           (loop (if (funcall pred k2 k1)
230                   (progn (setf (%svref out i-out) v2
231                                i-out (%i+ i-out 1)
232                                i2 (%i+ i2 1))
233                          (when (eq i2 end2)
234                            (return))
235                          (setq v2 (%svref a2 i2)
236                                k2 (funcall key v2)))
237                   (progn (setf (%svref out i-out) v1
238                                i-out (%i+ i-out 1)
239                                i1 (%i+ i1 1))
240                          (when (eq i1 end1)
241                            (setq a1 a2 i1 i2 end1 end2 v1 v2)
242                            (return))
243                          (setq v1 (%svref a1 i1)
244                                k1 (funcall key v1)))))))
245    (loop
246      (setf (%svref out i-out) v1
247            i1 (%i+ i1 1))
248      (if (eq i1 end1) 
249        (return out))
250      (setq v1 (%svref a1 i1)
251            i-out (%i+ i-out 1)))))
252
253(defun %merge-simple-vectors-no-key (a1 start1 end1 a2 start2 end2
254                                        out start-out pred)
255  (let* ((i1 start1)
256         (i2 start2)
257         (i-out start-out)
258         v1 v2)
259    (cond ((eq start1 end1)
260           (when (eq start2 end2)
261             (return-from %merge-simple-vectors-no-key out))
262           (setq i1 start2
263                 end1 end2
264                 a1 a2
265                 v1 (%svref a1 i1)))
266          ((eq start2 end2)
267           (setq i1 start1
268                 v1 (%svref a1 i1)))
269          (t
270           (setq v1 (%svref a1 i1)
271                 v2 (%svref a2 i2))
272           (loop (if (funcall pred v2 v1)
273                   (progn (setf (%svref out i-out) v2
274                                i-out (%i+ i-out 1)
275                                i2 (%i+ i2 1))
276                          (when (eq i2 end2)
277                            (return))
278                          (setq v2 (%svref a2 i2)))
279                   (progn (setf (%svref out i-out) v1
280                                i-out (%i+ i-out 1)
281                                i1 (%i+ i1 1))
282                          (when (eq i1 end1)
283                            (setq a1 a2 i1 i2 end1 end2 v1 v2)
284                            (return))
285                          (setq v1 (%svref a1 i1)))))))
286    (loop
287      (setf (%svref out i-out) v1
288            i1 (%i+ i1 1))
289      (if (eq i1 end1) 
290        (return out))
291      (setq v1 (%svref a1 i1)
292            i-out (%i+ i-out 1)))))
293
294
295;;; Quick sort internals
296(defun %quick-sort-vector (vector start end pred key)
297  (declare (optimize (speed 3) (safety 0)))
298  (declare (fixnum start end))
299  (if (< start end)
300    (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1)))))
301           (Ai (aref vector p))
302           (x (funcall key Ai))
303           (pivot Ai)
304           (i start)
305           (j (the fixnum (1+ end)))
306           Aj)
307      (declare (fixnum p i j))
308      (setf (aref vector p) (aref vector start)
309            (aref vector start) Ai)
310      (block partition
311        (loop
312          (loop (unless (> (decf j) i) (return-from partition))
313                (unless (funcall pred
314                                 x
315                                 (funcall key (setq Aj (aref vector j))))
316                  (return)))
317          (loop (unless (< (incf i) j) (return-from partition))
318                (unless (funcall pred
319                                 (funcall key (setq Ai (aref vector i)))
320                                 x)
321                  (return)))
322          (setf (aref vector i) Aj
323                (aref vector j) Ai)))
324      (setf (aref vector start) (aref vector j)
325            (aref vector j) pivot)
326      ; This compare is important.  It limits stack depth to log(end-start)
327      (if (< (the fixnum (- j start)) (the fixnum (- end j)))
328        (progn
329          (%quick-sort-vector vector start (the fixnum (1- j)) pred key)
330          (%quick-sort-vector vector (the fixnum (1+ j)) end pred key))
331        (progn
332          (%quick-sort-vector vector (the fixnum (1+ j)) end pred key)
333          (%quick-sort-vector vector start (the fixnum (1- j)) pred key))))
334    vector))
335
336(defun %quick-sort-simple-vector (vector start end pred key)
337  (declare (optimize (speed 3) (safety 0)))
338  (declare (type simple-vector vector)
339           (fixnum start end))
340  (if (< start end)
341    (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1)))))
342           (Ai (svref vector p))
343           (pivot Ai)
344           (x (funcall key Ai))
345           (i start)
346           (j (the fixnum (1+ end)))
347           Aj)
348      (declare (fixnum p i j))
349      (setf (svref vector p) (svref vector start)
350            (svref vector start) Ai)
351      (block partition
352        (loop
353          (loop (unless (> (decf j) i) (return-from partition))
354                (unless (funcall pred
355                                 x
356                                 (funcall key (setq Aj (svref vector j))))
357                  (return)))
358          (loop (unless (< (incf i) j) (return-from partition))
359                (unless (funcall pred
360                                 (funcall key (setq Ai (svref vector i)))
361                                 x)
362                  (return)))
363          (setf (aref vector i) Aj
364                (aref vector j) Ai)))
365      (setf (svref vector start) (svref vector j)
366            (svref vector j) pivot)
367      (if (< (the fixnum (- j start)) (the fixnum (- end j)))
368        (progn
369          (%quick-sort-simple-vector vector start (the fixnum (1- j)) pred key)
370          (%quick-sort-simple-vector vector (the fixnum (1+ j)) end pred key))
371        (progn
372          (%quick-sort-simple-vector vector (the fixnum (1+ j)) end pred key)
373          (%quick-sort-simple-vector vector start (the fixnum (1- j)) pred key))))
374    vector))
375
376(defun %quick-sort-simple-vector-no-key (vector start end pred)
377  (declare (optimize (speed 3) (safety 0)))
378  (declare (type simple-vector vector)
379           (fixnum start end))
380  (if (< start end)
381    (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1)))))
382           (x (svref vector p))
383           (i start)
384           (j (the fixnum (1+ end)))
385           Ai Aj)
386      (declare (fixnum p i j))
387      (setf (svref vector p) (svref vector start)
388            (svref vector start) x)
389      (block partition
390        (loop
391          (loop (unless (> (decf j) i) (return-from partition))
392                (unless (funcall pred
393                                 x
394                                 (setq Aj (svref vector j)))
395                  (return)))
396          (loop (unless (< (incf i) j) (return-from partition))
397                (unless (funcall pred
398                                 (setq Ai (svref vector i))
399                                 x)
400                  (return)))
401          (setf (aref vector i) Aj
402                (aref vector j) Ai)))
403      (setf (svref vector start) (svref vector j)
404            (svref vector j) x)
405      (if (< (the fixnum (- j start)) (the fixnum (- end j)))
406        (progn
407          (%quick-sort-simple-vector-no-key vector start (the fixnum (1- j)) pred)
408          (%quick-sort-simple-vector-no-key vector (the fixnum (1+ j)) end pred))
409        (progn
410          (%quick-sort-simple-vector-no-key vector (the fixnum (1+ j)) end pred)
411          (%quick-sort-simple-vector-no-key vector start (the fixnum (1- j)) pred))))
412    vector))
413
414
415
416;; This conses like crazy if you merge lists into vectors or vice-versa, but
417;; I don't want to write 6 more merging routines.  Fry's coerce's
418;; will have to stand for now.
419;; Only difficulty here is parsing the result-type for vectors.
420(defun merge (result-type sequence1 sequence2 predicate &key key)
421  "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
422   sequence of type RESULT-TYPE using PREDICATE to order the elements.
423   If result-type specifies an array, the returned array will not be
424   a complex array. Usually, result-type is either LIST, ARRAY or STRING."
425  (let* ((result-len (+ (length sequence1) (length sequence2)))
426         (result-ctype (specifier-type result-type)))
427    (cond ((csubtypep result-ctype (specifier-type 'null))
428           (unless (zerop result-len)
429             (error 'invalid-subtype-error :datum result-type
430                    :expected-type 'cons)))
431          ((csubtypep result-ctype (specifier-type 'list))
432           (canonicalize-pred-and-key predicate key)
433           (values                      ; For the terminally pedantic.
434            (merge-lists* (if (listp sequence1)
435                            sequence1
436                            (coerce sequence1 'list))
437                          (if (listp sequence2)
438                            sequence2
439                            (coerce sequence2 'list))
440                          predicate key)))
441          ((csubtypep result-ctype (specifier-type 'vector))
442           (merge-vectors (if (listp sequence1)
443                            (coerce sequence1 'vector)
444                            sequence1)
445                          (if (listp sequence2)
446                            (coerce sequence2 'vector)
447                            sequence2)
448                          predicate key
449                          result-type))
450          (t (error 'invalid-subtype-error
451                    :datum result-type
452                    :expected-type 'sequence)))))
453
454(defun merge-vectors (vector-1 vector-2 pred key 
455                               &optional (result-type 'vector))
456  "Internal function.  Use MERGE instead."
457  (canonicalize-pred-and-key)
458  (let* ((length-1 (length vector-1))
459         (length-2 (length vector-2))
460         (result-length (+ length-1 length-2))
461         (result (make-merge-vectors-result
462                  result-type result-length vector-1 vector-2))
463         real-vector-1 start-1 real-vector-2 start-2)
464    (multiple-value-setq (real-vector-1 start-1)
465                         (array-data-and-offset vector-1))
466    (multiple-value-setq (real-vector-2 start-2)
467                         (array-data-and-offset vector-2))
468    (incf length-1 start-1)
469    (incf length-2 start-2)
470    (if (and (simple-vector-p real-vector-1) (simple-vector-p real-vector-2)
471             (simple-vector-p result))
472      (if key
473        (%merge-simple-vectors real-vector-1 start-1 length-1
474                               real-vector-2 start-2 length-2
475                               result 0 pred key)
476        (%merge-simple-vectors-no-key real-vector-1 start-1 length-1
477                                      real-vector-2 start-2 length-2
478                                      result 0 pred))
479      (%merge-vectors real-vector-1 start-1 length-1
480                      real-vector-2 start-2 length-2
481                      result 0 pred key))))
482
483;; OK, here goes the type parsing...
484(defun make-merge-vectors-result (result-type result-length vector-1 vector-2)
485  (let* ((ctype (specifier-type result-type)))
486    (let* ((size (array-ctype-length ctype))
487           (elt-type (array-or-union-ctype-element-type ctype)))
488      (if (eq elt-type '*)
489        (let ((et1 (array-element-type vector-1))
490              (et2 (array-element-type vector-2)))
491          (setq elt-type (if (eq et1 et2) et1 `(or ,et1 ,et2)))))
492      (if (and size (not (eq size result-length)))
493        (error 'invalid-subtype-error
494               :datum result-type
495               :expected-type `(vector ,elt-type ,result-length))
496        (make-array (the fixnum (or size result-length))
497                    :element-type elt-type)))))
498       
499
500;; Gee, that wasn't so bad after all.
501;; Well, when you're building on the shoulders of giants,
502;; your little effort can seem great.
503
504
505;; "If I haven't seen as far as others, it's because giants were standing on my shoulders."
Note: See TracBrowser for help on using the repository browser.