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 (defun sort (sequence predicate &key key)
  15   #!+sb-doc
  16   "Destructively sorts sequence. Predicate should return non-Nil if
  17    Arg1 is to precede Arg2."
  18   (typecase sequence
  19     (simple-vector
  20      (if (> (the fixnum (length (the simple-vector sequence))) 0)
  21          (sort-simple-vector sequence predicate key)
  22          sequence))
  23     (list
  24      (sort-list sequence predicate key))
  25     (vector
  26      (if (> (the fixnum (length sequence)) 0)
  27          (sort-vector sequence predicate key)
  28          sequence))
  29     (t
  30      (error 'simple-type-error
  31             :datum sequence
  32             :expected-type 'sequence
  33             :format-control "~S is not a sequence."
  34             :format-arguments (list sequence)))))
  35 \f
  36 ;;;; sorting vectors
  37
  38 ;;; Make simple-vector and miscellaneous vector sorting functions.
  39 (macrolet (;; BUILD-HEAP rearranges seq elements into a heap to start heap
  40            ;; sorting.
  41            (build-heap (seq type len-1 pred key)
  42              (let ((i (gensym)))
  43                `(do ((,i (floor ,len-1 2) (1- ,i)))
  44                     ((minusp ,i) ,seq)
  45                   (declare (fixnum ,i))
  46                   (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
  47            ;; HEAPIFY, assuming both sons of root are heaps, percolates the
  48            ;; root element through the sons to form a heap at root. Root and
  49            ;; max are zero based coordinates, but the heap algorithm only works
  50            ;; on arrays indexed from 1 through N (not 0 through N-1); This is
  51            ;; because a root at I has sons at 2*I and 2*I+1 which does not work
  52            ;; for a root at 0. Because of this, boundaries, roots, and
  53            ;; termination are computed using 1..N indexes.
  54            (heapify (seq vector-ref root max pred key)
  55              (let ((heap-root (gensym))
  56                    (heap-max (gensym))
  57                    (root-ele (gensym))
  58                    (root-key (gensym))
  59                    (heap-max/2 (gensym))
  60                    (heap-l-son (gensym))
  61                    (one-son (gensym))
  62                    (one-son-ele (gensym))
  63                    (one-son-key (gensym))
  64                    (r-son-ele (gensym))
  65                    (r-son-key (gensym))
  66                    (var-root (gensym)))
  67                `(let* ((,var-root ,root) ; (necessary to not clobber calling
  68                                          ; root var)
  69                        (,heap-root (1+ ,root))
  70                        (,heap-max (1+ ,max))
  71                        (,root-ele (,vector-ref ,seq ,root))
  72                        (,root-key (apply-key ,key ,root-ele))
  73                        (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
  74                   (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
  75                   (loop
  76                     (if (> ,heap-root ,heap-max/2) (return))
  77                     (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
  78                            ;; l-son index in seq (0..N-1) is one less than heap
  79                            ;; computation.
  80                            (,one-son (1- ,heap-l-son))
  81                            (,one-son-ele (,vector-ref ,seq ,one-son))
  82                            (,one-son-key (apply-key ,key ,one-son-ele)))
  83                       (declare (fixnum ,heap-l-son ,one-son))
  84                       (if (< ,heap-l-son ,heap-max)
  85                           ;; There is a right son.
  86                           (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
  87                                  (,r-son-key (apply-key ,key ,r-son-ele)))
  88                             ;; Choose the greater of the two sons.
  89                             (when (funcall ,pred ,one-son-key ,r-son-key)
  90                               (setf ,one-son ,heap-l-son)
  91                               (setf ,one-son-ele ,r-son-ele)
  92                               (setf ,one-son-key ,r-son-key))))
  93                       ;; If greater son is less than root, then we've formed a
  94                       ;; heap again..
  95                       (if (funcall ,pred ,one-son-key ,root-key) (return))
  96                       ;; ..else put greater son at root and make greater son
  97                       ;; node be the root.
  98                       (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
  99                       (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates)
 100                       (setf ,var-root ,one-son)))     ; actual index into vector for root ele
 101                   ;; Now really put percolated value into heap at the
 102                   ;; appropriate root node.
 103                   (setf (,vector-ref ,seq ,var-root) ,root-ele))))
 104            (def-vector-sort-fun (fun-name vector-ref)
 105              `(defun ,fun-name (seq pred key)
 106                 (let ((len-1 (1- (length (the vector seq)))))
 107                   (declare (fixnum len-1))
 108                   (build-heap seq ,vector-ref len-1 pred key)
 109                   (do* ((i len-1 i-1)
 110                         (i-1 (1- i) (1- i-1)))
 111                        ((zerop i) seq)
 112                     (declare (fixnum i i-1))
 113                     (rotatef (,vector-ref seq 0) (,vector-ref seq i))
 114                     (heapify seq ,vector-ref 0 i-1 pred key))))))
 115   (def-vector-sort-fun sort-vector aref)
 116   (def-vector-sort-fun sort-simple-vector svref))
 117 \f
 118 ;;;; stable sorting
 119
 120 (defun stable-sort (sequence predicate &key key)
 121   #!+sb-doc
 122   "Destructively sorts sequence. Predicate should return non-Nil if
 123    Arg1 is to precede Arg2."
 124   (typecase sequence
 125     (simple-vector
 126      (stable-sort-simple-vector sequence predicate key))
 127     (list
 128      (sort-list sequence predicate key))
 129     (vector
 130      (stable-sort-vector sequence predicate key))
 131     (t
 132      (error 'simple-type-error
 133             :datum sequence
 134             :expected-type 'sequence
 135             :format-control "~S is not a sequence."
 136             :format-arguments (list sequence)))))
 137
 138 ;;; stable sort of lists
 139
 140 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over the list
 141 ;;; grabbing one element at a time and merging it with the next one form pairs
 142 ;;; of sorted elements. Then n is doubled, and elements are taken in runs of
 143 ;;; two, merging one run with the next to form quadruples of sorted elements.
 144 ;;; This continues until n is large enough that the inner loop only runs for
 145 ;;; one iteration; that is, there are only two runs that can be merged, the
 146 ;;; first run starting at the beginning of the list, and the second being the
 147 ;;; remaining elements.
 148
 149 (defun sort-list (list pred key)
 150   (let ((head (cons :header list))  ; head holds on to everything
 151         (n 1)                  ; bottom-up size of lists to be merged
 152         unsorted                    ; unsorted is the remaining list to be
 153                                     ;   broken into n size lists and merged
 154         list-1                      ; list-1 is one length n list to be merged
 155         last)                       ; last points to the last visited cell
 156     (declare (fixnum n))
 157     (loop
 158      ;; start collecting runs of n at the first element
 159      (setf unsorted (cdr head))
 160      ;; tack on the first merge of two n-runs to the head holder
 161      (setf last head)
 162      (let ((n-1 (1- n)))
 163        (declare (fixnum n-1))
 164        (loop
 165         (setf list-1 unsorted)
 166         (let ((temp (nthcdr n-1 list-1))
 167               list-2)
 168           (cond (temp
 169                  ;; there are enough elements for a second run
 170                  (setf list-2 (cdr temp))
 171                  (setf (cdr temp) nil)
 172                  (setf temp (nthcdr n-1 list-2))
 173                  (cond (temp
 174                         (setf unsorted (cdr temp))
 175                         (setf (cdr temp) nil))
 176                        ;; the second run goes off the end of the list
 177                        (t (setf unsorted nil)))
 178                  (multiple-value-bind (merged-head merged-last)
 179                      (merge-lists* list-1 list-2 pred key)
 180                    (setf (cdr last) merged-head)
 181                    (setf last merged-last))
 182                  (if (null unsorted) (return)))
 183                 ;; if there is only one run, then tack it on to the end
 184                 (t (setf (cdr last) list-1)
 185                    (return)))))
 186        (setf n (ash n 1)) ; (+ n n)
 187        ;; If the inner loop only executed once, then there were only enough
 188        ;; elements for two runs given n, so all the elements have been merged
 189        ;; into one list. This may waste one outer iteration to realize.
 190        (if (eq list-1 (cdr head))
 191            (return list-1))))))
 192
 193 ;;; APPLY-PRED saves us a function call sometimes.
 194 (eval-when (:compile-toplevel :execute)
 195   (sb!xc:defmacro apply-pred (one two pred key)
 196     `(if ,key
 197          (funcall ,pred (funcall ,key ,one)
 198                   (funcall ,key  ,two))
 199          (funcall ,pred ,one ,two)))
 200 ) ; EVAL-WHEN
 201
 202 (defvar *merge-lists-header* (list :header))
 203
 204 ;;; MERGE-LISTS*   originally written by Jim Large.
 205 ;;;                modified to return a pointer to the end of the result
 206 ;;;                   and to not cons header each time its called.
 207 ;;; It destructively merges list-1 with list-2. In the resulting
 208 ;;; list, elements of list-2 are guaranteed to come after equal elements
 209 ;;; of list-1.
 210 (defun merge-lists* (list-1 list-2 pred key)
 211   (do* ((result *merge-lists-header*)
 212         (P result))                  ; points to last cell of result
 213        ((or (null list-1) (null list-2)) ; done when either list used up
 214         (if (null list-1)              ; in which case, append the
 215             (rplacd p list-2)      ;   other list
 216             (rplacd p list-1))
 217         (do ((drag p lead)
 218              (lead (cdr p) (cdr lead)))
 219             ((null lead)
 220              (values (prog1 (cdr result) ; Return the result sans header
 221                             (rplacd result nil)) ; (free memory, be careful)
 222                      drag))))      ;   and return pointer to last element.
 223     (cond ((apply-pred (car list-2) (car list-1) pred key)
 224            (rplacd p list-2)       ; Append the lesser list to last cell of
 225            (setq p (cdr p))         ;   result. Note: test must bo done for
 226            (pop list-2))               ;   LIST-2 < LIST-1 so merge will be
 227           (T (rplacd p list-1)   ;   stable for LIST-1.
 228              (setq p (cdr p))
 229              (pop list-1)))))
 230
 231 ;;; stable sort of vectors
 232
 233 ;;; Stable sorting vectors is done with the same algorithm used for
 234 ;;; lists, using a temporary vector to merge back and forth between it
 235 ;;; and the given vector to sort.
 236
 237 (eval-when (:compile-toplevel :execute)
 238
 239 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 240 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 241 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 242 ;;; and merges them into a target vector starting at index start-1.
 243
 244 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 245                                                      pred key source-ref
 246                                                      target-ref)
 247   (let ((i (gensym))
 248         (j (gensym))
 249         (target-i (gensym)))
 250     `(let ((,i ,start-1)
 251            (,j ,end-1) ; start-2
 252            (,target-i ,start-1))
 253        (declare (fixnum ,i ,j ,target-i))
 254        (loop
 255         (cond ((= ,i ,end-1)
 256                (loop (if (= ,j ,end-2) (return))
 257                      (setf (,target-ref ,target ,target-i)
 258                            (,source-ref ,source ,j))
 259                      (incf ,target-i)
 260                      (incf ,j))
 261                (return))
 262               ((= ,j ,end-2)
 263                (loop (if (= ,i ,end-1) (return))
 264                      (setf (,target-ref ,target ,target-i)
 265                            (,source-ref ,source ,i))
 266                      (incf ,target-i)
 267                      (incf ,i))
 268                (return))
 269               ((apply-pred (,source-ref ,source ,j)
 270                            (,source-ref ,source ,i)
 271                            ,pred ,key)
 272                (setf (,target-ref ,target ,target-i)
 273                      (,source-ref ,source ,j))
 274                (incf ,j))
 275               (t (setf (,target-ref ,target ,target-i)
 276                        (,source-ref ,source ,i))
 277                  (incf ,i)))
 278         (incf ,target-i)))))
 279
 280 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
 281 ;;; it uses a temporary vector. Direction determines whether we are merging
 282 ;;; into the temporary (T) or back into the given vector (NIL).
 283
 284 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 285   (let ((vector-len (gensym)) (n (gensym))
 286         (direction (gensym))  (unsorted (gensym))
 287         (start-1 (gensym))    (end-1 (gensym))
 288         (end-2 (gensym))      (temp-len (gensym))
 289         (i (gensym)))
 290     `(let ((,vector-len (length (the vector ,vector)))
 291            (,n 1)        ; bottom-up size of contiguous runs to be merged
 292            (,direction t) ; t vector --> temp    nil temp --> vector
 293            (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
 294            (,unsorted 0)  ; unsorted..vector-len are the elements that need
 295                           ; to be merged for a given n
 296            (,start-1 0))  ; one n-len subsequence to be merged with the next
 297        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
 298        (if (> ,vector-len ,temp-len)
 299            (setf *merge-sort-temp-vector*
 300                  (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
 301        (loop
 302         ;; for each n, we start taking n-runs from the start of the vector
 303         (setf ,unsorted 0)
 304         (loop
 305          (setf ,start-1 ,unsorted)
 306          (let ((,end-1 (+ ,start-1 ,n)))
 307            (declare (fixnum ,end-1))
 308            (cond ((< ,end-1 ,vector-len)
 309                   ;; there are enough elements for a second run
 310                   (let ((,end-2 (+ ,end-1 ,n)))
 311                     (declare (fixnum ,end-2))
 312                     (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 313                     (setf ,unsorted ,end-2)
 314                     (if ,direction
 315                         (stable-sort-merge-vectors*
 316                          ,vector *merge-sort-temp-vector*
 317                          ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 318                         (stable-sort-merge-vectors*
 319                          *merge-sort-temp-vector* ,vector
 320                          ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 321                     (if (= ,unsorted ,vector-len) (return))))
 322                  ;; if there is only one run, copy those elements to the end
 323                  (t (if ,direction
 324                         (do ((,i ,start-1 (1+ ,i)))
 325                             ((= ,i ,vector-len))
 326                           (declare (fixnum ,i))
 327                           (setf (svref *merge-sort-temp-vector* ,i)
 328                                 (,vector-ref ,vector ,i)))
 329                         (do ((,i ,start-1 (1+ ,i)))
 330                             ((= ,i ,vector-len))
 331                           (declare (fixnum ,i))
 332                           (setf (,vector-ref ,vector ,i)
 333                                 (svref *merge-sort-temp-vector* ,i))))
 334                     (return)))))
 335         ;; If the inner loop only executed once, then there were only enough
 336         ;; elements for two subsequences given n, so all the elements have
 337         ;; been merged into one list. Start-1 will have remained 0 upon exit.
 338         (when (zerop ,start-1)
 339           (if ,direction
 340               ;; if we just merged into the temporary, copy it all back
 341               ;; to the given vector.
 342               (dotimes (,i ,vector-len)
 343                 (setf (,vector-ref ,vector ,i)
 344                       (svref *merge-sort-temp-vector* ,i))))
 345           (return ,vector))
 346         (setf ,n (ash ,n 1)) ; (* 2 n)
 347         (setf ,direction (not ,direction))))))
 348
 349 ) ; EVAL-when
 350
 351 ;;; Temporary vector for stable sorting vectors.
 352 (defvar *merge-sort-temp-vector*
 353   (make-array 50))
 354
 355 (declaim (simple-vector *merge-sort-temp-vector*))
 356
 357 (defun stable-sort-simple-vector (vector pred key)
 358   (declare (simple-vector vector))
 359   (vector-merge-sort vector pred key svref))
 360
 361 (defun stable-sort-vector (vector pred key)
 362   (vector-merge-sort vector pred key aref))
 363
 364 ;;;; merging
 365
 366 (eval-when (:compile-toplevel :execute)
 367
 368 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 369 ;;; of the elements of vector-1 and vector-2. Elements from vector-2 are
 370 ;;; chosen only if they are strictly less than elements of vector-1,
 371 ;;; (pred elt-2 elt-1), as specified in the manual.
 372
 373 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 374                                result-vector pred key access)
 375   (let ((result-i (gensym))
 376         (i (gensym))
 377         (j (gensym)))
 378     `(let* ((,result-i 0)
 379             (,i 0)
 380             (,j 0))
 381        (declare (fixnum ,result-i ,i ,j))
 382        (loop
 383         (cond ((= ,i ,length-1)
 384                (loop (if (= ,j ,length-2) (return))
 385                      (setf (,access ,result-vector ,result-i)
 386                            (,access ,vector-2 ,j))
 387                      (incf ,result-i)
 388                      (incf ,j))
 389                (return ,result-vector))
 390               ((= ,j ,length-2)
 391                (loop (if (= ,i ,length-1) (return))
 392                      (setf (,access ,result-vector ,result-i)
 393                            (,access ,vector-1 ,i))
 394                      (incf ,result-i)
 395                      (incf ,i))
 396                (return ,result-vector))
 397               ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
 398                            ,pred ,key)
 399                (setf (,access ,result-vector ,result-i)
 400                      (,access ,vector-2 ,j))
 401                (incf ,j))
 402               (t (setf (,access ,result-vector ,result-i)
 403                        (,access ,vector-1 ,i))
 404                  (incf ,i)))
 405         (incf ,result-i)))))
 406
 407 ) ; EVAL-WHEN
 408
 409 (defun merge (result-type sequence1 sequence2 predicate &key key)
 410   #!+sb-doc
 411   "The sequences Sequence1 and Sequence2 are destructively merged into
 412    a sequence of type Result-Type using the Predicate to order the elements."
 413   (if (eq result-type 'list)
 414       (let ((result (merge-lists* (coerce sequence1 'list)
 415                                   (coerce sequence2 'list)
 416                                   predicate key)))
 417         result)
 418       (let* ((vector-1 (coerce sequence1 'vector))
 419              (vector-2 (coerce sequence2 'vector))
 420              (length-1 (length vector-1))
 421              (length-2 (length vector-2))
 422              (result (make-sequence-of-type result-type (+ length-1 length-2))))
 423         (declare (vector vector-1 vector-2)
 424                  (fixnum length-1 length-2))
 425
 426         #!+high-security
 427         (check-type-var result result-type)
 428         (if (and (simple-vector-p result)
 429                  (simple-vector-p vector-1)
 430                  (simple-vector-p vector-2))
 431             (merge-vectors vector-1 length-1 vector-2 length-2
 432                            result predicate key svref)
 433             (merge-vectors vector-1 length-1 vector-2 length-2
 434                            result predicate key aref)))))