From: Chris Hanson Date: Thu, 30 Apr 1998 18:06:04 +0000 (+0000) Subject: Change sort routines so that both merge and quick sort can be loaded X-Git-Tag: 20090517-FFI~4806 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=701025c88aa71c651b90b52081224b711d461de8;p=mit-scheme.git Change sort routines so that both merge and quick sort can be loaded at the same time. As before, SORT and SORT! default to merge sort. --- diff --git a/v7/src/runtime/msort.scm b/v7/src/runtime/msort.scm index 4a7bde009..21b762c06 100644 --- a/v7/src/runtime/msort.scm +++ b/v7/src/runtime/msort.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: msort.scm,v 14.4 1996/12/04 16:21:42 adams Exp $ +$Id: msort.scm,v 14.5 1998/04/30 18:05:04 cph Exp $ -Copyright (c) 1988-1996 Massachusetts Institute of Technology +Copyright (c) 1988-98 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,7 +39,7 @@ MIT in each case. |# ;; Functional and unstable -(define (sort obj pred) +(define (merge-sort obj pred) (define (loop l) (if (and (pair? l) (pair? (cdr l))) (split l '() '()) @@ -48,10 +48,13 @@ MIT in each case. |# (define (split l one two) (if (pair? l) (split (cdr l) two (cons (car l) one)) - (merge (loop one) (loop two)))) + (begin + (if (not (null? l)) (lose)) + (merge (loop one) (loop two))))) (define (merge one two) - (cond ((null? one) two) + (cond ((null? one) + two) ((pred (car two) (car one)) (cons (car two) (merge (cdr two) one))) @@ -59,52 +62,54 @@ MIT in each case. |# (cons (car one) (merge (cdr one) two))))) - (cond ((pair? obj) - (if (null? (cdr obj)) - (list (car obj)) ; must return newly allocated list - (loop obj))) - ((vector? obj) - (sort! (vector-copy obj) pred)) - ((null? obj) - '()) - (else - (error:wrong-type-argument obj "list or vector" 'SORT)))) - + (define (lose) + (error:wrong-type-argument obj "list or vector" 'MERGE-SORT)) + + (if (vector? obj) + (merge-sort! (vector-copy obj) pred) + (begin + (if (pair? obj) + (if (pair? (cdr obj)) + (loop obj) + (begin + (if (not (null? (cdr obj))) (lose)) + ;; Must return newly allocated list. + (list (car obj)))) + (begin + (if (not (null? obj)) (lose)) + '()))))) + ;; This merge sort is stable for partial orders (for predicates like ;; <=, rather than like <). -(define (sort! v pred) - - (define-integrable < fix:<) - (define-integrable > fix:>) - (define-integrable 1+ fix:1+) - (define-integrable + fix:+) - +(define (merge-sort! v pred) (define (sort-internal! vec temp low high) - (if (< low high) - (let* ((middle (quotient (+ low high) 2)) - (next (1+ middle))) + (if (fix:< low high) + (let* ((middle (quotient (fix:+ low high) 2)) + (next (fix:+ middle 1))) (sort-internal! temp vec low middle) (sort-internal! temp vec next high) (let loop ((p low) (p1 low) (p2 next)) - (if (not (> p high)) - (cond ((> p1 middle) + (if (not (fix:> p high)) + (cond ((fix:> p1 middle) (vector-set! vec p (vector-ref temp p2)) - (loop (1+ p) p1 (1+ p2))) - ((or (> p2 high) + (loop (fix:+ p 1) p1 (fix:+ p2 1))) + ((or (fix:> p2 high) (pred (vector-ref temp p1) (vector-ref temp p2))) (vector-set! vec p (vector-ref temp p1)) - (loop (1+ p) (1+ p1) p2)) + (loop (fix:+ p 1) (fix:+ p1 1) p2)) (else (vector-set! vec p (vector-ref temp p2)) - (loop (1+ p) p1 (1+ p2))))))))) + (loop (fix:+ p 1) p1 (fix:+ p2 1))))))))) (if (not (vector? v)) - (error:wrong-type-argument v "vector" 'SORT!)) - + (error:wrong-type-argument v "vector" 'MERGE-SORT!)) (sort-internal! v (vector-copy v) 0 - (-1+ (vector-length v))) - v) \ No newline at end of file + (fix:- (vector-length v) 1)) + v) + +(define sort merge-sort) +(define sort! merge-sort!) \ No newline at end of file diff --git a/v7/src/runtime/qsort.scm b/v7/src/runtime/qsort.scm index 054cde99c..372d5a0a4 100644 --- a/v7/src/runtime/qsort.scm +++ b/v7/src/runtime/qsort.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: qsort.scm,v 14.2 1996/12/01 17:20:23 adams Exp $ +$Id: qsort.scm,v 14.3 1998/04/30 18:05:09 cph Exp $ -Copyright (c) 1988-1996 Massachusetts Institute of Technology +Copyright (c) 1988-98 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,44 +37,45 @@ MIT in each case. |# (declare (usual-integrations)) -(define (sort vector predicate) +(define (quick-sort vector predicate) (if (vector? vector) - (sort! (vector-copy vector) predicate) - (vector->list (sort! (list->vector vector) predicate)))) - -(define (sort! vector predicate) + (quick-sort! (vector-copy vector) predicate) + (vector->list (quick-sort! (list->vector vector) predicate)))) +(define (quick-sort! vector predicate) (define (outer-loop l r) - (if (> r l) - (if (= r (1+ l)) + (if (fix:> r l) + (if (fix:= r (fix:+ l 1)) (if (predicate (vector-ref vector r) (vector-ref vector l)) (exchange! l r)) (let ((lth-element (vector-ref vector l))) (define (increase-i i) - (if (or (> i r) + (if (or (fix:> i r) (predicate lth-element (vector-ref vector i))) i - (increase-i (1+ i)))) + (increase-i (fix:+ i 1)))) (define (decrease-j j) - (if (or (<= j l) + (if (or (fix:<= j l) (not (predicate lth-element (vector-ref vector j)))) j - (decrease-j (-1+ j)))) + (decrease-j (fix:- j 1)))) (define (inner-loop i j) - (if (< i j) ;used to be <= - (begin (exchange! i j) - (inner-loop (increase-i (1+ i)) - (decrease-j (-1+ j)))) - (begin (if (> j l) - (exchange! j l)) - (outer-loop (1+ j) r) - (outer-loop l (-1+ j))))) - - (inner-loop (increase-i (1+ l)) + (if (fix:< i j) ;used to be <= + (begin + (exchange! i j) + (inner-loop (increase-i (fix:+ i 1)) + (decrease-j (fix:- j 1)))) + (begin + (if (fix:> j l) + (exchange! j l)) + (outer-loop (fix:+ j 1) r) + (outer-loop l (fix:- j 1))))) + + (inner-loop (increase-i (fix:+ l 1)) (decrease-j r)))))) (define-integrable (exchange! i j) @@ -83,6 +84,6 @@ MIT in each case. |# (vector-set! vector j ith-element))) (if (not (vector? vector)) - (error:wrong-type-argument vector "vector" 'SORT!)) - (outer-loop 0 (-1+ (vector-length vector))) + (error:wrong-type-argument vector "vector" 'QUICK-SORT!)) + (outer-loop 0 (fix:- (vector-length vector) 1)) vector) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 79af2341b..c1d04c0d4 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.296 1998/04/01 08:16:15 cph Exp $ +$Id: runtime.pkg,v 14.297 1998/04/30 18:06:04 cph Exp $ Copyright (c) 1988-98 Massachusetts Institute of Technology @@ -43,15 +43,13 @@ MIT in each case. |# "fixart" "global" "lambdx" + "msort" + "qsort" "queue" "sfile" "symbol" "udata" "vector") - (file-case sort-type - ((merge-sort) "msort") - ;;((quick-sort) "qsort") - (else)) (file-case os-type ((unix) "unxprm") ((dos) "dosprm") diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 822807a5a..4d022d052 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.302 1998/04/01 08:16:07 cph Exp $ +$Id: runtime.pkg,v 14.303 1998/04/30 18:05:39 cph Exp $ Copyright (c) 1988-98 Massachusetts Institute of Technology @@ -43,15 +43,13 @@ MIT in each case. |# "fixart" "global" "lambdx" + "msort" + "qsort" "queue" "sfile" "symbol" "udata" "vector") - (file-case sort-type - ((merge-sort) "msort") - ;;((quick-sort) "qsort") - (else)) (file-case os-type ((unix) "unxprm") ((dos) "dosprm")