source: branches/streams/abcl/src/org/armedbear/lisp/sort.lisp

Last change on this file was 14587, checked in by Mark Evenson, 11 years ago

Transform (hopefully) all occurances of old common-lisp.net URIs to abcl.org.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 17.8 KB
Line 
1;;; sort.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: sort.lisp 14587 2013-11-10 17:53:11Z 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;;;
37;;; STABLE SORT
38;;;
39
40;;;
41;;; MERGE SORT for vectors (and sequences in general)
42;;;
43;;; - top-down stable merge sort
44;;; - it is defined with 2 macros to allow a single algorithm
45;;;   and multiple sequence types: merge-vectors-body and merge-sort-body
46;;; - merge-vectors-body merges two given sequences
47;;; - merge-sort-body contains the top-down algorithm
48;;; - the body macro is called by the merge-sort-vectors functions,
49;;;   which typecases the type of sequence and expands the apropriate body
50;;; - more types of sequences/vectors can be added
51;;; - the macros generate the merge sort body with or without funcall to key
52;;; - the merge-vectors algorithm is inspired from the CCL base code
53;;;
54
55;;; http://abcl.org/trac/ticket/196
56;;; TODO Restore the optimization for SIMPLE-VECTOR types by
57;;; conditionally using aref/svref instead of always using AREF
58
59(defmacro merge-vectors-body (type ref a start-a end-a b start-b end-b aux start-aux predicate &optional key)
60  (let ((i-a (gensym)) 
61  (i-b (gensym))
62  (i-aux (gensym))
63  (v-a (gensym))
64  (v-b (gensym))
65  (k-a (gensym))
66  (k-b (gensym))
67  (merge-block (gensym))) 
68    `(locally
69   (declare (type fixnum ,start-a ,end-a ,start-b ,end-b ,start-aux)
70      (type ,type ,a ,b)
71      (type simple-vector ,aux)
72      (type function ,predicate ,@(if key `(,key)))
73      (optimize (speed 3) (safety 0)))
74       (block ,merge-block
75    (let ((,i-a ,start-a)
76    (,i-b ,start-b)
77    (,i-aux ,start-aux)
78    ,v-a ,v-b ,k-a ,k-b)
79      (declare (type fixnum ,i-a ,i-b ,i-aux))
80      (cond ((= ,start-a ,end-a)
81       (when (= ,start-b ,end-b)
82         (return-from ,merge-block))
83       (setf ,i-a ,start-b
84       ,end-a ,end-b
85       ,a ,b
86       ,v-a (,ref ,a ,i-a)))
87      ((= ,start-b ,end-b)
88       (setf ,i-a ,start-a
89       ,v-a (,ref ,a ,i-a)))
90      (t
91       (setf ,v-a (,ref ,a ,i-a)
92       ,v-b (,ref ,b ,i-b)
93       ,@(if key 
94             `(,k-a (funcall ,key ,v-a))
95             `(,k-a ,v-a))
96       ,@(if key 
97             `(,k-b (funcall ,key ,v-b))
98             `(,k-b ,v-b)))
99       (loop 
100         (if (funcall ,predicate ,k-b ,k-a)
101       (progn 
102;;         (setf (svref ,aux ,i-aux) ,v-b ;; FIXME Ticket #196
103         (setf (aref ,aux ,i-aux) ,v-b
104         ,i-aux (+ ,i-aux 1)
105         ,i-b (+ ,i-b 1))
106         (when (= ,i-b ,end-b) (return))
107         (setf ,v-b (,ref ,b ,i-b)
108         ,@(if key 
109               `(,k-b (funcall ,key ,v-b))
110               `(,k-b ,v-b))))
111       (progn 
112;;         (setf (svref ,aux ,i-aux) ,v-a ;; FIXME Ticket #196
113         (setf (aref ,aux ,i-aux) ,v-a
114         ,i-aux (+ ,i-aux 1)
115         ,i-a (+ ,i-a 1))
116         (when (= ,i-a ,end-a)
117           (setf ,a ,b 
118           ,i-a ,i-b 
119           ,end-a ,end-b 
120           ,v-a ,v-b)
121           (return))
122         (setf ,v-a (,ref ,a ,i-a)
123         ,@(if key 
124               `(,k-a (funcall ,key ,v-a))
125               `(,k-a ,v-a))))))))
126      (loop
127;;        (setf (svref ,aux ,i-aux) ,v-a ;; FIXME Ticket #196
128        (setf (aref ,aux ,i-aux) ,v-a
129        ,i-a (+ ,i-a 1))
130        (when (= ,i-a ,end-a) (return))
131        (setf ,v-a (,ref ,a ,i-a)
132        ,i-aux (+ ,i-aux 1))))))))
133
134(defmacro merge-sort-body (type ref mpredicate mkey msequence mstart mend)
135  (let ((merge-sort-call (gensym))
136  (maux (gensym))
137  (aux (gensym))
138  (sequence (gensym))
139  (start (gensym))
140  (end (gensym))
141  (predicate (gensym))
142  (key (gensym))
143  (mid (gensym))
144  (direction (gensym)))
145    `(locally
146   (declare (optimize (speed 3) (safety 0)))
147       (labels ((,merge-sort-call (,sequence ,start ,end ,predicate ,key ,aux ,direction)
148      (declare (type function ,predicate ,@(if mkey `(,key)))
149         (type fixnum ,start ,end)
150         (type ,type ,sequence))
151      (let ((,mid (+ ,start (ash (- ,end ,start) -1))))
152        (declare (type fixnum ,mid))
153        (if (<= (- ,mid 1) ,start)
154      (unless ,direction (setf (,ref ,aux ,start) (,ref ,sequence ,start)))
155      (,merge-sort-call ,sequence ,start ,mid ,predicate ,key ,aux (not ,direction)))
156        (if (>= (+ ,mid 1) ,end)
157      (unless ,direction (setf (,ref ,aux ,mid) (,ref ,sequence ,mid)))
158      (,merge-sort-call ,sequence ,mid ,end ,predicate ,key ,aux (not ,direction)))
159        (unless ,direction (psetq ,sequence ,aux ,aux ,sequence))
160        ,(if mkey
161       `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
162                ,mid ,end ,aux ,start ,predicate ,key)
163       `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
164                ,mid ,end ,aux ,start ,predicate)))))
165   (let ((,maux (make-array ,mend)))
166;;     (declare (type simple-vector ,maux))
167     (declare (type vector ,maux))
168     (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil))))))
169
170(defun merge-sort-vectors (sequence predicate key)
171  (let ((end (length sequence)))
172    (typecase sequence
173      (simple-vector 
174       (if key
175     (merge-sort-body simple-vector svref predicate key sequence 0 end)
176     (merge-sort-body simple-vector svref predicate nil sequence 0 end)))
177      (vector 
178       (if key
179     (merge-sort-body vector aref predicate key sequence 0 end)
180     (merge-sort-body vector aref predicate nil sequence 0 end))))
181    sequence))
182
183
184;;;
185;;;  MERGE SORT for lists
186;;;
187
188;; Adapted from SBCL.
189(declaim (ftype (function (list) cons) last-cons-of))
190(defun last-cons-of (list)
191  (loop
192    (let ((rest (rest list)))
193      (if rest
194          (setf list rest)
195          (return list)))))
196
197;; Adapted from OpenMCL.
198(defun merge-lists (list1 list2 pred key)
199  (declare (optimize (speed 3) (safety 0)))
200  (if (null key)
201      (merge-lists-no-key list1 list2 pred)
202      (cond ((null list1)
203             (values list2 (last-cons-of list2)))
204            ((null list2)
205             (values list1 (last-cons-of list1)))
206            (t
207             (let* ((result (cons nil nil))
208                    (p result)               ; p points to last cell of result
209                    (key1 (funcall key (car list1)))
210                    (key2 (funcall key (car list2))))
211               (declare (type list p))
212               (loop
213                 (cond ((funcall pred key2 key1)
214                        (rplacd p list2)     ; append the lesser list to last cell of
215                        (setf p (cdr p))     ;   result.  Note: test must bo done for
216                        (pop list2)          ;   list2 < list1 so merge will be
217                        (unless list2        ;   stable for list1
218                          (rplacd p list1)
219                          (return (values (cdr result) (last-cons-of p))))
220                        (setf key2 (funcall key (car list2))))
221                       (t
222                        (rplacd p list1)
223                        (setf p (cdr p))
224                        (pop list1)
225                        (unless list1
226                          (rplacd p list2)
227                          (return (values (cdr result) (last-cons-of p))))
228                        (setf key1 (funcall key (car list1)))))))))))
229
230(defun merge-lists-no-key (list1 list2 pred)
231  (declare (optimize (speed 3) (safety 0)))
232  (cond ((null list1)
233         (values list2 (last-cons-of list2)))
234        ((null list2)
235         (values list1 (last-cons-of list1)))
236        (t
237         (let* ((result (cons nil nil))
238                (p result)                   ; p points to last cell of result
239                (key1 (car list1))
240                (key2 (car list2)))
241           (declare (type list p))
242           (loop
243             (cond ((funcall pred key2 key1)
244                    (rplacd p list2)         ; append the lesser list to last cell of
245                    (setf p (cdr p))         ;   result.  Note: test must bo done for
246                    (pop list2)              ;   list2 < list1 so merge will be
247                    (unless list2            ;   stable for list1
248                      (rplacd p list1)
249                      (return (values (cdr result) (last-cons-of p))))
250                    (setf key2 (car list2)))
251                   (t
252                    (rplacd p list1)
253                    (setf p (cdr p))
254                    (pop list1)
255                    (unless list1
256                      (rplacd p list2)
257                      (return (values (cdr result) (last-cons-of p))))
258                    (setf key1 (car list1)))))))))
259
260;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
261;;; the list grabbing one element at a time and merging it with the next one
262;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
263;;; in runs of two, merging one run with the next to form quadruples of sorted
264;;; elements.  This continues until n is large enough that the inner loop only
265;;; runs for one iteration; that is, there are only two runs that can be merged,
266;;; the first run starting at the beginning of the list, and the second being
267;;; the remaining elements.
268
269(defun sort-list (list pred key)
270  (when (or (eq key #'identity) (eq key 'identity))
271    (setf key nil))
272  (let ((head (cons nil list)) ; head holds on to everything
273        (n 1)                  ; bottom-up size of lists to be merged
274        unsorted               ; unsorted is the remaining list to be
275                               ;   broken into n size lists and merged
276        list-1                 ; list-1 is one length n list to be merged
277        last                   ; last points to the last visited cell
278        )
279    (declare (type fixnum n))
280    (loop
281      ;; start collecting runs of n at the first element
282      (setf unsorted (cdr head))
283      ;; tack on the first merge of two n-runs to the head holder
284      (setf last head)
285      (let ((n-1 (1- n)))
286        (declare (type fixnum n-1))
287        (loop
288          (setf list-1 unsorted)
289          (let ((temp (nthcdr n-1 list-1))
290                list-2)
291            (cond (temp
292                   ;; there are enough elements for a second run
293                   (setf list-2 (cdr temp))
294                   (setf (cdr temp) nil)
295                   (setf temp (nthcdr n-1 list-2))
296                   (cond (temp
297                          (setf unsorted (cdr temp))
298                          (setf (cdr temp) nil))
299                         ;; the second run goes off the end of the list
300                         (t (setf unsorted nil)))
301                   (multiple-value-bind (merged-head merged-last)
302                       (merge-lists list-1 list-2 pred key)
303                     (setf (cdr last) merged-head)
304                     (setf last merged-last))
305                   (if (null unsorted) (return)))
306                  ;; if there is only one run, then tack it on to the end
307                  (t (setf (cdr last) list-1)
308                     (return)))))
309        (setf n (+ n n))
310        ;; If the inner loop only executed once, then there were only enough
311        ;; elements for two runs given n, so all the elements have been merged
312        ;; into one list.  This may waste one outer iteration to realize.
313        (if (eq list-1 (cdr head))
314            (return list-1))))))
315;;;
316;;; MERGE
317;;;
318
319;;; From ECL. Should already be user-extensible as it does no type dispatch
320;;; and uses only user-extensible functions.
321(defun merge (result-type sequence1 sequence2 predicate
322                          &key key
323                          &aux (l1 (length sequence1)) (l2 (length sequence2)))
324  (unless key (setq key #'identity))
325  (do ((newseq (make-sequence result-type (+ l1 l2)))
326       (j 0 (1+ j))
327       (i1 0)
328       (i2 0))
329    ((and (= i1 l1) (= i2 l2)) newseq)
330    (cond ((and (< i1 l1) (< i2 l2))
331           (cond ((funcall predicate
332                           (funcall key (elt sequence1 i1))
333                           (funcall key (elt sequence2 i2)))
334                  (setf (elt newseq j) (elt sequence1 i1))
335                  (incf i1))
336                 ((funcall predicate
337                           (funcall key (elt sequence2 i2))
338                           (funcall key (elt sequence1 i1)))
339                  (setf (elt newseq j) (elt sequence2 i2))
340                  (incf i2))
341                 (t
342                  (setf (elt newseq j) (elt sequence1 i1))
343                  (incf i1))))
344          ((< i1 l1)
345           (setf (elt newseq j) (elt sequence1 i1))
346           (incf i1))
347          (t
348           (setf (elt newseq j) (elt sequence2 i2))
349           (incf i2)))))
350
351;;;
352;;; SORT
353;;;
354
355;;;
356;;; QUICKSORT
357;;;
358;;; - algorithm is in the quicksort-body macro, so that it allows
359;;;   the use of different types (e.g., simple-vector, vector)
360;;; - the pivot is picked by selecting middle point
361;;; - sorts the smaller partition first
362;;; - the macro generates the quicksort body with or without funcall to key
363;;;
364
365(defmacro quicksort-body (type ref mpredicate mkey sequence mstart mend)
366  (let ((quicksort-call (gensym))
367  (predicate (gensym))
368  (key (gensym))
369  (vector (gensym))
370  (start (gensym))
371  (end (gensym))
372  (i (gensym))
373  (j (gensym))
374  (p (gensym))
375  (d (gensym))
376  (kd (gensym)))
377    `(locally 
378   (declare (speed 3) (safety 0))
379       (labels ((,quicksort-call (,vector ,start ,end ,predicate ,key)
380       (declare (type function ,predicate ,@(if mkey `(,key)))
381          (type fixnum ,start ,end)
382          (type ,type ,sequence))
383       (if (< ,start ,end)
384           (let* ((,i ,start)
385            (,j (1+ ,end))
386            (,p (the fixnum (+ ,start (ash (- ,end ,start) -1))))
387            (,d (,ref ,vector ,p))
388            ,@(if mkey
389            `((,kd (funcall ,key ,d)))
390            `((,kd ,d))))
391       (rotatef (,ref ,vector ,p) (,ref ,vector ,start))
392       (block outer-loop
393         (loop
394           (loop 
395             (unless (> (decf ,j) ,i) (return-from outer-loop))
396             (when (funcall ,predicate 
397                ,@(if mkey 
398                `((funcall ,key (,ref ,vector ,j)))
399                `((,ref ,vector ,j)))
400                ,kd) (return)))
401           (loop 
402             (unless (< (incf ,i) ,j) (return-from outer-loop))
403             (unless (funcall ,predicate
404            ,@(if mkey 
405                `((funcall ,key (,ref ,vector ,i)))
406                `((,ref ,vector ,i)))
407            ,kd) (return)))
408           (rotatef (,ref ,vector ,i) (,ref ,vector ,j))))
409       (setf (,ref ,vector ,start) (,ref ,vector ,j)
410             (,ref ,vector ,j) ,d)
411       (if (< (- ,j ,start) (- ,end ,j))
412           (progn
413             (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)
414             (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key))
415           (progn
416             (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key)
417             (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)))))))
418   (,quicksort-call ,sequence ,mstart ,mend ,mpredicate ,mkey)))))
419
420(defun quicksort (sequence predicate key)
421  (handler-case 
422      (let ((end (1- (length sequence))))
423        (typecase sequence
424          (simple-vector 
425           (if key
426               (quicksort-body simple-vector svref predicate key sequence 0 end)
427               (quicksort-body simple-vector svref predicate nil sequence 0 end)))
428          (vector 
429           (if key
430               (quicksort-body vector aref predicate key sequence 0 end)
431               (quicksort-body vector aref predicate nil sequence 0 end))))
432        sequence)
433    (t (e) 
434      (warn "~&New quicksort implementation failed with~&'~A'.~&Trying stable implementation...~&" e)
435      (quick-sort sequence 0 (length sequence) predicate key))))
436
437;;; DEPRECATED -- to be removed in abcl-1.4
438;;; From ECL.
439;;; Alternative implementation for quick-sort SORT
440(defun quick-sort (seq start end pred key)
441  (unless key (setq key #'identity))
442  (if (<= end (1+ start))
443      seq
444      (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
445        (block outer-loop
446          (loop (loop (decf k)
447                  (unless (< j k) (return-from outer-loop))
448                  (when (funcall pred (funcall key (elt seq k)) kd)
449                    (return)))
450            (loop (incf j)
451              (unless (< j k) (return-from outer-loop))
452              (unless (funcall pred (funcall key (elt seq j)) kd)
453                (return)))
454            (let ((temp (elt seq j)))
455              (setf (elt seq j) (elt seq k)
456                    (elt seq k) temp))))
457        (setf (elt seq start) (elt seq j)
458              (elt seq j) d)
459        (quick-sort seq start j pred key)
460        (quick-sort seq (1+ j) end pred key))))
461
462;;;
463;;; main SORT and STABLE-SORT function calls
464;;;
465;;; - sort: quicksort and merge sort (only for lists)
466;;; - stable-sort: merge sort (all types)
467;;;
468
469(defun sort (sequence predicate &rest args &key key)
470  (sequence::seq-dispatch sequence
471    (sort-list sequence predicate key)
472    (quicksort sequence predicate key)
473    (apply #'sequence:sort sequence predicate args)))
474
475(defun stable-sort (sequence predicate &rest args &key key)
476  (sequence::seq-dispatch sequence
477    (sort-list sequence predicate key)
478    (merge-sort-vectors sequence predicate key)
479    (apply #'sequence:stable-sort sequence predicate args)))
Note: See TracBrowser for help on using the repository browser.