From: Chris Hanson <org/chris-hanson/cph>
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")