source: trunk/j/src/org/armedbear/lisp/sort.lisp @ 9266

Last change on this file since 9266 was 4569, checked in by piso, 18 years ago


File size: 7.3 KB
1;;; sort.lisp
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: sort.lisp,v 1.6 2003-10-29 14:16:47 piso Exp $
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(in-package "COMMON-LISP")
22(export '(sort merge))
24(defun sort (sequence predicate &key key)
25  (if (listp sequence)
26      (sort-list sequence predicate key)
27      (quick-sort sequence 0 (length sequence) predicate key)))
29(defun stable-sort (sequence predicate &key key)
30  (if (listp sequence)
31      (sort-list sequence predicate key)
32      (quick-sort sequence 0 (length sequence) predicate key)))
34;;; From CMUCL.
36;;; Stable Sorting Lists
38;;; APPLY-PRED saves us a function call sometimes.
39(defmacro apply-pred (one two pred key)
40  `(if ,key
41       (funcall ,pred (funcall ,key ,one)
42                (funcall ,key  ,two))
43       (funcall ,pred ,one ,two)))
45;;; MERGE-LISTS*   originally written by Jim Large.
46;;;        modified to return a pointer to the end of the result
47;;;           and to not cons header each time its called.
48;;; It destructively merges list-1 with list-2.  In the resulting
49;;; list, elements of list-2 are guaranteed to come after equal elements
50;;; of list-1.
51(defun merge-lists* (list-1 list-2 pred key
52          &optional (merge-lists-header (list :header)))
53  (do* ((result merge-lists-header)
54  (p result))                         ; P points to last cell of result
55    ((or (null list-1) (null list-2))       ; done when either list used up
56     (if (null list-1)                      ; in which case, append the
57         (rplacd p list-2)                  ;   other list
58         (rplacd p list-1))
59     (do ((drag p lead)
60          (lead (cdr p) (cdr lead)))
61       ((null lead)
62        (values (prog1 (cdr result)         ; return the result sans header
63                       (rplacd result nil)) ; (free memory, be careful)
64                drag))))        ; and return pointer to last element
65    (cond ((apply-pred (car list-2) (car list-1) pred key)
66     (rplacd p list-2)           ; append the lesser list to last cell of
67     (setq p (cdr p))            ;   result.  Note: test must bo done for
68     (pop list-2))               ;   list-2 < list-1 so merge will be
69    (t (rplacd p list-1)         ;   stable for list-1
70       (setq p (cdr p))
71       (pop list-1)))))
73;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
74;;; the list grabbing one element at a time and merging it with the next one
75;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
76;;; in runs of two, merging one run with the next to form quadruples of sorted
77;;; elements.  This continues until n is large enough that the inner loop only
78;;; runs for one iteration; that is, there are only two runs that can be merged,
79;;; the first run starting at the beginning of the list, and the second being
80;;; the remaining elements.
82(defun sort-list (list pred key)
83  (let ((head (cons :header list))  ; head holds on to everything
84  (n 1)                       ; bottom-up size of lists to be merged
85  unsorted        ; unsorted is the remaining list to be
86                                    ;   broken into n size lists and merged
87  list-1          ; list-1 is one length n list to be merged
88  last          ; last points to the last visited cell
89  (merge-lists-header (list :header)))
90    (declare (fixnum n))
91    (loop
92      ;; start collecting runs of n at the first element
93      (setf unsorted (cdr head))
94      ;; tack on the first merge of two n-runs to the head holder
95      (setf last head)
96      (let ((n-1 (1- n)))
97        (declare (fixnum n-1))
98        (loop
99          (setf list-1 unsorted)
100          (let ((temp (nthcdr n-1 list-1))
101                list-2)
102            (cond (temp
103                   ;; there are enough elements for a second run
104                   (setf list-2 (cdr temp))
105                   (setf (cdr temp) nil)
106                   (setf temp (nthcdr n-1 list-2))
107                   (cond (temp
108                          (setf unsorted (cdr temp))
109                          (setf (cdr temp) nil))
110                         ;; the second run goes off the end of the list
111                         (t (setf unsorted nil)))
112                   (multiple-value-bind (merged-head merged-last)
113                     (merge-lists* list-1 list-2 pred key
114                                   merge-lists-header)
115                     (setf (cdr last) merged-head)
116                     (setf last merged-last))
117                   (if (null unsorted) (return)))
118                  ;; if there is only one run, then tack it on to the end
119                  (t (setf (cdr last) list-1)
120                     (return)))))
121        (setf n (+ n n))
122        ;; If the inner loop only executed once, then there were only enough
123        ;; elements for two runs given n, so all the elements have been merged
124        ;; into one list.  This may waste one outer iteration to realize.
125        (if (eq list-1 (cdr head))
126            (return list-1))))))
128;;; From ECL.
129(defun quick-sort (seq start end pred key)
130  (unless key (setq key #'identity))
131  (if (<= end (1+ start))
132      seq
133      (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
134        (block outer-loop
135          (loop (loop (decf k)
136                  (unless (< j k) (return-from outer-loop))
137                  (when (funcall pred (funcall key (elt seq k)) kd)
138                    (return)))
139            (loop (incf j)
140              (unless (< j k) (return-from outer-loop))
141              (unless (funcall pred (funcall key (elt seq j)) kd)
142                (return)))
143            (let ((temp (elt seq j)))
144              (setf (elt seq j) (elt seq k)
145                    (elt seq k) temp))))
146        (setf (elt seq start) (elt seq j)
147              (elt seq j) d)
148        (quick-sort seq start j pred key)
149        (quick-sort seq (1+ j) end pred key))))
151;;; From ECL.
152(defun merge (result-type sequence1 sequence2 predicate
153                          &key key
154                          &aux (l1 (length sequence1)) (l2 (length sequence2)))
155  (unless key (setq key #'identity))
156  (do ((newseq (make-sequence result-type (+ l1 l2)))
157       (j 0 (1+ j))
158       (i1 0)
159       (i2 0))
160    ((and (= i1 l1) (= i2 l2)) newseq)
161    (cond ((and (< i1 l1) (< i2 l2))
162     (cond ((funcall predicate
163         (funcall key (elt sequence1 i1))
164         (funcall key (elt sequence2 i2)))
165      (setf (elt newseq j) (elt sequence1 i1))
166      (incf i1))
167     ((funcall predicate
168         (funcall key (elt sequence2 i2))
169         (funcall key (elt sequence1 i1)))
170      (setf (elt newseq j) (elt sequence2 i2))
171      (incf i2))
172     (t
173      (setf (elt newseq j) (elt sequence1 i1))
174      (incf i1))))
175          ((< i1 l1)
176     (setf (elt newseq j) (elt sequence1 i1))
177     (incf i1))
178    (t
179     (setf (elt newseq j) (elt sequence2 i2))
180     (incf i2)))))
Note: See TracBrowser for help on using the repository browser.