Changeset 13873
 Timestamp:
 02/13/12 10:02:35 (9 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/sort.lisp
r13870 r13873 305 305 (if (eq list1 (cdr head)) 306 306 (return list1)))))) 307 307 ;;; 308 ;;; MERGE 309 ;;; 310 311 ;;; From ECL. Should already be userextensible as it does no type dispatch 312 ;;; and uses only userextensible functions. 313 (defun merge (resulttype sequence1 sequence2 predicate 314 &key key 315 &aux (l1 (length sequence1)) (l2 (length sequence2))) 316 (unless key (setq key #'identity)) 317 (do ((newseq (makesequence resulttype (+ l1 l2))) 318 (j 0 (1+ j)) 319 (i1 0) 320 (i2 0)) 321 ((and (= i1 l1) (= i2 l2)) newseq) 322 (cond ((and (< i1 l1) (< i2 l2)) 323 (cond ((funcall predicate 324 (funcall key (elt sequence1 i1)) 325 (funcall key (elt sequence2 i2))) 326 (setf (elt newseq j) (elt sequence1 i1)) 327 (incf i1)) 328 ((funcall predicate 329 (funcall key (elt sequence2 i2)) 330 (funcall key (elt sequence1 i1))) 331 (setf (elt newseq j) (elt sequence2 i2)) 332 (incf i2)) 333 (t 334 (setf (elt newseq j) (elt sequence1 i1)) 335 (incf i1)))) 336 ((< i1 l1) 337 (setf (elt newseq j) (elt sequence1 i1)) 338 (incf i1)) 339 (t 340 (setf (elt newseq j) (elt sequence2 i2)) 341 (incf i2))))) 308 342 309 343 ;;; … … 377 411 378 412 (defun quicksort (sequence predicate key) 379 (let ((end (1 (length sequence)))) 380 (typecase sequence 381 (simplevector 382 (if key 383 (quicksortbody simplevector svref predicate key sequence 0 end) 384 (quicksortbody simplevector svref predicate nil sequence 0 end))) 385 (vector 386 (if key 387 (quicksortbody vector aref predicate key sequence 0 end) 388 (quicksortbody vector aref predicate nil sequence 0 end)))) 389 sequence)) 390 413 (handlercase 414 (let ((end (1 (length sequence)))) 415 (typecase sequence 416 (simplevector 417 (if key 418 (quicksortbody simplevector svref predicate key sequence 0 end) 419 (quicksortbody simplevector svref predicate nil sequence 0 end))) 420 (vector 421 (if key 422 (quicksortbody vector aref predicate key sequence 0 end) 423 (quicksortbody vector aref predicate nil sequence 0 end)))) 424 sequence) 425 (t (e) 426 (warn "~&New quicksort implementation failed with~&'~A'.~&Trying stable implementation...~&" e) 427 (quicksort sequence 0 (length sequence) predicate key)))) 428 429 ;;; DEPRECATED  to be removed in abcl1.4 430 ;;; From ECL. 431 ;;; Alternative implementation for quicksort SORT 432 (defun quicksort (seq start end pred key) 433 (unless key (setq key #'identity)) 434 (if (<= end (1+ start)) 435 seq 436 (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) 437 (block outerloop 438 (loop (loop (decf k) 439 (unless (< j k) (returnfrom outerloop)) 440 (when (funcall pred (funcall key (elt seq k)) kd) 441 (return))) 442 (loop (incf j) 443 (unless (< j k) (returnfrom outerloop)) 444 (unless (funcall pred (funcall key (elt seq j)) kd) 445 (return))) 446 (let ((temp (elt seq j))) 447 (setf (elt seq j) (elt seq k) 448 (elt seq k) temp)))) 449 (setf (elt seq start) (elt seq j) 450 (elt seq j) d) 451 (quicksort seq start j pred key) 452 (quicksort seq (1+ j) end pred key)))) 391 453 392 454 ;;;
Note: See TracChangeset
for help on using the changeset viewer.