source: trunk/abcl/src/org/armedbear/lisp/sort.lisp @ 13852

Last change on this file since 13852 was 13852, checked in by Mark Evenson, 10 years ago

CL:SORT implementation replace non-optimal quicksort with public version.

With these changes, SORT seems to be a little faster (for vectors)
although I was not worried with optimizations. In ABCL 1.0.1, in my
machine, sorting 1000000 random integers takes around 10s on average
while now it takes 2s. However, I must point out I didn't do any
serious and proper benchmarking, just some runs.

I will be happy to answer any questions if necessary.

Jorge Tavares

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 11.8 KB
1;;; sort.lisp
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: sort.lisp 13852 2012-02-04 19:08:03Z mevenson $
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.
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; GNU General Public License for more details.
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.
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.
32(in-package #:system)
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)))
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)))
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)))))
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)))))))))))
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)))))))))
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.
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))))))
186<> dc:author "Jorge Tavares" ;
187    dc:description
189The quicksort function picks the pivot by selecting a midpoint and
190also sorts the smaller partition first. These are enough to avoid the
191stack overflow problem as reported. I've performed some tests and it
192looks it is correct
193"""" .
197;;; - the pivot is a middle point
198;;; - sorts the smaller partition first
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))
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))))
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)))))
Note: See TracBrowser for help on using the repository browser.