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-vector (vector start end predicate-fun key-fun-or-nil)
  15   (sort-vector vector start end predicate-fun key-fun-or-nil))
  16
  17 ;;; This is MAYBE-INLINE because it's not too hard to have an
  18 ;;; application where sorting is a major bottleneck, and inlining it
  19 ;;; allows the compiler to make enough optimizations that it might be
  20 ;;; worth the (large) cost in space.
  21 (declaim (maybe-inline sort))
  22 (defun sort (sequence predicate &key key)
  23   #!+sb-doc
  24   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
  25    ARG1 is to precede ARG2."
  26   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
  27     (typecase sequence
  28       (list
  29        (stable-sort-list sequence
  30                          predicate-fun
  31                          (if key (%coerce-callable-to-fun key) #'identity)))
  32       (vector
  33        (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
  34          (with-array-data ((vector (the vector sequence))
  35                            (start 0)
  36                            (end (length sequence)))
  37            (sort-vector vector start end predicate-fun key-fun-or-nil)))
  38        sequence)
  39       (t
  40        (error 'simple-type-error
  41               :datum sequence
  42               :expected-type 'sequence
  43               :format-control "~S is not a sequence."
  44               :format-arguments (list sequence))))))
  45 \f
  46 ;;;; stable sorting
  47
  48 (defun stable-sort (sequence predicate &key key)
  49   #!+sb-doc
  50   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
  51    ARG1 is to precede ARG2."
  52   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
  53     (typecase sequence
  54       (simple-vector
  55        (stable-sort-simple-vector sequence
  56                                   predicate-fun
  57                                   (and key (%coerce-callable-to-fun key))))
  58       (list
  59        (stable-sort-list sequence
  60                          predicate-fun
  61                          (if key (%coerce-callable-to-fun key) #'identity)))
  62       (vector
  63        (stable-sort-vector sequence
  64                            predicate-fun
  65                            (and key (%coerce-callable-to-fun key))))
  66       (t
  67        (error 'simple-type-error
  68               :datum sequence
  69               :expected-type 'sequence
  70               :format-control "~S is not a sequence."
  71               :format-arguments (list sequence))))))
  72   \f
  73 ;;; APPLY-KEYED-PRED saves us a function call sometimes.
  74 (eval-when (:compile-toplevel :execute)
  75   (sb!xc:defmacro apply-keyed-pred (one two pred key)
  76     `(if ,key
  77          (funcall ,pred (funcall ,key ,one)
  78                   (funcall ,key  ,two))
  79          (funcall ,pred ,one ,two)))
  80 ) ; EVAL-WHEN
  81 \f
  82 ;;;; stable sort of lists
  83
  84 (defun last-cons-of (list)
  85   (loop (let ((rest (rest list)))
  86           (if rest
  87               (setf list rest)
  88               (return list)))))
  89
  90 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
  91 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
  92 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
  93 ;;; come before equal elements of LIST-2.
  94 ;;;
  95 ;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
  96 ;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
  97 ;;; the last cons in the list which NRECONC calls TAIL).
  98 (defun merge-lists* (list-1 list-2 pred-fun key-fun)
  99   (declare (type list list-1 list-2))
 100   (declare (type function pred-fun key-fun))
 101   (cond ((null list-1) (values list-2 (last-cons-of list-2)))
 102         ((null list-2) (values list-1 (last-cons-of list-1)))
 103         (t (let* ((reversed-result-so-far nil)
 104                   (key-1 (funcall key-fun (car list-1)))
 105                   (key-2 (funcall key-fun (car list-2))))
 106              (loop
 107               (macrolet ((frob (list-i key-i other-list)
 108                            `(progn
 109                               ;; basically
 110                               ;;   (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
 111                               ;; except doing some fancy footwork to
 112                               ;; reuse the cons cell:
 113                               (psetf (cdr ,list-i) reversed-result-so-far
 114                                      reversed-result-so-far ,list-i
 115                                      ,list-i (cdr ,list-i))
 116                               ;; Now maybe we're done.
 117                               (if (endp ,list-i)
 118                                   (return (values (nreconc
 119                                                    reversed-result-so-far
 120                                                    ,other-list)
 121                                                   (last-cons-of
 122                                                    ,other-list)))
 123                                   (setf ,key-i
 124                                         (funcall key-fun (car ,list-i)))))))
 125                 ;; Note that by making KEY-2 the first arg to
 126                 ;; PRED-FUN, we arrange that if PRED-FUN is a function
 127                 ;; in the #'< style, the outcome is stably sorted.
 128                 (if (funcall pred-fun key-2 key-1)
 129                     (frob list-2 key-2 list-1)
 130                     (frob list-1 key-1 list-2))))))))
 131
 132 ;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
 133 ;;; over the list grabbing one element at a time and merging it with
 134 ;;; the next one to form pairs of sorted elements. Then N is doubled,
 135 ;;; and elements are taken in runs of two, merging one run with the
 136 ;;; next to form quadruples of sorted elements. This continues until N
 137 ;;; is large enough that the inner loop only runs for one iteration;
 138 ;;; that is, there are only two runs that can be merged, the first run
 139 ;;; starting at the beginning of the list, and the second being the
 140 ;;; remaining elements.
 141 (defun stable-sort-list (list pred-fun key-fun)
 142   (let ((head (cons :header list))  ; head holds on to everything
 143         (n 1)                       ; bottom-up size of lists to be merged
 144         unsorted                    ; unsorted is the remaining list to be
 145                                     ;   broken into n size lists and merged
 146         list-1                      ; list-1 is one length n list to be merged
 147         last)                       ; last points to the last visited cell
 148     (declare (type function pred-fun key-fun)
 149              (type fixnum n))
 150     (loop
 151      ;; Start collecting runs of N at the first element.
 152      (setf unsorted (cdr head))
 153      ;; Tack on the first merge of two N-runs to the head holder.
 154      (setf last head)
 155      (let ((n-1 (1- n)))
 156        (declare (fixnum n-1))
 157        (loop
 158         (setf list-1 unsorted)
 159         (let ((temp (nthcdr n-1 list-1))
 160               list-2)
 161           (cond (temp
 162                  ;; There are enough elements for a second run.
 163                  (setf list-2 (cdr temp))
 164                  (setf (cdr temp) nil)
 165                  (setf temp (nthcdr n-1 list-2))
 166                  (cond (temp
 167                         (setf unsorted (cdr temp))
 168                         (setf (cdr temp) nil))
 169                        ;; The second run goes off the end of the list.
 170                        (t (setf unsorted nil)))
 171                  (multiple-value-bind (merged-head merged-last)
 172                      (merge-lists* list-1 list-2 pred-fun key-fun)
 173                    (setf (cdr last) merged-head
 174                          last merged-last))
 175                  (if (null unsorted) (return)))
 176                 ;; If there is only one run, then tack it on to the end.
 177                 (t (setf (cdr last) list-1)
 178                    (return)))))
 179        (setf n (ash n 1)) ; (+ n n)
 180        ;; If the inner loop only executed once, then there were only
 181        ;; enough elements for two runs given n, so all the elements
 182        ;; have been merged into one list. This may waste one outer
 183        ;; iteration to realize.
 184        (if (eq list-1 (cdr head))
 185            (return list-1))))))
 186 \f
 187 ;;;; stable sort of vectors
 188
 189 ;;; Stable sorting vectors is done with the same algorithm used for
 190 ;;; lists, using a temporary vector to merge back and forth between it
 191 ;;; and the given vector to sort.
 192
 193 (eval-when (:compile-toplevel :execute)
 194
 195 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 196 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 197 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 198 ;;; and merges them into a target vector starting at index start-1.
 199
 200 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 201                                                      pred key source-ref
 202                                                      target-ref)
 203   (let ((i (gensym))
 204         (j (gensym))
 205         (target-i (gensym)))
 206     `(let ((,i ,start-1)
 207            (,j ,end-1) ; start-2
 208            (,target-i ,start-1))
 209        (declare (fixnum ,i ,j ,target-i))
 210        (loop
 211         (cond ((= ,i ,end-1)
 212                (loop (if (= ,j ,end-2) (return))
 213                      (setf (,target-ref ,target ,target-i)
 214                            (,source-ref ,source ,j))
 215                      (incf ,target-i)
 216                      (incf ,j))
 217                (return))
 218               ((= ,j ,end-2)
 219                (loop (if (= ,i ,end-1) (return))
 220                      (setf (,target-ref ,target ,target-i)
 221                            (,source-ref ,source ,i))
 222                      (incf ,target-i)
 223                      (incf ,i))
 224                (return))
 225               ((apply-keyed-pred (,source-ref ,source ,j)
 226                                  (,source-ref ,source ,i)
 227                                  ,pred ,key)
 228                (setf (,target-ref ,target ,target-i)
 229                      (,source-ref ,source ,j))
 230                (incf ,j))
 231               (t (setf (,target-ref ,target ,target-i)
 232                        (,source-ref ,source ,i))
 233                  (incf ,i)))
 234         (incf ,target-i)))))
 235
 236 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
 237 ;;; but it uses a temporary vector. DIRECTION determines whether we
 238 ;;; are merging into the temporary (T) or back into the given vector
 239 ;;; (NIL).
 240 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 241   (let ((vector-len (gensym)) (n (gensym))
 242         (direction (gensym))  (unsorted (gensym))
 243         (start-1 (gensym))    (end-1 (gensym))
 244         (end-2 (gensym))      (temp-len (gensym))
 245         (i (gensym)))
 246     `(let ((,vector-len (length (the vector ,vector)))
 247            (,n 1)        ; bottom-up size of contiguous runs to be merged
 248            (,direction t) ; t vector --> temp    nil temp --> vector
 249            (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
 250            (,unsorted 0)  ; unsorted..vector-len are the elements that need
 251                           ; to be merged for a given n
 252            (,start-1 0))  ; one n-len subsequence to be merged with the next
 253        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
 254        (if (> ,vector-len ,temp-len)
 255            (setf *merge-sort-temp-vector*
 256                  (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
 257        (loop
 258         ;; for each n, we start taking n-runs from the start of the vector
 259         (setf ,unsorted 0)
 260         (loop
 261          (setf ,start-1 ,unsorted)
 262          (let ((,end-1 (+ ,start-1 ,n)))
 263            (declare (fixnum ,end-1))
 264            (cond ((< ,end-1 ,vector-len)
 265                   ;; there are enough elements for a second run
 266                   (let ((,end-2 (+ ,end-1 ,n)))
 267                     (declare (fixnum ,end-2))
 268                     (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 269                     (setf ,unsorted ,end-2)
 270                     (if ,direction
 271                         (stable-sort-merge-vectors*
 272                          ,vector *merge-sort-temp-vector*
 273                          ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 274                         (stable-sort-merge-vectors*
 275                          *merge-sort-temp-vector* ,vector
 276                          ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 277                     (if (= ,unsorted ,vector-len) (return))))
 278                  ;; if there is only one run, copy those elements to the end
 279                  (t (if ,direction
 280                         (do ((,i ,start-1 (1+ ,i)))
 281                             ((= ,i ,vector-len))
 282                           (declare (fixnum ,i))
 283                           (setf (svref *merge-sort-temp-vector* ,i)
 284                                 (,vector-ref ,vector ,i)))
 285                         (do ((,i ,start-1 (1+ ,i)))
 286                             ((= ,i ,vector-len))
 287                           (declare (fixnum ,i))
 288                           (setf (,vector-ref ,vector ,i)
 289                                 (svref *merge-sort-temp-vector* ,i))))
 290                     (return)))))
 291         ;; If the inner loop only executed once, then there were only enough
 292         ;; elements for two subsequences given n, so all the elements have
 293         ;; been merged into one list. Start-1 will have remained 0 upon exit.
 294         (when (zerop ,start-1)
 295           (if ,direction
 296               ;; if we just merged into the temporary, copy it all back
 297               ;; to the given vector.
 298               (dotimes (,i ,vector-len)
 299                 (setf (,vector-ref ,vector ,i)
 300                       (svref *merge-sort-temp-vector* ,i))))
 301           (return ,vector))
 302         (setf ,n (ash ,n 1)) ; (* 2 n)
 303         (setf ,direction (not ,direction))))))
 304
 305 ) ; EVAL-when
 306
 307 ;;; temporary vector for stable sorting vectors
 308 (defvar *merge-sort-temp-vector*
 309   (make-array 50))
 310
 311 (declaim (simple-vector *merge-sort-temp-vector*))
 312
 313 (defun stable-sort-simple-vector (vector pred key)
 314   (declare (type simple-vector vector)
 315            (type function pred)
 316            (type (or null function) key))
 317   (vector-merge-sort vector pred key svref))
 318
 319 (defun stable-sort-vector (vector pred key)
 320   (declare (type function pred)
 321            (type (or null function) key))
 322   (vector-merge-sort vector pred key aref))
 323 \f
 324 ;;;; merging
 325
 326 (eval-when (:compile-toplevel :execute)
 327
 328 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 329 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
 330 ;;; are chosen only if they are strictly less than elements of
 331 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
 332 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 333                                result-vector pred key access)
 334   (let ((result-i (gensym))
 335         (i (gensym))
 336         (j (gensym)))
 337     `(let* ((,result-i 0)
 338             (,i 0)
 339             (,j 0))
 340        (declare (fixnum ,result-i ,i ,j))
 341        (loop
 342         (cond ((= ,i ,length-1)
 343                (loop (if (= ,j ,length-2) (return))
 344                      (setf (,access ,result-vector ,result-i)
 345                            (,access ,vector-2 ,j))
 346                      (incf ,result-i)
 347                      (incf ,j))
 348                (return ,result-vector))
 349               ((= ,j ,length-2)
 350                (loop (if (= ,i ,length-1) (return))
 351                      (setf (,access ,result-vector ,result-i)
 352                            (,access ,vector-1 ,i))
 353                      (incf ,result-i)
 354                      (incf ,i))
 355                (return ,result-vector))
 356               ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
 357                                  ,pred ,key)
 358                (setf (,access ,result-vector ,result-i)
 359                      (,access ,vector-2 ,j))
 360                (incf ,j))
 361               (t (setf (,access ,result-vector ,result-i)
 362                        (,access ,vector-1 ,i))
 363                  (incf ,i)))
 364         (incf ,result-i)))))
 365
 366 ) ; EVAL-WHEN
 367
 368 (defun merge (result-type sequence1 sequence2 predicate &key key)
 369   #!+sb-doc
 370   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
 371    sequence of type RESULT-TYPE using PREDICATE to order the elements."
 372   ;; FIXME: This implementation is remarkably inefficient in various
 373   ;; ways. In decreasing order of estimated user astonishment, I note:
 374   ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
 375   ;; to lists before doing MERGE-LISTS*; and walking input lists
 376   ;; (because of the call to MERGE-LISTS*, which walks the list to
 377   ;; find the last element for its second return value) even in cases
 378   ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
 379   ;; can be largely ignored. -- WHN 2003-01-05
 380   (let ((type (specifier-type result-type)))
 381     (cond
 382       ((csubtypep type (specifier-type 'list))
 383        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
 384        ;; benefits from the error checking there. Short of
 385        ;; reimplementing everything, we can't do the same for the LIST
 386        ;; case, so do relevant length checking here:
 387        (let ((s1 (coerce sequence1 'list))
 388              (s2 (coerce sequence2 'list))
 389              (pred-fun (%coerce-callable-to-fun predicate))
 390              (key-fun (if key
 391                           (%coerce-callable-to-fun key)
 392                           #'identity)))
 393          (when (type= type (specifier-type 'list))
 394            (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun))))
 395          (when (eq type *empty-type*)
 396            (bad-sequence-type-error nil))
 397          (when (type= type (specifier-type 'null))
 398            (if (and (null s1) (null s2))
 399                (return-from merge 'nil)
 400                ;; FIXME: This will break on circular lists (as,
 401                ;; indeed, will the whole MERGE function).
 402                (sequence-type-length-mismatch-error type
 403                                                     (+ (length s1)
 404                                                        (length s2)))))
 405          (if (cons-type-p type)
 406              (multiple-value-bind (min exactp)
 407                  (sb!kernel::cons-type-length-info type)
 408                (let ((length (+ (length s1) (length s2))))
 409                  (if exactp
 410                      (unless (= length min)
 411                        (sequence-type-length-mismatch-error type length))
 412                      (unless (>= length min)
 413                        (sequence-type-length-mismatch-error type length)))
 414                  (values (merge-lists* s1 s2 pred-fun key-fun))))
 415              (sequence-type-too-hairy result-type))))
 416       ((csubtypep type (specifier-type 'vector))
 417        (let* ((vector-1 (coerce sequence1 'vector))
 418               (vector-2 (coerce sequence2 'vector))
 419               (length-1 (length vector-1))
 420               (length-2 (length vector-2))
 421               (result (make-sequence result-type
 422                                      (+ length-1 length-2))))
 423          (declare (vector vector-1 vector-2)
 424                   (fixnum length-1 length-2))
 425          (if (and (simple-vector-p result)
 426                   (simple-vector-p vector-1)
 427                   (simple-vector-p vector-2))
 428              (merge-vectors vector-1 length-1 vector-2 length-2
 429                             result predicate key svref)
 430              (merge-vectors vector-1 length-1 vector-2 length-2
 431                             result predicate key aref))))
 432       (t (bad-sequence-type-error result-type)))))