#| -*-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
\f
;; Functional and unstable
-(define (sort obj pred)
+(define (merge-sort obj pred)
(define (loop l)
(if (and (pair? l) (pair? (cdr l)))
(split l '() '())
(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)))
(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))))
-\f
+ (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
#| -*-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
(declare (usual-integrations))
\f
-(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)
(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
projects / mit-scheme.git / commitdiff