source: branches/working-0711/ccl/level-1/l1-sort.lisp @ 11832

Last change on this file since 11832 was 2326, checked in by bryan, 14 years ago

add (in-package "CCL") forms.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; Low-level list sorting routines.  Used by CLOS and SORT.
18
19(in-package "CCL")
20
21(eval-when (:compile-toplevel :execute)
22
23(defmacro apply-key (key value)
24  `(if ,key
25     (funcall ,key ,value)
26     ,value))
27
28)
29
30;; A macro to make predicate & key into lfuns, or maybe NIL.
31(defmacro canonicalize-pred-and-key (&optional (pred 'pred) (key 'key))
32  `(progn (setq ,pred (coerce-to-function ,pred))
33          (unless (null ,key)
34            (setq ,key (coerce-to-function ,key))
35            (if (eq ,key #'identity) (setq ,key nil)))))
36
37
38(defun final-cons (p)
39  (do* ((drag p lead)
40        (lead (cdr p) (cdr lead)))
41       ((null lead)
42        drag)))
43
44;;;                modified to return a pointer to the end of the result
45;;;                   and to not cons header each time its called.
46;;; It destructively merges list-1 with list-2.  In the resulting
47;;; list, elements of list-2 are guaranteed to come after equal elements
48;;; of list-1.
49(defun merge-lists* (list-1 list-2 pred key)
50  (declare (optimize (speed 3) (safety 0)))
51  (if (null key)
52    (merge-lists*-no-key list-1 list-2 pred) 
53    (cond ((null list-1)
54           (values list-2 (final-cons list-2)))
55          ((null list-2)
56           (values list-1 (final-cons list-1)))
57          (t (let* ((result (cons nil nil))
58                    (P result)                  ; P points to last cell of result
59                    (key-1 (apply-key key (car list-1)))
60                    (key-2 (apply-key key (car list-2))))
61               (declare (dynamic-extent result))
62               (declare (type list p))
63               (loop
64                 (cond ((funcall pred key-2 key-1)
65                        (rplacd P list-2)       ; append the lesser list to last cell of
66                        (setq P (cdr P))        ;   result.  Note: test must bo done for
67                        (pop list-2)            ;   list-2 < list-1 so merge will be
68                        (unless list-2          ;   stable for list-1
69                          (rplacd P list-1)
70                          (return (values (cdr result) (final-cons p))))
71                        (setq key-2 (apply-key key (car list-2))))
72                       (T (rplacd P list-1)         
73                          (setq P (cdr P))
74                          (pop list-1)
75                          (unless list-1
76                            (rplacd P list-2)
77                            (return (values (cdr result) (final-cons p))))
78                          (setq key-1 (apply-key key (car list-1)))))))))))
79
80(defun merge-lists*-no-key (list-1 list-2 pred)
81  (declare (optimize (speed 3) (safety 0)))
82  (cond ((null list-1)
83         (values list-2 (final-cons list-2)))
84        ((null list-2)
85         (values list-1 (final-cons list-1)))
86        (t (let* ((result (cons nil nil))
87                  (P result)                  ; P points to last cell of result
88                  (key-1 (car list-1))
89                  (key-2 (car list-2)))
90             (declare (dynamic-extent result))
91             (declare (type list p))
92             (loop
93               (cond ((funcall pred key-2 key-1)
94                      (rplacd P list-2)        ; append the lesser list to last cell of
95                      (setq P (cdr P))         ;   result.  Note: test must bo done for
96                      (pop list-2)             ;   list-2 < list-1 so merge will be
97                      (unless list-2           ;   stable for list-1
98                        (rplacd P list-1)
99                        (return (values (cdr result) (final-cons p))))
100                      (setq key-2 (car list-2)))
101                     (T (rplacd P list-1)
102                        (setq P (cdr P))
103                        (pop list-1)
104                        (unless list-1
105                          (rplacd P list-2)
106                          (return (values (cdr result) (final-cons p))))
107                        (setq key-1 (car list-1)))))))))
108
109(defun sort-list (list pred key)
110  (canonicalize-pred-and-key pred key)
111  (let ((head (cons nil list))          ; head holds on to everything
112          (n 1)                                ; bottom-up size of lists to be merged
113          unsorted                             ; unsorted is the remaining list to be
114                                        ;   broken into n size lists and merged
115          list-1                               ; list-1 is one length n list to be merged
116          last)                                ; last points to the last visited cell
117    (declare (fixnum n))
118    (declare (dynamic-extent head))
119    (loop
120      ;; start collecting runs of n at the first element
121      (setf unsorted (cdr head))
122      ;; tack on the first merge of two n-runs to the head holder
123      (setf last head)
124      (let ((n-1 (1- n)))
125        (declare (fixnum n-1))
126        (loop
127            (setf list-1 unsorted)
128            (let ((temp (nthcdr n-1 list-1))
129                  list-2)
130              (cond (temp
131                       ;; there are enough elements for a second run
132                       (setf list-2 (cdr temp))
133                       (setf (cdr temp) nil)
134                       (setf temp (nthcdr n-1 list-2))
135                       (cond (temp
136                                (setf unsorted (cdr temp))
137                                (setf (cdr temp) nil))
138                             ;; the second run goes off the end of the list
139                             (t (setf unsorted nil)))
140                       (multiple-value-bind (merged-head merged-last)
141                                            (merge-lists* list-1 list-2 pred key)
142                         (setf (cdr last) merged-head)
143                         (setf last merged-last))
144                       (if (null unsorted) (return)))
145                      ;; if there is only one run, then tack it on to the end
146                      (t (setf (cdr last) list-1)
147                         (return)))))
148        (setf n (ash n 1)) ; (+ n n)
149        ;; If the inner loop only executed once, then there were only enough
150        ;; elements for two runs given n, so all the elements have been merged
151        ;; into one list.  This may waste one outer iteration to realize.
152        (if (eq list-1 (cdr head))
153            (return list-1))))))
154
155
156;; The no-key version of %sort-list
157;; list had better be a list.
158;; pred had better be functionp.
159(defun %sort-list-no-key (list pred)
160  (sort-list list pred nil))
161
162(defun sort-list-error ()
163  (error "List arg to SORT not a proper list"))
164
165
166
Note: See TracBrowser for help on using the repository browser.