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

Last change on this file since 8177 was 2325, checked in by bryan, 14 years ago

add (in-package "CCL") forms.

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