src/code/sort.lisp

   1 ;;;; SORT and friends
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
  15 ;;; isn't really related to the CMU CL code, since instead of trying
  16 ;;; to generalize the CMU CL code to allow START and END values, this
  17 ;;; code has been written from scratch following Chapter 7 of
  18 ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
  19 (defun sort-vector (vector start end predicate key)
  20   (sort-vector vector start end predicate key))
  21
  22 ;;; This is MAYBE-INLINE because it's not too hard to have an
  23 ;;; application where sorting is a major bottleneck, and inlining it
  24 ;;; allows the compiler to make enough optimizations that it might be
  25 ;;; worth the (large) cost in space.
  26 (declaim (maybe-inline sort))
  27 (defun sort (sequence predicate &key key)
  28   #!+sb-doc
  29   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
  30    ARG1 is to precede ARG2."
  31   (let ((predicate-function (%coerce-callable-to-fun predicate))
  32         (key-function (and key (%coerce-callable-to-fun key))))
  33     (typecase sequence
  34       (list (sort-list sequence predicate-function key-function))
  35       (vector
  36        (with-array-data ((vector (the vector sequence))
  37                          (start 0)
  38                          (end (length sequence)))
  39          (sort-vector vector start end predicate-function key-function))
  40        sequence)
  41       (t
  42        (error 'simple-type-error
  43               :datum sequence
  44               :expected-type 'sequence
  45               :format-control "~S is not a sequence."
  46               :format-arguments (list sequence))))))
  47 \f
  48 ;;;; stable sorting
  49
  50 (defun stable-sort (sequence predicate &key key)
  51   #!+sb-doc
  52   "Destructively sorts sequence. Predicate should return non-Nil if
  53    Arg1 is to precede Arg2."
  54   (typecase sequence
  55     (simple-vector
  56      (stable-sort-simple-vector sequence predicate key))
  57     (list
  58      (sort-list sequence predicate key))
  59     (vector
  60      (stable-sort-vector sequence predicate key))
  61     (t
  62      (error 'simple-type-error
  63             :datum sequence
  64             :expected-type 'sequence
  65             :format-control "~S is not a sequence."
  66             :format-arguments (list sequence)))))
  67
  68 ;;; stable sort of lists
  69
  70 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
  71 ;;; the list grabbing one element at a time and merging it with the
  72 ;;; next one form pairs of sorted elements. Then n is doubled, and
  73 ;;; elements are taken in runs of two, merging one run with the next
  74 ;;; to form quadruples of sorted elements. This continues until n is
  75 ;;; large enough that the inner loop only runs for one iteration; that
  76 ;;; is, there are only two runs that can be merged, the first run
  77 ;;; starting at the beginning of the list, and the second being the
  78 ;;; remaining elements.
  79
  80 (defun sort-list (list pred key)
  81   (let ((head (cons :header list))  ; head holds on to everything
  82         (n 1)                       ; bottom-up size of lists to be merged
  83         unsorted                    ; unsorted is the remaining list to be
  84                                     ;   broken into n size lists and merged
  85         list-1                      ; list-1 is one length n list to be merged
  86         last)                       ; last points to the last visited cell
  87     (declare (fixnum n))
  88     (loop
  89      ;; start collecting runs of n at the first element
  90      (setf unsorted (cdr head))
  91      ;; tack on the first merge of two n-runs to the head holder
  92      (setf last head)
  93      (let ((n-1 (1- n)))
  94        (declare (fixnum n-1))
  95        (loop
  96         (setf list-1 unsorted)
  97         (let ((temp (nthcdr n-1 list-1))
  98               list-2)
  99           (cond (temp
 100                  ;; there are enough elements for a second run
 101                  (setf list-2 (cdr temp))
 102                  (setf (cdr temp) nil)
 103                  (setf temp (nthcdr n-1 list-2))
 104                  (cond (temp
 105                         (setf unsorted (cdr temp))
 106                         (setf (cdr temp) nil))
 107                        ;; the second run goes off the end of the list
 108                        (t (setf unsorted nil)))
 109                  (multiple-value-bind (merged-head merged-last)
 110                      (merge-lists* list-1 list-2 pred key)
 111                    (setf (cdr last) merged-head)
 112                    (setf last merged-last))
 113                  (if (null unsorted) (return)))
 114                 ;; if there is only one run, then tack it on to the end
 115                 (t (setf (cdr last) list-1)
 116                    (return)))))
 117        (setf n (ash n 1)) ; (+ n n)
 118        ;; If the inner loop only executed once, then there were only
 119        ;; enough elements for two runs given n, so all the elements
 120        ;; have been merged into one list. This may waste one outer
 121        ;; iteration to realize.
 122        (if (eq list-1 (cdr head))
 123            (return list-1))))))
 124
 125 ;;; APPLY-PRED saves us a function call sometimes.
 126 (eval-when (:compile-toplevel :execute)
 127   (sb!xc:defmacro apply-pred (one two pred key)
 128     `(if ,key
 129          (funcall ,pred (funcall ,key ,one)
 130                   (funcall ,key  ,two))
 131          (funcall ,pred ,one ,two)))
 132 ) ; EVAL-WHEN
 133
 134 (defvar *merge-lists-header* (list :header))
 135
 136 ;;; MERGE-LISTS*   originally written by Jim Large.
 137 ;;;                modified to return a pointer to the end of the result
 138 ;;;                   and to not cons header each time its called.
 139 ;;; It destructively merges list-1 with list-2. In the resulting
 140 ;;; list, elements of list-2 are guaranteed to come after equal elements
 141 ;;; of list-1.
 142 (defun merge-lists* (list-1 list-2 pred key)
 143   (do* ((result *merge-lists-header*)
 144         (P result))                  ; points to last cell of result
 145        ((or (null list-1) (null list-2)) ; done when either list used up
 146         (if (null list-1)              ; in which case, append the
 147             (rplacd p list-2)      ;   other list
 148             (rplacd p list-1))
 149         (do ((drag p lead)
 150              (lead (cdr p) (cdr lead)))
 151             ((null lead)
 152              (values (prog1 (cdr result) ; Return the result sans header
 153                             (rplacd result nil)) ; (free memory, be careful)
 154                      drag))))      ;   and return pointer to last element.
 155     (cond ((apply-pred (car list-2) (car list-1) pred key)
 156            (rplacd p list-2)       ; Append the lesser list to last cell of
 157            (setq p (cdr p))         ;   result. Note: test must be done for
 158            (pop list-2))               ;   LIST-2 < LIST-1 so merge will be
 159           (T (rplacd p list-1)   ;   stable for LIST-1.
 160              (setq p (cdr p))
 161              (pop list-1)))))
 162
 163 ;;; stable sort of vectors
 164
 165 ;;; Stable sorting vectors is done with the same algorithm used for
 166 ;;; lists, using a temporary vector to merge back and forth between it
 167 ;;; and the given vector to sort.
 168
 169 (eval-when (:compile-toplevel :execute)
 170
 171 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 172 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 173 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 174 ;;; and merges them into a target vector starting at index start-1.
 175
 176 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 177                                                      pred key source-ref
 178                                                      target-ref)
 179   (let ((i (gensym))
 180         (j (gensym))
 181         (target-i (gensym)))
 182     `(let ((,i ,start-1)
 183            (,j ,end-1) ; start-2
 184            (,target-i ,start-1))
 185        (declare (fixnum ,i ,j ,target-i))
 186        (loop
 187         (cond ((= ,i ,end-1)
 188                (loop (if (= ,j ,end-2) (return))
 189                      (setf (,target-ref ,target ,target-i)
 190                            (,source-ref ,source ,j))
 191                      (incf ,target-i)
 192                      (incf ,j))
 193                (return))
 194               ((= ,j ,end-2)
 195                (loop (if (= ,i ,end-1) (return))
 196                      (setf (,target-ref ,target ,target-i)
 197                            (,source-ref ,source ,i))
 198                      (incf ,target-i)
 199                      (incf ,i))
 200                (return))
 201               ((apply-pred (,source-ref ,source ,j)
 202                            (,source-ref ,source ,i)
 203                            ,pred ,key)
 204                (setf (,target-ref ,target ,target-i)
 205                      (,source-ref ,source ,j))
 206                (incf ,j))
 207               (t (setf (,target-ref ,target ,target-i)
 208                        (,source-ref ,source ,i))
 209                  (incf ,i)))
 210         (incf ,target-i)))))
 211
 212 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
 213 ;;; but it uses a temporary vector. DIRECTION determines whether we
 214 ;;; are merging into the temporary (T) or back into the given vector
 215 ;;; (NIL).
 216 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 217   (let ((vector-len (gensym)) (n (gensym))
 218         (direction (gensym))  (unsorted (gensym))
 219         (start-1 (gensym))    (end-1 (gensym))
 220         (end-2 (gensym))      (temp-len (gensym))
 221         (i (gensym)))
 222     `(let ((,vector-len (length (the vector ,vector)))
 223            (,n 1)        ; bottom-up size of contiguous runs to be merged
 224            (,direction t) ; t vector --> temp    nil temp --> vector
 225            (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
 226            (,unsorted 0)  ; unsorted..vector-len are the elements that need
 227                           ; to be merged for a given n
 228            (,start-1 0))  ; one n-len subsequence to be merged with the next
 229        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
 230        (if (> ,vector-len ,temp-len)
 231            (setf *merge-sort-temp-vector*
 232                  (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
 233        (loop
 234         ;; for each n, we start taking n-runs from the start of the vector
 235         (setf ,unsorted 0)
 236         (loop
 237          (setf ,start-1 ,unsorted)
 238          (let ((,end-1 (+ ,start-1 ,n)))
 239            (declare (fixnum ,end-1))
 240            (cond ((< ,end-1 ,vector-len)
 241                   ;; there are enough elements for a second run
 242                   (let ((,end-2 (+ ,end-1 ,n)))
 243                     (declare (fixnum ,end-2))
 244                     (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 245                     (setf ,unsorted ,end-2)
 246                     (if ,direction
 247                         (stable-sort-merge-vectors*
 248                          ,vector *merge-sort-temp-vector*
 249                          ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 250                         (stable-sort-merge-vectors*
 251                          *merge-sort-temp-vector* ,vector
 252                          ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 253                     (if (= ,unsorted ,vector-len) (return))))
 254                  ;; if there is only one run, copy those elements to the end
 255                  (t (if ,direction
 256                         (do ((,i ,start-1 (1+ ,i)))
 257                             ((= ,i ,vector-len))
 258                           (declare (fixnum ,i))
 259                           (setf (svref *merge-sort-temp-vector* ,i)
 260                                 (,vector-ref ,vector ,i)))
 261                         (do ((,i ,start-1 (1+ ,i)))
 262                             ((= ,i ,vector-len))
 263                           (declare (fixnum ,i))
 264                           (setf (,vector-ref ,vector ,i)
 265                                 (svref *merge-sort-temp-vector* ,i))))
 266                     (return)))))
 267         ;; If the inner loop only executed once, then there were only enough
 268         ;; elements for two subsequences given n, so all the elements have
 269         ;; been merged into one list. Start-1 will have remained 0 upon exit.
 270         (when (zerop ,start-1)
 271           (if ,direction
 272               ;; if we just merged into the temporary, copy it all back
 273               ;; to the given vector.
 274               (dotimes (,i ,vector-len)
 275                 (setf (,vector-ref ,vector ,i)
 276                       (svref *merge-sort-temp-vector* ,i))))
 277           (return ,vector))
 278         (setf ,n (ash ,n 1)) ; (* 2 n)
 279         (setf ,direction (not ,direction))))))
 280
 281 ) ; EVAL-when
 282
 283 ;;; temporary vector for stable sorting vectors
 284 (defvar *merge-sort-temp-vector*
 285   (make-array 50))
 286
 287 (declaim (simple-vector *merge-sort-temp-vector*))
 288
 289 (defun stable-sort-simple-vector (vector pred key)
 290   (declare (simple-vector vector))
 291   (vector-merge-sort vector pred key svref))
 292
 293 (defun stable-sort-vector (vector pred key)
 294   (vector-merge-sort vector pred key aref))
 295
 296 ;;;; merging
 297
 298 (eval-when (:compile-toplevel :execute)
 299
 300 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 301 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
 302 ;;; are chosen only if they are strictly less than elements of
 303 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
 304 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 305                                result-vector pred key access)
 306   (let ((result-i (gensym))
 307         (i (gensym))
 308         (j (gensym)))
 309     `(let* ((,result-i 0)
 310             (,i 0)
 311             (,j 0))
 312        (declare (fixnum ,result-i ,i ,j))
 313        (loop
 314         (cond ((= ,i ,length-1)
 315                (loop (if (= ,j ,length-2) (return))
 316                      (setf (,access ,result-vector ,result-i)
 317                            (,access ,vector-2 ,j))
 318                      (incf ,result-i)
 319                      (incf ,j))
 320                (return ,result-vector))
 321               ((= ,j ,length-2)
 322                (loop (if (= ,i ,length-1) (return))
 323                      (setf (,access ,result-vector ,result-i)
 324                            (,access ,vector-1 ,i))
 325                      (incf ,result-i)
 326                      (incf ,i))
 327                (return ,result-vector))
 328               ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
 329                            ,pred ,key)
 330                (setf (,access ,result-vector ,result-i)
 331                      (,access ,vector-2 ,j))
 332                (incf ,j))
 333               (t (setf (,access ,result-vector ,result-i)
 334                        (,access ,vector-1 ,i))
 335                  (incf ,i)))
 336         (incf ,result-i)))))
 337
 338 ) ; EVAL-WHEN
 339
 340 (defun merge (result-type sequence1 sequence2 predicate &key key)
 341   #!+sb-doc
 342   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
 343    sequence of type RESULT-TYPE using PREDICATE to order the elements."
 344   (let ((type (specifier-type result-type)))
 345     (cond
 346       ((csubtypep type (specifier-type 'list))
 347        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
 348        ;; benefits from the error checking there. Short of
 349        ;; reimplementing everything, we can't do the same for the LIST
 350        ;; case, so do relevant length checking here:
 351        (let ((s1 (coerce sequence1 'list))
 352              (s2 (coerce sequence2 'list)))
 353          (when (type= type (specifier-type 'list))
 354            (return-from merge (values (merge-lists* s1 s2 predicate key))))
 355          (when (eq type *empty-type*)
 356            (bad-sequence-type-error nil))
 357          (when (type= type (specifier-type 'null))
 358            (if (and (null s1) (null s2))
 359                (return-from merge 'nil)
 360                ;; FIXME: This will break on circular lists (as,
 361                ;; indeed, will the whole MERGE function).
 362                (sequence-type-length-mismatch-error type
 363                                                     (+ (length s1)
 364                                                        (length s2)))))
 365          (if (csubtypep (specifier-type '(cons nil t)) type)
 366              (if (and (null s1) (null s2))
 367                  (sequence-type-length-mismatch-error type 0)
 368                  (values (merge-lists* s1 s2 predicate key)))
 369              (sequence-type-too-hairy result-type))))
 370       ((csubtypep type (specifier-type 'vector))
 371        (let* ((vector-1 (coerce sequence1 'vector))
 372               (vector-2 (coerce sequence2 'vector))
 373               (length-1 (length vector-1))
 374               (length-2 (length vector-2))
 375               (result (make-sequence result-type
 376                                      (+ length-1 length-2))))
 377          (declare (vector vector-1 vector-2)
 378                   (fixnum length-1 length-2))
 379          (if (and (simple-vector-p result)
 380                   (simple-vector-p vector-1)
 381                   (simple-vector-p vector-2))
 382              (merge-vectors vector-1 length-1 vector-2 length-2
 383                             result predicate key svref)
 384              (merge-vectors vector-1 length-1 vector-2 length-2
 385                             result predicate key aref))))
 386       (t (bad-sequence-type-error result-type)))))