1 | ;;; sort.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: sort.lisp 13852 2012-02-04 19:08:03Z mevenson $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | ;;; |
---|
20 | ;;; As a special exception, the copyright holders of this library give you |
---|
21 | ;;; permission to link this library with independent modules to produce an |
---|
22 | ;;; executable, regardless of the license terms of these independent |
---|
23 | ;;; modules, and to copy and distribute the resulting executable under |
---|
24 | ;;; terms of your choice, provided that you also meet, for each linked |
---|
25 | ;;; independent module, the terms and conditions of the license of that |
---|
26 | ;;; module. An independent module is a module which is not derived from |
---|
27 | ;;; or based on this library. If you modify this library, you may extend |
---|
28 | ;;; this exception to your version of the library, but you are not |
---|
29 | ;;; obligated to do so. If you do not wish to do so, delete this |
---|
30 | ;;; exception statement from your version. |
---|
31 | |
---|
32 | (in-package #:system) |
---|
33 | |
---|
34 | (require "EXTENSIBLE-SEQUENCES-BASE") |
---|
35 | |
---|
36 | (defun sort (sequence predicate &rest args &key key) |
---|
37 | (sequence::seq-dispatch sequence |
---|
38 | (sort-list sequence predicate key) |
---|
39 | (quicksort sequence 0 (1- (length sequence)) predicate (or key #'identity)) |
---|
40 | (apply #'sequence:sort sequence predicate args))) |
---|
41 | |
---|
42 | (defun stable-sort (sequence predicate &rest args &key key) |
---|
43 | (sequence::seq-dispatch sequence |
---|
44 | (sort-list sequence predicate key) |
---|
45 | ;;; Jorge Tavares: |
---|
46 | ;;; As a quick fix, I send in attach a patch that uses in stable-sort merge |
---|
47 | ;;; sort for all sequences. This is done by coercing the sequence to list, |
---|
48 | ;;; calling merge sort and coercing it back to the original sequence type. |
---|
49 | ;;; However, as a long term improvement, the best solution would be to |
---|
50 | ;;; implement a merge sort for non-list sequences. |
---|
51 | (coerce (sort-list (coerce sequence 'list) |
---|
52 | predicate |
---|
53 | key) |
---|
54 | (type-of sequence)) |
---|
55 | (apply #'sequence:stable-sort sequence predicate args))) |
---|
56 | |
---|
57 | ;; Adapted from SBCL. |
---|
58 | (declaim (ftype (function (list) cons) last-cons-of)) |
---|
59 | (defun last-cons-of (list) |
---|
60 | (loop |
---|
61 | (let ((rest (rest list))) |
---|
62 | (if rest |
---|
63 | (setf list rest) |
---|
64 | (return list))))) |
---|
65 | |
---|
66 | ;; Adapted from OpenMCL. |
---|
67 | (defun merge-lists (list1 list2 pred key) |
---|
68 | (declare (optimize (speed 3) (safety 0))) |
---|
69 | (if (null key) |
---|
70 | (merge-lists-no-key list1 list2 pred) |
---|
71 | (cond ((null list1) |
---|
72 | (values list2 (last-cons-of list2))) |
---|
73 | ((null list2) |
---|
74 | (values list1 (last-cons-of list1))) |
---|
75 | (t |
---|
76 | (let* ((result (cons nil nil)) |
---|
77 | (p result) ; p points to last cell of result |
---|
78 | (key1 (funcall key (car list1))) |
---|
79 | (key2 (funcall key (car list2)))) |
---|
80 | (declare (type list p)) |
---|
81 | (loop |
---|
82 | (cond ((funcall pred key2 key1) |
---|
83 | (rplacd p list2) ; append the lesser list to last cell of |
---|
84 | (setf p (cdr p)) ; result. Note: test must bo done for |
---|
85 | (pop list2) ; list2 < list1 so merge will be |
---|
86 | (unless list2 ; stable for list1 |
---|
87 | (rplacd p list1) |
---|
88 | (return (values (cdr result) (last-cons-of p)))) |
---|
89 | (setf key2 (funcall key (car list2)))) |
---|
90 | (t |
---|
91 | (rplacd p list1) |
---|
92 | (setf p (cdr p)) |
---|
93 | (pop list1) |
---|
94 | (unless list1 |
---|
95 | (rplacd p list2) |
---|
96 | (return (values (cdr result) (last-cons-of p)))) |
---|
97 | (setf key1 (funcall key (car list1))))))))))) |
---|
98 | |
---|
99 | (defun merge-lists-no-key (list1 list2 pred) |
---|
100 | (declare (optimize (speed 3) (safety 0))) |
---|
101 | (cond ((null list1) |
---|
102 | (values list2 (last-cons-of list2))) |
---|
103 | ((null list2) |
---|
104 | (values list1 (last-cons-of list1))) |
---|
105 | (t |
---|
106 | (let* ((result (cons nil nil)) |
---|
107 | (p result) ; p points to last cell of result |
---|
108 | (key1 (car list1)) |
---|
109 | (key2 (car list2))) |
---|
110 | (declare (type list p)) |
---|
111 | (loop |
---|
112 | (cond ((funcall pred key2 key1) |
---|
113 | (rplacd p list2) ; append the lesser list to last cell of |
---|
114 | (setf p (cdr p)) ; result. Note: test must bo done for |
---|
115 | (pop list2) ; list2 < list1 so merge will be |
---|
116 | (unless list2 ; stable for list1 |
---|
117 | (rplacd p list1) |
---|
118 | (return (values (cdr result) (last-cons-of p)))) |
---|
119 | (setf key2 (car list2))) |
---|
120 | (t |
---|
121 | (rplacd p list1) |
---|
122 | (setf p (cdr p)) |
---|
123 | (pop list1) |
---|
124 | (unless list1 |
---|
125 | (rplacd p list2) |
---|
126 | (return (values (cdr result) (last-cons-of p)))) |
---|
127 | (setf key1 (car list1))))))))) |
---|
128 | |
---|
129 | ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over |
---|
130 | ;;; the list grabbing one element at a time and merging it with the next one |
---|
131 | ;;; form pairs of sorted elements. Then n is doubled, and elements are taken |
---|
132 | ;;; in runs of two, merging one run with the next to form quadruples of sorted |
---|
133 | ;;; elements. This continues until n is large enough that the inner loop only |
---|
134 | ;;; runs for one iteration; that is, there are only two runs that can be merged, |
---|
135 | ;;; the first run starting at the beginning of the list, and the second being |
---|
136 | ;;; the remaining elements. |
---|
137 | |
---|
138 | (defun sort-list (list pred key) |
---|
139 | (when (or (eq key #'identity) (eq key 'identity)) |
---|
140 | (setf key nil)) |
---|
141 | (let ((head (cons nil list)) ; head holds on to everything |
---|
142 | (n 1) ; bottom-up size of lists to be merged |
---|
143 | unsorted ; unsorted is the remaining list to be |
---|
144 | ; broken into n size lists and merged |
---|
145 | list-1 ; list-1 is one length n list to be merged |
---|
146 | last ; last points to the last visited cell |
---|
147 | ) |
---|
148 | (declare (type fixnum n)) |
---|
149 | (loop |
---|
150 | ;; start collecting runs of n at the first element |
---|
151 | (setf unsorted (cdr head)) |
---|
152 | ;; tack on the first merge of two n-runs to the head holder |
---|
153 | (setf last head) |
---|
154 | (let ((n-1 (1- n))) |
---|
155 | (declare (type fixnum n-1)) |
---|
156 | (loop |
---|
157 | (setf list-1 unsorted) |
---|
158 | (let ((temp (nthcdr n-1 list-1)) |
---|
159 | list-2) |
---|
160 | (cond (temp |
---|
161 | ;; there are enough elements for a second run |
---|
162 | (setf list-2 (cdr temp)) |
---|
163 | (setf (cdr temp) nil) |
---|
164 | (setf temp (nthcdr n-1 list-2)) |
---|
165 | (cond (temp |
---|
166 | (setf unsorted (cdr temp)) |
---|
167 | (setf (cdr temp) nil)) |
---|
168 | ;; the second run goes off the end of the list |
---|
169 | (t (setf unsorted nil))) |
---|
170 | (multiple-value-bind (merged-head merged-last) |
---|
171 | (merge-lists list-1 list-2 pred key) |
---|
172 | (setf (cdr last) merged-head) |
---|
173 | (setf last merged-last)) |
---|
174 | (if (null unsorted) (return))) |
---|
175 | ;; if there is only one run, then tack it on to the end |
---|
176 | (t (setf (cdr last) list-1) |
---|
177 | (return))))) |
---|
178 | (setf n (+ n n)) |
---|
179 | ;; If the inner loop only executed once, then there were only enough |
---|
180 | ;; elements for two runs given n, so all the elements have been merged |
---|
181 | ;; into one list. This may waste one outer iteration to realize. |
---|
182 | (if (eq list-1 (cdr head)) |
---|
183 | (return list-1)))))) |
---|
184 | |
---|
185 | #| |
---|
186 | <> dc:author "Jorge Tavares" ; |
---|
187 | dc:description |
---|
188 | """ |
---|
189 | The quicksort function picks the pivot by selecting a midpoint and |
---|
190 | also sorts the smaller partition first. These are enough to avoid the |
---|
191 | stack overflow problem as reported. I've performed some tests and it |
---|
192 | looks it is correct |
---|
193 | """" . |
---|
194 | |# |
---|
195 | ;;; |
---|
196 | ;;; QUICKSORT |
---|
197 | ;;; - the pivot is a middle point |
---|
198 | ;;; - sorts the smaller partition first |
---|
199 | ;;; |
---|
200 | (defun quicksort (vector start end predicate key) |
---|
201 | (declare (type fixnum start end) |
---|
202 | (type function predicate key)) |
---|
203 | (if (< start end) |
---|
204 | (let* ((i start) |
---|
205 | (j (1+ end)) |
---|
206 | (p (+ start (ash (- end start) -1))) |
---|
207 | (d (aref vector p)) |
---|
208 | (kd (funcall key d))) |
---|
209 | (rotatef (aref vector p) (aref vector start)) |
---|
210 | (block outer-loop |
---|
211 | (loop |
---|
212 | (loop |
---|
213 | (unless (> (decf j) i) (return-from outer-loop)) |
---|
214 | (when (funcall predicate |
---|
215 | (funcall key (aref vector j)) kd) |
---|
216 | (return))) |
---|
217 | (loop |
---|
218 | (unless (< (incf i) j) (return-from outer-loop)) |
---|
219 | (unless (funcall predicate |
---|
220 | (funcall key (aref vector i)) kd) |
---|
221 | (return))) |
---|
222 | (rotatef (aref vector i) (aref vector j)))) |
---|
223 | (setf (aref vector start) (aref vector j) |
---|
224 | (aref vector j) d) |
---|
225 | (if (< (- j start) (- end j)) |
---|
226 | (progn |
---|
227 | (quicksort vector start (1- j) predicate key) |
---|
228 | (quicksort vector (1+ j) end predicate key)) |
---|
229 | (progn |
---|
230 | (quicksort vector (1+ j) end predicate key) |
---|
231 | (quicksort vector start (1- j) predicate key)))) |
---|
232 | vector)) |
---|
233 | |
---|
234 | ;;; DEPRECATED -- to be removed in abcl-1.4 |
---|
235 | ;;; From ECL. |
---|
236 | (defun quick-sort (seq start end pred key) |
---|
237 | (unless key (setq key #'identity)) |
---|
238 | (if (<= end (1+ start)) |
---|
239 | seq |
---|
240 | (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) |
---|
241 | (block outer-loop |
---|
242 | (loop (loop (decf k) |
---|
243 | (unless (< j k) (return-from outer-loop)) |
---|
244 | (when (funcall pred (funcall key (elt seq k)) kd) |
---|
245 | (return))) |
---|
246 | (loop (incf j) |
---|
247 | (unless (< j k) (return-from outer-loop)) |
---|
248 | (unless (funcall pred (funcall key (elt seq j)) kd) |
---|
249 | (return))) |
---|
250 | (let ((temp (elt seq j))) |
---|
251 | (setf (elt seq j) (elt seq k) |
---|
252 | (elt seq k) temp)))) |
---|
253 | (setf (elt seq start) (elt seq j) |
---|
254 | (elt seq j) d) |
---|
255 | (quick-sort seq start j pred key) |
---|
256 | (quick-sort seq (1+ j) end pred key)))) |
---|
257 | |
---|
258 | ;;; From ECL. Should already be user-extensible as it does no type dispatch |
---|
259 | ;;; and uses only user-extensible functions. |
---|
260 | (defun merge (result-type sequence1 sequence2 predicate |
---|
261 | &key key |
---|
262 | &aux (l1 (length sequence1)) (l2 (length sequence2))) |
---|
263 | (unless key (setq key #'identity)) |
---|
264 | (do ((newseq (make-sequence result-type (+ l1 l2))) |
---|
265 | (j 0 (1+ j)) |
---|
266 | (i1 0) |
---|
267 | (i2 0)) |
---|
268 | ((and (= i1 l1) (= i2 l2)) newseq) |
---|
269 | (cond ((and (< i1 l1) (< i2 l2)) |
---|
270 | (cond ((funcall predicate |
---|
271 | (funcall key (elt sequence1 i1)) |
---|
272 | (funcall key (elt sequence2 i2))) |
---|
273 | (setf (elt newseq j) (elt sequence1 i1)) |
---|
274 | (incf i1)) |
---|
275 | ((funcall predicate |
---|
276 | (funcall key (elt sequence2 i2)) |
---|
277 | (funcall key (elt sequence1 i1))) |
---|
278 | (setf (elt newseq j) (elt sequence2 i2)) |
---|
279 | (incf i2)) |
---|
280 | (t |
---|
281 | (setf (elt newseq j) (elt sequence1 i1)) |
---|
282 | (incf i1)))) |
---|
283 | ((< i1 l1) |
---|
284 | (setf (elt newseq j) (elt sequence1 i1)) |
---|
285 | (incf i1)) |
---|
286 | (t |
---|
287 | (setf (elt newseq j) (elt sequence2 i2)) |
---|
288 | (incf i2))))) |
---|