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

Last change on this file since 13873 was 13873, checked in by Mark Evenson, 9 years ago

Restore autoload CL:MERGE as part of ANSI sort triage (See #196).

This was mistakenly removed as part of Jorge Tavares' last commit.

As an optimization, we attempt to invoke the original quicksort
implementation if the new one fails while emitting a warning to the
user.

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