diff options
Diffstat (limited to 'sort.scm')
| -rw-r--r-- | sort.scm | 76 |
1 files changed, 48 insertions, 28 deletions
@@ -8,15 +8,31 @@ ;;; Updated: 19 June 1995 ;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09 ;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04 +;;; jaffer: 2006-10-08: +;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument. (require 'array) +(define (rank-1-array->list array) + (define dimensions (array-dimensions array)) + (do ((idx (+ -1 (car dimensions)) (+ -1 idx)) + (lst '() (cons (array-ref array idx) lst))) + ((< idx 0) lst))) + +(define (sort:make-predicate caller less? opt-key) + (case (length opt-key) + ((0) less?) + ((1) (let ((key (car opt-key))) + (lambda (a b) (less? (key a) (key b))))) + (else (slib:error caller 'too-many-args (cdr opt-key))))) + ;;; (sorted? sequence less?) ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) ;;; such that for all 1 <= i <= m, ;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). ;@ -(define (sorted? seq less?) +(define (sorted? seq less? . opt-key) + (set! less? (sort:make-predicate 'sorted? less? opt-key)) (cond ((null? seq) #t) ((array? seq) (let ((dims (array-dimensions seq))) @@ -39,7 +55,8 @@ ;;; interleaved so that (sorted? (merge a b less?) less?). ;;; Note: this does _not_ accept arrays. See below. ;@ -(define (merge a b less?) +(define (merge a b less? . opt-key) + (set! less? (sort:make-predicate 'merge less? opt-key)) (cond ((null? a) b) ((null? b) a) (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b))) @@ -54,12 +71,7 @@ (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 arrays. -;@ -(define (merge! a b less?) +(define (sort:merge! a b less?) (define (loop r a b) (if (less? (car b) (car a)) (begin @@ -86,13 +98,15 @@ (loop a (cdr a) b)) a))) -;;; (sort! sequence less?) -;;; sorts the list, array, or string 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. +;;; (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 arrays. ;@ -(define (sort! seq less?) +(define (merge! a b less? . opt-key) + (sort:merge! a b (sort:make-predicate 'merge! less? opt-key))) + +(define (sort:sort! seq less?) (define (step n) (cond ((> n 2) (let* ((j (quotient n 2)) @@ -128,11 +142,23 @@ (else ;; otherwise, assume it is a list (step (length seq))))) -(define (rank-1-array->list array) - (define dimensions (array-dimensions array)) - (do ((idx (+ -1 (car dimensions)) (+ -1 idx)) - (lst '() (cons (array-ref array idx) lst))) - ((< idx 0) lst))) +;;; (sort! sequence less?) +;;; sorts the list, array, or string 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. +;;; A. Jaffer modified to always return the original pair. +;@ +(define (sort! seq less? . opt-key) + (define ret (sort:sort! seq (sort:make-predicate 'sort! less? opt-key))) + (if (not (eq? ret seq)) + (do ((crt ret (cdr crt))) + ((eq? (cdr crt) seq) + (set-cdr! crt ret) + (let ((scar (car seq)) (scdr (cdr seq))) + (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) + (set-car! ret scar) (set-cdr! ret scdr))))) + seq) ;;; (sort sequence less?) ;;; sorts a array, string, or list non-destructively. It does this @@ -141,12 +167,9 @@ ;;; 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?) - (cond ((vector? seq) - (list->vector (sort:sort! (vector->list seq) less?))) - ((string? seq) - (list->string (sort:sort! (string->list seq) less?))) - ((array? seq) +(define (sort seq less? . opt-key) + (set! less? (sort:make-predicate 'sort less? opt-key)) + (cond ((array? seq) (let ((dimensions (array-dimensions seq))) (define newra (apply make-array seq dimensions)) (do ((sorted (sort:sort! (rank-1-array->list seq) less?) @@ -155,6 +178,3 @@ ((null? sorted) newra) (array-set! newra (car sorted) i)))) (else (sort:sort! (append seq '()) less?)))) - -(define sort:merge! merge!) -(define sort:sort! sort!) |