From 5c00b6def9576d61e9c8d5bc7c3fcd0c9c4b5ca1 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 16 Mar 2000 17:09:11 +0000 Subject: [PATCH] Change implementation of MERGE-SORT (and therefore SORT) so that it uses the in-place vector-sorting algorithm for lists. The previous algorithm created a stack of depth (/ (LENGTH L) 2), which made it impossible to use for large lists. This algorithm creates a stack of depth (/ (LOG (LENGTH L)) (LOG 2)). Additionally, tweaked the vector-sorting algorithm to use indexes in a slightly more efficient (and clearer) way. --- v7/src/runtime/msort.scm | 95 ++++++++++++---------------------------- 1 file changed, 29 insertions(+), 66 deletions(-) diff --git a/v7/src/runtime/msort.scm b/v7/src/runtime/msort.scm index 58e9651e5..370955acf 100644 --- a/v7/src/runtime/msort.scm +++ b/v7/src/runtime/msort.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: msort.scm,v 14.6 1999/01/02 06:11:34 cph Exp $ +$Id: msort.scm,v 14.7 2000/03/16 17:09:11 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-2000 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -24,78 +24,41 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) -;; Functional and unstable +;; This merge sort is stable for partial orders (for predicates like +;; <=, rather than like <). (define (merge-sort obj pred) - (define (loop l) - (if (and (pair? l) (pair? (cdr l))) - (split l '() '()) - l)) - - (define (split l one two) - (if (pair? l) - (split (cdr l) two (cons (car l) one)) - (begin - (if (not (null? l)) (lose)) - (merge (loop one) (loop two))))) - - (define (merge one two) - (cond ((null? one) - two) - ((pred (car two) (car one)) - (cons (car two) - (merge (cdr two) one))) - (else - (cons (car one) - (merge (cdr one) two))))) - - (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 <). + (vector->list (merge-sort! (list->vector obj) pred)))) (define (merge-sort! v pred) - (define (sort-internal! vec temp low high) - (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 (fix:> p high)) - (cond ((fix:> p1 middle) - (vector-set! vec p (vector-ref temp p2)) - (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 (fix:+ p 1) (fix:+ p1 1) p2)) - (else - (vector-set! vec p (vector-ref temp p2)) - (loop (fix:+ p 1) p1 (fix:+ p2 1))))))))) - (if (not (vector? v)) (error:wrong-type-argument v "vector" 'MERGE-SORT!)) - (sort-internal! v - (vector-copy v) - 0 - (fix:- (vector-length v) 1)) + (let sort-subvector + ((v v) + (temp (vector-copy v)) + (low 0) + (high (vector-length v))) + (if (fix:> (fix:- high low) 1) + (let ((middle (fix:quotient (fix:+ low high) 2))) + ;; Sort each half of (V,LOW,HIGH) into the corresponding + ;; half of TEMP. + (sort-subvector temp v low middle) + (sort-subvector temp v middle high) + ;; Merge the two halves of TEMP back into V. + (let merge ((p low) (p1 low) (p2 middle)) + (if (fix:< p high) + (if (and (fix:< p1 middle) + (or (fix:= p2 high) + (pred (vector-ref temp p1) + (vector-ref temp p2)))) + (begin + (vector-set! v p (vector-ref temp p1)) + (merge (fix:+ p 1) (fix:+ p1 1) p2)) + (begin + (vector-set! v p (vector-ref temp p2)) + (merge (fix:+ p 1) p1 (fix:+ p2 1))))))))) v) (define sort merge-sort) -- 2.25.1