diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index 9d716760c3..1f8c641d0b 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -25,25 +25,6 @@ compose) - ;; used by sort-internal; note that a and b are reversed, to we invert `less?' - ;; test - (define (merge-sorted-lists! a b less?) - (define (loop r a b r-a?) ; r-a? for optimization -- is r connected to a? - (if (not (less? (mcar b) (mcar a))) - (begin (when r-a? (set-mcdr! r b)) - (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))) - ;; (car a) <= (car b) - (begin (unless r-a? (set-mcdr! r a)) - (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))))) - (cond [(null? a) b] - [(null? b) a] - [(not (less? (mcar b) (mcar a))) - (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)) - b] - [else ; (car a) <= (car b) - (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)) - a])) - ;; This is a destructive stable merge-sort, adapted from slib and improved by ;; Eli Barzilay ;; The original source said: @@ -51,97 +32,135 @@ ;; 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) - ;; lst is actually reversed when we get here, so all the `less?' - ;; tests are surrounded by `not': + (define (sort-internal lst less? n) + (define (merge-sorted! a b) + (define (loop r a b r-a?) ; r-a? for optimization -- is r connected to a? + (if (less? (mcar b) (mcar a)) + (begin (when r-a? (set-mcdr! r b)) + (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))) + ;; (car a) <= (car b) + (begin (unless r-a? (set-mcdr! r a)) + (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))))) + (cond [(null? a) b] + [(null? b) a] + [(less? (mcar b) (mcar a)) + (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)) + b] + [else ; (car a) <= (car b) + (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)) + a])) + (let step ([n 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-sorted-lists! a b less?))] + (merge-sorted! 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 (mcdr lst)] [p2 (mcdr (mcdr lst))]) (let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)]) (set! lst (mcdr p2)) - (cond [(not (less? y x)) ; y x - (cond [(not (less? z y)) ; z y x + (cond [(less? y x) ; y x + (cond [(less? z y) ; z y x (set-mcar! p z) (set-mcar! p1 y) (set-mcar! p2 x)] - [(not (less? z x)) ; y z x + [(less? z x) ; y z x (set-mcar! p y) (set-mcar! p1 z) (set-mcar! p2 x)] [else ; y x z (set-mcar! p y) (set-mcar! p1 x)])] - [(not (less? z x)) ; z x y + [(less? z x) ; z x y (set-mcar! p z) (set-mcar! p1 x) (set-mcar! p2 y)] - [(not (less? z y)) ; x z y + [(less? z y) ; x z y (set-mcar! p1 z) (set-mcar! p2 y)]) (set-mcdr! p2 '()) p))] [(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst]) (set! lst (mcdr (mcdr lst))) - (when (not (less? y x)) (set-mcar! p y) (set-mcar! (mcdr p) x)) + (when (less? y x) (set-mcar! p y) (set-mcar! (mcdr p) x)) (set-mcdr! (mcdr p) '()) p)] [(= n 1) (let ([p lst]) (set! lst (mcdr lst)) (set-mcdr! p '()) p)] - [else '()])) + [else '()]))) + (define (sort lst less?) (unless (list? lst) (raise-type-error 'sort "proper list" lst)) (unless (and (procedure? less?) (procedure-arity-includes? less? 2)) (raise-type-error 'sort "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 (set! lst - ;; copy + reverse the list: - (let loop ([lst lst][a null]) - (if (null? lst) - a - (loop (cdr lst) - (mcons (car lst) a))))) - ;; Sort: - (let ([r (step n)]) - ;; copy + reverse the result: - (let loop ([r r][a null]) - (if (null? r) - a - (loop (mcdr r) (cons (mcar r) a)))))]))) - - (define (sort lst less?) (sort-internal lst less? #t 'sort)) + (cond + ;; trivial case + [(< n 2) 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] + ;; inlined cases, for optimization of short lists + [(< n 3) + (if (= n 2) + ;; (because of the above test, we can assume that the input is + ;; unsorted) + (list (cadr lst) (car lst)) + (let ([a (car lst)] [b (cadr lst)] [c (caddr lst)]) + ;; General note: we need a stable sort, so we should always + ;; compare (less? later-item earlier-item) since it gives more + ;; information. A good way to see that we have good code is to + ;; check that each permutation appears exactly once. This means + ;; that n=4 will have 23 cases, so don't bother. (Homework: write + ;; a macro to generate code for a specific N. Bonus: prove + ;; correctness. Extra bonus: prove optimal solution. Extra extra + ;; bonus: prove optimal solution exists, extract macro from + ;; proof.) + (let ([a (car lst)] [b (cadr lst)] [c (caddr lst)]) + (if (less? b a) + ;; bmlist + [mlst (let ([mlst (mcons (car lst) null)]) + (let loop ([last mlst] [lst (cdr lst)]) + (if (null? lst) + mlst + (let ([new (mcons (car lst) null)]) + (set-mcdr! last new) + (loop new (cdr lst))))))]) + ;; mlist->list + (let loop ([r (sort-internal mlst less? n)]) + (if (null? r) + r + (cons (mcar r) (loop (mcdr r))))))]))) (define (do-remove who item list equal?) (unless (list? list) (raise-type-error who "list" list)) (let loop ([list list]) - (cond - [(null? list) null] - [(equal? item (car list)) (cdr list)] - [else (cons (car list) (loop (cdr list)))]))) + (cond [(null? list) null] + [(equal? item (car list)) (cdr list)] + [else (cons (car list) (loop (cdr list)))]))) (define remove - (case-lambda - [(item list) (do-remove 'remove item list equal?)] - [(item list equal?) - (unless (and (procedure? equal?) - (procedure-arity-includes? equal? 2)) - (raise-type-error 'remove "procedure (arity 2)" equal?)) - (do-remove 'remove item list equal?)])) + (case-lambda + [(item list) (do-remove 'remove item list equal?)] + [(item list equal?) + (unless (and (procedure? equal?) + (procedure-arity-includes? equal? 2)) + (raise-type-error 'remove "procedure (arity 2)" equal?)) + (do-remove 'remove item list equal?)])) (define (remq item list) (do-remove 'remq item list eq?)) @@ -156,18 +175,18 @@ (raise-type-error who "list" r)) (let rloop ([r r]) (cond - [(null? r) null] - [else (let ([first-r (car r)]) - (let loop ([l-rest l]) - (cond - [(null? l-rest) (cons first-r (rloop (cdr r)))] - [(equal? (car l-rest) first-r) (rloop (cdr r))] - [else (loop (cdr l-rest))])))]))) - + [(null? r) null] + [else (let ([first-r (car r)]) + (let loop ([l-rest l]) + (cond + [(null? l-rest) (cons first-r (rloop (cdr r)))] + [(equal? (car l-rest) first-r) (rloop (cdr r))] + [else (loop (cdr l-rest))])))]))) + (define remove* (case-lambda [(l r) (do-remove* 'remove* l r equal?)] - [(l r equal?) + [(l r equal?) (unless (and (procedure? equal?) (procedure-arity-includes? equal? 2)) (raise-type-error 'remove* "procedure (arity 2)" equal?)) diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss index d9776b8c7c..a2cd6a3c96 100644 --- a/collects/tests/mzscheme/function.ss +++ b/collects/tests/mzscheme/function.ss @@ -67,27 +67,46 @@ '("d" "f" "e" "c" "a" "c" "b") string