1;;; sort.lisp 2;;; 3;;; Copyright (C) 2003-2005 Peter Graves 4;;; $Id$ 5;;; 6;;; This program is free software; you can redistribute it and/or 7;;; modify it under the terms of the GNU General Public License 8;;; as published by the Free Software Foundation; either version 2 9;;; of the License, or (at your option) any later version. 10;;; 11;;; This program is distributed in the hope that it will be useful, 12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;; GNU General Public License for more details. 15;;; 16;;; You should have received a copy of the GNU General Public License 17;;; along with this program; if not, write to the Free Software 18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 19;;; 20;;; As a special exception, the copyright holders of this library give you 21;;; permission to link this library with independent modules to produce an 22;;; executable, regardless of the license terms of these independent 23;;; modules, and to copy and distribute the resulting executable under 24;;; terms of your choice, provided that you also meet, for each linked 25;;; independent module, the terms and conditions of the license of that 26;;; module. An independent module is a module which is not derived from 27;;; or based on this library. If you modify this library, you may extend 28;;; this exception to your version of the library, but you are not 29;;; obligated to do so. If you do not wish to do so, delete this 30;;; exception statement from your version. 31 32(in-package #:system) 33 34(require "EXTENSIBLE-SEQUENCES-BASE") 35 36;;; 37;;; STABLE SORT 38;;; 39 40;;; 41;;; MERGE SORT for vectors (and sequences in general) 42;;; 43;;; - top-down stable merge sort 44;;; - it is defined with 2 macros to allow a single algorithm 45;;; and multiple sequence types: merge-vectors-body and merge-sort-body 46;;; - merge-vectors-body merges two given sequences 47;;; - merge-sort-body contains the top-down algorithm 48;;; - the body macro is called by the merge-sort-vectors functions, 49;;; which typecases the type of sequence and expands the apropriate body 50;;; - more types of sequences/vectors can be added 51;;; - the macros generate the merge sort body with or without funcall to key 52;;; - the merge-vectors algorithm is inspired from the CCL base code 53;;; 54 55;;; http://abcl.org/trac/ticket/196 56;;; TODO Restore the optimization for SIMPLE-VECTOR types by 57;;; conditionally using aref/svref instead of always using AREF 58 59(defmacro merge-vectors-body (type ref a start-a end-a b start-b end-b aux start-aux predicate &optional key) 60 (let ((i-a (gensym)) 61 (i-b (gensym)) 62 (i-aux (gensym)) 63 (v-a (gensym)) 64 (v-b (gensym)) 65 (k-a (gensym)) 66 (k-b (gensym)) 67 (merge-block (gensym))) 68 `(locally 69 (declare (type fixnum ,start-a ,end-a ,start-b ,end-b ,start-aux) 70 (type ,type ,a ,b) 71 (type simple-vector ,aux) 72 (type function ,predicate ,@(if key `(,key))) 73 (optimize (speed 3) (safety 0))) 74 (block ,merge-block 75 (let ((,i-a ,start-a) 76 (,i-b ,start-b) 77 (,i-aux ,start-aux) 78 ,v-a ,v-b ,k-a ,k-b) 79 (declare (type fixnum ,i-a ,i-b ,i-aux)) 80 (cond ((= ,start-a ,end-a) 81 (when (= ,start-b ,end-b) 82 (return-from ,merge-block)) 83 (setf ,i-a ,start-b 84 ,end-a ,end-b 85 ,a ,b 86 ,v-a (,ref ,a ,i-a))) 87 ((= ,start-b ,end-b) 88 (setf ,i-a ,start-a 89 ,v-a (,ref ,a ,i-a))) 90 (t 91 (setf ,v-a (,ref ,a ,i-a) 92 ,v-b (,ref ,b ,i-b) 93 ,@(if key 94 `(,k-a (funcall ,key ,v-a)) 95 `(,k-a ,v-a)) 96 ,@(if key 97 `(,k-b (funcall ,key ,v-b)) 98 `(,k-b ,v-b))) 99 (loop 100 (if (funcall ,predicate ,k-b ,k-a) 101 (progn 102 ,(if (subtypep type 'simple-vector) 103 `(setf (svref ,aux ,i-aux) ,v-b 104 ,i-aux (+ ,i-aux 1) 105 ,i-b (+ ,i-b 1)) 106 `(setf (aref ,aux ,i-aux) ,v-b 107 ,i-aux (+ ,i-aux 1) 108 ,i-b (+ ,i-b 1))) 109 (when (= ,i-b ,end-b) (return)) 110 (setf ,v-b (,ref ,b ,i-b) 111 ,@(if key 112 `(,k-b (funcall ,key ,v-b)) 113 `(,k-b ,v-b)))) 114 (progn 115 ,(if (subtypep type 'simple-vector) 116 `(setf (svref ,aux ,i-aux) ,v-a 117 ,i-aux (+ ,i-aux 1) 118 ,i-a (+ ,i-a 1)) 119 `(setf (aref ,aux ,i-aux) ,v-a 120 ,i-aux (+ ,i-aux 1) 121 ,i-a (+ ,i-a 1))) 122 (when (= ,i-a ,end-a) 123 (setf ,a ,b 124 ,i-a ,i-b 125 ,end-a ,end-b 126 ,v-a ,v-b) 127 (return)) 128 (setf ,v-a (,ref ,a ,i-a) 129 ,@(if key 130 `(,k-a (funcall ,key ,v-a)) 131 `(,k-a ,v-a)))))))) 132 (loop 133 ,(if (subtypep type 'simple-vector) 134 `(setf (svref ,aux ,i-aux) ,v-a 135 ,i-a (+ ,i-a 1)) 136 `(setf (aref ,aux ,i-aux) ,v-a 137 ,i-a (+ ,i-a 1))) 138 (when (= ,i-a ,end-a) (return)) 139 (setf ,v-a (,ref ,a ,i-a) 140 ,i-aux (+ ,i-aux 1)))))))) 141 142(defmacro merge-sort-body (type ref mpredicate mkey msequence mstart mend) 143 (let ((merge-sort-call (gensym)) 144 (maux (gensym)) 145 (aux (gensym)) 146 (sequence (gensym)) 147 (start (gensym)) 148 (end (gensym)) 149 (predicate (gensym)) 150 (key (gensym)) 151 (mid (gensym)) 152 (direction (gensym))) 153 `(locally 154 (declare (optimize (speed 3) (safety 0))) 155 (labels ((,merge-sort-call (,sequence ,start ,end ,predicate ,key ,aux ,direction) 156 (declare (type function ,predicate ,@(if mkey `(,key))) 157 (type fixnum ,start ,end) 158 (type ,type ,sequence)) 159 (let ((,mid (+ ,start (ash (- ,end ,start) -1)))) 160 (declare (type fixnum ,mid)) 161 (if (<= (- ,mid 1) ,start) 162 (unless ,direction (setf (,ref ,aux ,start) (,ref ,sequence ,start))) 163 (,merge-sort-call ,sequence ,start ,mid ,predicate ,key ,aux (not ,direction))) 164 (if (>= (+ ,mid 1) ,end) 165 (unless ,direction (setf (,ref ,aux ,mid) (,ref ,sequence ,mid))) 166 (,merge-sort-call ,sequence ,mid ,end ,predicate ,key ,aux (not ,direction))) 167 (unless ,direction (psetq ,sequence ,aux ,aux ,sequence)) 168 ,(if mkey 169 `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 170 ,mid ,end ,aux ,start ,predicate ,key) 171 `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 172 ,mid ,end ,aux ,start ,predicate))))) 173 (let ((,maux (make-array ,mend))) 174 (declare (type ,maux ,type)) 175 (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil)))))) 176 177(defun merge-sort-vectors (sequence predicate key) 178 (let ((end (length sequence))) 179 (when (> end 1) 180 (typecase sequence 181 (simple-vector 182 (if key 183 (merge-sort-body simple-vector svref predicate key sequence 0 end) 184 (merge-sort-body simple-vector svref predicate nil sequence 0 end))) 185 (vector 186 (if key 187 (merge-sort-body vector aref predicate key sequence 0 end) 188 (merge-sort-body vector aref predicate nil sequence 0 end))))) 189 sequence)) 190 191 192;;; 193;;; MERGE SORT for lists 194;;; 195 196;; Adapted from SBCL. 197(declaim (ftype (function (list) cons) last-cons-of)) 198(defun last-cons-of (list) 199 (loop 200 (let ((rest (rest list))) 201 (if rest 202 (setf list rest) 203 (return list))))) 204 205;; Adapted from OpenMCL. 206(defun merge-lists (list1 list2 pred key) 207 (declare (optimize (speed 3) (safety 0))) 208 (if (null key) 209 (merge-lists-no-key list1 list2 pred) 210 (cond ((null list1) 211 (values list2 (last-cons-of list2))) 212 ((null list2) 213 (values list1 (last-cons-of list1))) 214 (t 215 (let* ((result (cons nil nil)) 216 (p result) ; p points to last cell of result 217 (key1 (funcall key (car list1))) 218 (key2 (funcall key (car list2)))) 219 (declare (type list p)) 220 (loop 221 (cond ((funcall pred key2 key1) 222 (rplacd p list2) ; append the lesser list to last cell of 223 (setf p (cdr p)) ; result. Note: test must bo done for 224 (pop list2) ; list2 < list1 so merge will be 225 (unless list2 ; stable for list1 226 (rplacd p list1) 227 (return (values (cdr result) (last-cons-of p)))) 228 (setf key2 (funcall key (car list2)))) 229 (t 230 (rplacd p list1) 231 (setf p (cdr p)) 232 (pop list1) 233 (unless list1 234 (rplacd p list2) 235 (return (values (cdr result) (last-cons-of p)))) 236 (setf key1 (funcall key (car list1))))))))))) 237 238(defun merge-lists-no-key (list1 list2 pred) 239 (declare (optimize (speed 3) (safety 0))) 240 (cond ((null list1) 241 (values list2 (last-cons-of list2))) 242 ((null list2) 243 (values list1 (last-cons-of list1))) 244 (t 245 (let* ((result (cons nil nil)) 246 (p result) ; p points to last cell of result 247 (key1 (car list1)) 248 (key2 (car list2))) 249 (declare (type list p)) 250 (loop 251 (cond ((funcall pred key2 key1) 252 (rplacd p list2) ; append the lesser list to last cell of 253 (setf p (cdr p)) ; result. Note: test must bo done for 254 (pop list2) ; list2 < list1 so merge will be 255 (unless list2 ; stable for list1 256 (rplacd p list1) 257 (return (values (cdr result) (last-cons-of p)))) 258 (setf key2 (car list2))) 259 (t 260 (rplacd p list1) 261 (setf p (cdr p)) 262 (pop list1) 263 (unless list1 264 (rplacd p list2) 265 (return (values (cdr result) (last-cons-of p)))) 266 (setf key1 (car list1))))))))) 267 268;;; SORT-LIST uses a bottom up merge sort. First a pass is made over 269;;; the list grabbing one element at a time and merging it with the next one 270;;; form pairs of sorted elements. Then n is doubled, and elements are taken 271;;; in runs of two, merging one run with the next to form quadruples of sorted 272;;; elements. This continues until n is large enough that the inner loop only 273;;; runs for one iteration; that is, there are only two runs that can be merged, 274;;; the first run starting at the beginning of the list, and the second being 275;;; the remaining elements. 276 277(defun sort-list (list pred key) 278 (when (or (eq key #'identity) (eq key 'identity)) 279 (setf key nil)) 280 (let ((head (cons nil list)) ; head holds on to everything 281 (n 1) ; bottom-up size of lists to be merged 282 unsorted ; unsorted is the remaining list to be 283 ; broken into n size lists and merged 284 list-1 ; list-1 is one length n list to be merged 285 last ; last points to the last visited cell 286 ) 287 (declare (type fixnum n)) 288 (loop 289 ;; start collecting runs of n at the first element 290 (setf unsorted (cdr head)) 291 ;; tack on the first merge of two n-runs to the head holder 292 (setf last head) 293 (let ((n-1 (1- n))) 294 (declare (type fixnum n-1)) 295 (loop 296 (setf list-1 unsorted) 297 (let ((temp (nthcdr n-1 list-1)) 298 list-2) 299 (cond (temp 300 ;; there are enough elements for a second run 301 (setf list-2 (cdr temp)) 302 (setf (cdr temp) nil) 303 (setf temp (nthcdr n-1 list-2)) 304 (cond (temp 305 (setf unsorted (cdr temp)) 306 (setf (cdr temp) nil)) 307 ;; the second run goes off the end of the list 308 (t (setf unsorted nil))) 309 (multiple-value-bind (merged-head merged-last) 310 (merge-lists list-1 list-2 pred key) 311 (setf (cdr last) merged-head) 312 (setf last merged-last)) 313 (if (null unsorted) (return))) 314 ;; if there is only one run, then tack it on to the end 315 (t (setf (cdr last) list-1) 316 (return))))) 317 (setf n (+ n n)) 318 ;; If the inner loop only executed once, then there were only enough 319 ;; elements for two runs given n, so all the elements have been merged 320 ;; into one list. This may waste one outer iteration to realize. 321 (if (eq list-1 (cdr head)) 322 (return list-1)))))) 323;;; 324;;; MERGE 325;;; 326 327;;; From ECL. Should already be user-extensible as it does no type dispatch 328;;; and uses only user-extensible functions. 329(defun merge (result-type sequence1 sequence2 predicate 330 &key key 331 &aux (l1 (length sequence1)) (l2 (length sequence2))) 332 (unless key (setq key #'identity)) 333 (do ((newseq (make-sequence result-type (+ l1 l2))) 334 (j 0 (1+ j)) 335 (i1 0) 336 (i2 0)) 337 ((and (= i1 l1) (= i2 l2)) newseq) 338 (cond ((and (< i1 l1) (< i2 l2)) 339 (cond ((funcall predicate 340 (funcall key (elt sequence1 i1)) 341 (funcall key (elt sequence2 i2))) 342 (setf (elt newseq j) (elt sequence1 i1)) 343 (incf i1)) 344 ((funcall predicate 345 (funcall key (elt sequence2 i2)) 346 (funcall key (elt sequence1 i1))) 347 (setf (elt newseq j) (elt sequence2 i2)) 348 (incf i2)) 349 (t 350 (setf (elt newseq j) (elt sequence1 i1)) 351 (incf i1)))) 352 ((< i1 l1) 353 (setf (elt newseq j) (elt sequence1 i1)) 354 (incf i1)) 355 (t 356 (setf (elt newseq j) (elt sequence2 i2)) 357 (incf i2))))) 358 359;;; 360;;; SORT 361;;; 362 363;;; 364;;; QUICKSORT 365;;; 366;;; - algorithm is in the quicksort-body macro, so that it allows 367;;; the use of different types (e.g., simple-vector, vector) 368;;; - the pivot is picked by selecting middle point 369;;; - sorts the smaller partition first 370;;; - the macro generates the quicksort body with or without funcall to key 371;;; 372 373(defmacro quicksort-body (type ref mpredicate mkey sequence mstart mend) 374 (let ((quicksort-call (gensym)) 375 (predicate (gensym)) 376 (key (gensym)) 377 (vector (gensym)) 378 (start (gensym)) 379 (end (gensym)) 380 (i (gensym)) 381 (j (gensym)) 382 (p (gensym)) 383 (d (gensym)) 384 (kd (gensym))) 385 `(locally 386 (declare (speed 3) (safety 0)) 387 (labels ((,quicksort-call (,vector ,start ,end ,predicate ,key) 388 (declare (type function ,predicate ,@(if mkey `(,key))) 389 (type fixnum ,start ,end) 390 (type ,type ,sequence)) 391 (if (< ,start ,end) 392 (let* ((,i ,start) 393 (,j (1+ ,end)) 394 (,p (the fixnum (+ ,start (ash (- ,end ,start) -1)))) 395 (,d (,ref ,vector ,p)) 396 ,@(if mkey 397 `((,kd (funcall ,key ,d))) 398 `((,kd ,d)))) 399 (rotatef (,ref ,vector ,p) (,ref ,vector ,start)) 400 (block outer-loop 401 (loop 402 (loop 403 (unless (> (decf ,j) ,i) (return-from outer-loop)) 404 (when (funcall ,predicate 405 ,@(if mkey 406 `((funcall ,key (,ref ,vector ,j))) 407 `((,ref ,vector ,j))) 408 ,kd) (return))) 409 (loop 410 (unless (< (incf ,i) ,j) (return-from outer-loop)) 411 (unless (funcall ,predicate 412 ,@(if mkey 413 `((funcall ,key (,ref ,vector ,i))) 414 `((,ref ,vector ,i))) 415 ,kd) (return))) 416 (rotatef (,ref ,vector ,i) (,ref ,vector ,j)))) 417 (setf (,ref ,vector ,start) (,ref ,vector ,j) 418 (,ref ,vector ,j) ,d) 419 (if (< (- ,j ,start) (- ,end ,j)) 420 (progn 421 (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key) 422 (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key)) 423 (progn 424 (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key) 425 (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key))))))) 426 (,quicksort-call ,sequence ,mstart ,mend ,mpredicate ,mkey))))) 427 428(defun quicksort (sequence predicate key) 429 (handler-case 430 (let ((end (1- (length sequence)))) 431 (typecase sequence 432 (simple-vector 433 (if key 434 (quicksort-body simple-vector svref predicate key sequence 0 end) 435 (quicksort-body simple-vector svref predicate nil sequence 0 end))) 436 (vector 437 (if key 438 (quicksort-body vector aref predicate key sequence 0 end) 439 (quicksort-body vector aref predicate nil sequence 0 end)))) 440 sequence) 441 (t (e) 442 (warn "~&New quicksort implementation failed with~&'~A'.~&Trying stable implementation...~&" e) 443 (quick-sort sequence 0 (length sequence) predicate key)))) 444 445;;; DEPRECATED -- to be removed in abcl-1.4 446;;; From ECL. 447;;; Alternative implementation for quick-sort SORT 448(defun quick-sort (seq start end pred key) 449 (unless key (setq key #'identity)) 450 (if (<= end (1+ start)) 451 seq 452 (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) 453 (block outer-loop 454 (loop (loop (decf k) 455 (unless (< j k) (return-from outer-loop)) 456 (when (funcall pred (funcall key (elt seq k)) kd) 457 (return))) 458 (loop (incf j) 459 (unless (< j k) (return-from outer-loop)) 460 (unless (funcall pred (funcall key (elt seq j)) kd) 461 (return))) 462 (let ((temp (elt seq j))) 463 (setf (elt seq j) (elt seq k) 464 (elt seq k) temp)))) 465 (setf (elt seq start) (elt seq j) 466 (elt seq j) d) 467 (quick-sort seq start j pred key) 468 (quick-sort seq (1+ j) end pred key)))) 469 470;;; 471;;; main SORT and STABLE-SORT function calls 472;;; 473;;; - sort: quicksort and merge sort (only for lists) 474;;; - stable-sort: merge sort (all types) 475;;; 476 477(defun sort (sequence predicate &rest args &key key) 478 (sequence::seq-dispatch sequence 479 (sort-list sequence predicate key) 480 (quicksort sequence predicate key) 481 (apply #'sequence:sort sequence predicate args))) 482 483(defun stable-sort (sequence predicate &rest args &key key) 484 (sequence::seq-dispatch sequence 485 (sort-list sequence predicate key) 486 (merge-sort-vectors sequence predicate key) 487 (apply #'sequence:stable-sort sequence predicate args))) 488