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