From 6744633338c1c6475dd7e9f0a9d4cd0ab52db031 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 30 Mar 2006 09:39:30 +0000 Subject: [PATCH] Moved (and improved) sort! etc from Swindle to mzlib/list.ss * Expose sort!, merge! and merge, since they're also useful * Made `mergesort' be an alias for `sort'. * Removed it all from Swindle * Removed `sort' from compat.ss * Needed to adjust a few other files, no problems but graphics/value-turtles provides its own version of `merge' svn: r2542 --- collects/graphics/value-turtles.ss | 4 +- collects/mzlib/compat.ss | 10 +- collects/mzlib/integer-set.ss | 2 +- collects/mzlib/list.ss | 204 ++++++++++++++++++++--------- collects/profj/types.ss | 11 +- collects/swindle/misc.ss | 124 ------------------ 6 files changed, 152 insertions(+), 203 deletions(-) diff --git a/collects/graphics/value-turtles.ss b/collects/graphics/value-turtles.ss index 14f72b3c4b..d4ff80e851 100644 --- a/collects/graphics/value-turtles.ss +++ b/collects/graphics/value-turtles.ss @@ -2,7 +2,7 @@ (require (lib "math.ss") (lib "class.ss") (lib "mred.ss" "mred") - (lib "list.ss") + (all-except (lib "list.ss") merge) (lib "struct.ss")) (provide turtles move draw turn turn/radians merge clean) @@ -347,4 +347,4 @@ (define (clean tv) (send tv clean-op)) (set! saved-turtle-snip% turtle-snip%) - (set! saved-turtles turtles)) \ No newline at end of file + (set! saved-turtles turtles)) diff --git a/collects/mzlib/compat.ss b/collects/mzlib/compat.ss index 3cb804f6c9..308a634bed 100644 --- a/collects/mzlib/compat.ss +++ b/collects/mzlib/compat.ss @@ -1,21 +1,19 @@ (module compat mzscheme - (require "list.ss") (provide real-time 1+ 1- >=? <=? >? ? >) @@ -26,10 +24,6 @@ (define gentemp gensym) - (define sort ; Chez argument order - (lambda (less-than? l) - (mergesort l less-than?))) - (define flush-output-port flush-output) (define real-time current-milliseconds) diff --git a/collects/mzlib/integer-set.ss b/collects/mzlib/integer-set.ss index 96b0668ade..d0a0256ef8 100644 --- a/collects/mzlib/integer-set.ss +++ b/collects/mzlib/integer-set.ss @@ -1,5 +1,5 @@ (module integer-set mzscheme - (require (lib "list.ss") + (require (all-except (lib "list.ss") merge) (lib "contract.ss")) #;(define-syntax test-block diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss index a95ce77026..47d3e6f594 100644 --- a/collects/mzlib/list.ss +++ b/collects/mzlib/list.ss @@ -3,42 +3,150 @@ (require "spidey.ss") (provide set-first! - first - second - third - fourth - fifth - sixth - seventh - eighth + first + second + third + fourth + fifth + sixth + seventh + eighth - set-rest! - rest + set-rest! + rest - cons? - empty - empty? + cons? + empty + empty? - foldl - foldr + foldl + foldr - last-pair + last-pair - remv - remq - remove - remv* - remq* - remove* + remv + remq + remove + remv* + remq* + remove* - assf - memf + assf + memf - filter - - quicksort - mergesort) - + filter + + quicksort + mergesort + sort + sort! + merge + merge!) + + ;; used by sort-internal, but can be useful by itself + (define (merge! a b less?) + (define (loop r a b) + (if (less? (car b) (car a)) + (begin (set-cdr! r b) + (if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b)))) + ;; (car a) <= (car b) + (begin (set-cdr! r a) + (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b))))) + (cond [(null? a) b] + [(null? b) a] + [(less? (car b) (car a)) + (if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b))) + b] + [else ; (car a) <= (car b) + (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b)) + a])) + ;; a non-destructive version for symmetry with merge! + (define (merge a b less?) + (cond [(null? a) b] + [(null? b) a] + [else (let loop ([x (car a)] [a (cdr a)] [y (car b)] [b (cdr b)]) + ;; The loop handles the merging of non-empty lists. It has + ;; been written this way to save testing and car/cdring. + (if (less? y x) + (if (null? b) + (list* y x a) + (cons y (loop x a (car b) (cdr b)))) + ;; x <= y + (if (null? a) + (list* x y b) + (cons x (loop (car a) (cdr a) y b)))))])) + + ;; This is a destructive stable merge-sort, adapted from slib and improved by + ;; Eli Barzilay + ;; The original source said: + ;; It uses a version of merge-sort invented, to the best of my knowledge, + ;; by David H. D. Warren, and first used in the DEC-10 Prolog system. + ;; R. A. O'Keefe adapted it to work destructively in Scheme. + ;; but it's a plain destructive merge sort. + (define (sort-internal lst less? copy? who) + (define (step n) + (cond [(> n 3) (let* (; let* not really needed with mzscheme's l->r eval + [j (quotient n 2)] [a (step j)] [b (step (- n j))]) + (merge! a b less?))] + ;; the following two cases are just explicit treatment of sublists + ;; of length 2 and 3, could remove both (and use the above case for + ;; n>1) and it would still work, except a little slower + [(= n 3) (let ([p lst] [p1 (cdr lst)] [p2 (cddr lst)]) + (let ([x (car p)] [y (car p1)] [z (car p2)]) + (set! lst (cdr p2)) + (cond [(less? y x) ; y x + (cond [(less? z y) ; z y x + (set-car! p z) + (set-car! p1 y) + (set-car! p2 x)] + [(less? z x) ; y z x + (set-car! p y) + (set-car! p1 z) + (set-car! p2 x)] + [else ; y x z + (set-car! p y) + (set-car! p1 x)])] + [(less? z x) ; z x y + (set-car! p z) + (set-car! p1 x) + (set-car! p2 y)] + [(less? z y) ; x z y + (set-car! p1 z) + (set-car! p2 y)]) + (set-cdr! p2 '()) + p))] + [(= n 2) (let ([x (car lst)] [y (cadr lst)] [p lst]) + (set! lst (cddr lst)) + (when (less? y x) (set-car! p y) (set-car! (cdr p) x)) + (set-cdr! (cdr p) '()) + p)] + [(= n 1) (let ([p lst]) + (set! lst (cdr lst)) + (set-cdr! p '()) + p)] + [else '()])) + (unless (list? lst) + (raise-type-error who "proper list" lst)) + (unless (procedure-arity-includes? less? 2) + (raise-type-error who "procedure of arity 2" less?)) + (let ([n (length lst)]) + (cond [(<= n 1) lst] + ;; check if the list is already sorted + ;; (which can be a common case, eg, directory lists). + [(let loop ([last (car lst)] [next (cdr lst)]) + (or (null? next) + (and (not (less? (car next) last)) + (loop (car next) (cdr next))))) + lst] + [else (when copy? (set! lst (append lst '()))) + (step n)]))) + + (define (sort! lst less?) + (sort-internal lst less? #f 'sort!)) + (define (sort lst less?) + (sort-internal lst less? #t 'sort)) + + ;; deprecated! (define quicksort (polymorphic (lambda (l less-than) @@ -68,34 +176,8 @@ (loop pivot max)))))))) (vector->list v))))) - (define mergesort - (polymorphic - (lambda (alox less-than) - (letrec ([split (lambda (alox r) - (cond - [(null? alox) r] - [(null? (cdr alox)) (cons alox r)] - [else (split (cdr alox) (cons (list (car alox)) r))]))] - [merge (lambda (l1 l2 r) - (cond - [(null? l1) (append! (reverse! r) l2)] - [(null? l2) (append! (reverse! r) l1)] - [(less-than (car l1) (car l2)) - (merge (cdr l1) l2 (cons (car l1) r))] - [else (merge (cdr l2) l1 (cons (car l2) r))]))] - [map2 (lambda (l) - (cond - [(null? l) '()] - [(null? (cdr l)) l] - [else (cons (merge (car l) (cadr l) null) - (map2 (cddr l)))]))] - [until (lambda (l) - (if (null? (cdr l)) - (car l) - (until (map2 l))))]) - (if (null? alox) - null - (until (split alox null))))))) + ;; deprecated! + (define mergesort sort) (define remove (polymorphic @@ -109,17 +191,17 @@ [else (cons (car list) (loop (cdr list)))]))])]) rm))) - + (define remq (polymorphic (lambda (item list) (remove item list eq?)))) - + (define remv (polymorphic (lambda (item list) (remove item list eqv?)))) - + (define remove* (polymorphic (case-lambda @@ -133,7 +215,7 @@ [(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)] [else (loop (cdr l-rest))])))])] [(l r) (remove* l r equal?)]))) - + (define remq* (polymorphic (lambda (l r) diff --git a/collects/profj/types.ss b/collects/profj/types.ss index e855a7e90b..4844be0715 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -8,7 +8,7 @@ (lib "class.ss") "ast.ss") - (provide (all-defined-except sort number-assign-conversions remove-dups meth-member? + (provide (all-defined-except number-assign-conversions remove-dups meth-member? generate-require-spec)) ;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int @@ -616,10 +616,6 @@ (method-record-atypes (car methods))) (meth-member? meth (cdr methods))))) - ;sort: (list number) -> (list number) - (define (sort l) - (quicksort l (lambda (i1 i2) (< (car i1) (car i2))))) - ;number-assign-conversion: (list type) (list type) type-records -> int (define (number-assign-conversions site-args method-args type-recs) (cond @@ -641,11 +637,12 @@ (assignable (filter (lambda (mr) (andmap a-convert? (m-atypes mr) arg-types)) methods)) - (assignable-count (sort + (assignable-count (sort (map (lambda (mr) (list (number-assign-conversions arg-types (m-atypes mr) type-recs) mr)) - assignable)))) + assignable) + (lambda (i1 i2) (< (car i1) (car i2)))))) (cond ((null? methods) (arg-count-fail)) ((= 1 (length methods-same)) (car methods-same)) diff --git a/collects/swindle/misc.ss b/collects/swindle/misc.ss index 0bd498c8cd..000d69998f 100644 --- a/collects/swindle/misc.ss +++ b/collects/swindle/misc.ss @@ -1882,128 +1882,4 @@ [(_ str clause ...) #`(let ([s str]) (cond #,@(do-clauses #'(clause ...))))])) -;; ---------------------------------------------------------------------------- -;; Taken from slib (faster than then quicksort and mergesort in list.ss). -;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort! -;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) - -;;>>... Sorting -;;> The following section defines functions for sorting. They are taken -;;> directly from slib since they are more convenient and faster than the -;;> functions in mzlib/list. See the source for more details. - -;;>> (sorted? sequence less?) -;;> True when `sequence' is a list (x0 x1 ... xm) or a vector #(x0 ... xm) -;;> such that its elements are sorted according to `less?': -;;> (not (less? (list-ref list i) (list-ref list (- i 1)))). -(define* (sorted? seq less?) - (cond [(null? seq) #t] - [(vector? seq) - (let ([n (vector-length seq)]) - (if (<= n 1) - #t - (do ([i 1 (+ i 1)]) - [(or (= i n) - (less? (vector-ref seq i) (vector-ref seq (- i 1)))) - (= i n)])))] - [else - (let loop ([last (car seq)] [next (cdr seq)]) - (or (null? next) - (and (not (less? (car next) last)) - (loop (car next) (cdr next)))))])) - -;;>> (merge a b less?) -;;> Takes two lists `a' and `b' such that both (sorted? a less?) and -;;> (sorted? b less?) are true, and returns a new list in which the -;;> elements of `a' and `b' have been stably interleaved so that (sorted? -;;> (merge a b less?) less?) is true. Note: this does not accept vectors. -(define* (merge a b less?) - (cond [(null? a) b] - [(null? b) a] - [else (let loop ([x (car a)] [a (cdr a)] [y (car b)] [b (cdr b)]) - ;; The loop handles the merging of non-empty lists. It has - ;; been written this way to save testing and car/cdring. - (if (less? y x) - (if (null? b) - (cons y (cons x a)) - (cons y (loop x a (car b) (cdr b)))) - ;; x <= y - (if (null? a) - (cons x (cons y b)) - (cons x (loop (car a) (cdr a) y b)))))])) - -;;>> (merge! a b less?) -;;> Takes two sorted lists `a' and `b' and smashes their cdr fields to -;;> form a single sorted list including the elements of both. Note: this -;;> does not accept vectors. -(define* (merge! a b less?) - (define (loop r a b) - (if (less? (car b) (car a)) - (begin (set-cdr! r b) - (if (null? (cdr b)) - (set-cdr! b a) - (loop b a (cdr b)))) - ;; (car a) <= (car b) - (begin (set-cdr! r a) - (if (null? (cdr a)) - (set-cdr! a b) - (loop a (cdr a) b))))) - (cond [(null? a) b] - [(null? b) a] - [(less? (car b) (car a)) - (if (null? (cdr b)) - (set-cdr! b a) - (loop b a (cdr b))) - b] - [else ; (car a) <= (car b) - (if (null? (cdr a)) - (set-cdr! a b) - (loop a (cdr a) b)) - a])) - -;;>> (sort! sequence less?) -;;> Sorts the list or vector `sequence' destructively. -;; It uses a version of merge-sort invented, to the best of my knowledge, by -;; David H. D. Warren, and first used in the DEC-10 Prolog system. -;; R. A. O'Keefe adapted it to work destructively in Scheme. -(define* (sort! seq less?) - (define (step n) - (cond [(> n 2) (let* ([j (quotient n 2)] - [a (step j)] - [k (- n j)] - [b (step k)]) - (merge! a b less?))] - [(= n 2) (let ([x (car seq)] - [y (cadr seq)] - [p seq]) - (set! seq (cddr seq)) - (when (less? y x) - (set-car! p y) (set-car! (cdr p) x)) - (set-cdr! (cdr p) '()) - p)] - [(= n 1) (let ([p seq]) - (set! seq (cdr seq)) - (set-cdr! p '()) - p)] - [else '()])) - (if (vector? seq) - (let ([n (vector-length seq)] [vec seq]) - (set! seq (vector->list seq)) - (do ([p (step n) (cdr p)] [i 0 (+ i 1)]) - [(null? p) vec] - (vector-set! vec i (car p)))) - ;; otherwise, assume it is a list - (step (length seq)))) - -;;>> (sort sequence less?) -;;> Sorts a vector or list non-destructively. It does this by sorting a -;;> copy of the sequence. -;; My understanding is that the Standard says that the result of append is -;; always "newly allocated" except for sharing structure with "the last -;; argument", so (append x '()) ought to be a standard way of copying a list x. -(define* (sort seq less?) - (if (vector? seq) - (list->vector (sort! (vector->list seq) less?)) - (sort! (append seq '()) less?))) - )