summaryrefslogtreecommitdiffstats
path: root/sort.scm
diff options
context:
space:
mode:
Diffstat (limited to 'sort.scm')
-rw-r--r--sort.scm236
1 files changed, 125 insertions, 111 deletions
diff --git a/sort.scm b/sort.scm
index 1b96e4c..ab5f896 100644
--- a/sort.scm
+++ b/sort.scm
@@ -10,44 +10,38 @@
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; jaffer: 2006-10-08:
;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
+;;; jaffer: 2006-11-05:
+;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
+;;; per element.
+;;; jaffer: 2007-01-29: Final SRFI-95.
(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? . opt-key)
- (set! less? (sort:make-predicate 'sorted? less? opt-key))
+ (define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? seq) #t)
((array? seq)
- (let ((dims (array-dimensions seq)))
- (define dimax (+ -1 (car dims)))
- (or (<= dimax 0)
- (do ((i 1 (+ i 1)))
- ((or (= i dimax)
- (less? (array-ref seq i)
- (array-ref seq (- i 1))))
- (= i dimax))))))
+ (let ((dimax (+ -1 (car (array-dimensions seq)))))
+ (or (<= dimax 1)
+ (let loop ((idx (+ -1 dimax))
+ (last (key (array-ref seq dimax))))
+ (or (negative? idx)
+ (let ((nxt (key (array-ref seq idx))))
+ (and (less? nxt last)
+ (loop (+ -1 idx) nxt))))))))
+ ((null? (cdr seq)) #t)
(else
- (let loop ((last (car seq)) (next (cdr seq)))
+ (let loop ((last (key (car seq)))
+ (next (cdr seq)))
(or (null? next)
- (and (not (less? (car next) last))
- (loop (car next) (cdr next))))))))
+ (let ((nxt (key (car next))))
+ (and (not (less? nxt last))
+ (loop nxt (cdr next)))))))))
;;; (merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
@@ -56,109 +50,129 @@
;;; Note: this does _not_ accept arrays. See below.
;@
(define (merge a b less? . opt-key)
- (set! less? (sort:make-predicate 'merge less? opt-key))
+ (define key (if (null? opt-key) identity (car opt-key)))
(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))))))))
+ (else
+ (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
+ (y (car b)) (ky (key (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? ky kx)
+ (if (null? b)
+ (cons y (cons x a))
+ (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
+ ;; x <= y
+ (if (null? a)
+ (cons x (cons y b))
+ (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
-(define (sort: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)))))
+(define (sort:merge! a b less? key)
+ (define (loop r a kcara b kcarb)
+ (cond ((less? kcarb kcara)
+ (set-cdr! r b)
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a kcara (cdr b) (key (cadr b)))))
+ (else ; (car a) <= (car b)
+ (set-cdr! r a)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) (key (cadr a)) b kcarb)))))
(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)))
+ (else
+ (let ((kcara (key (car a)))
+ (kcarb (key (car b))))
+ (cond
+ ((less? kcarb kcara)
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a kcara (cdr b) (key (cadr b))))
+ b)
+ (else ; (car a) <= (car b)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) (key (cadr a)) b kcarb))
+ a))))))
-;;; (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? . opt-key)
- (sort:merge! a b (sort:make-predicate 'merge! less? opt-key)))
+ (sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
-(define (sort:sort! seq less?)
+(define (sort:sort-list! seq less? key)
+ (define keyer (if key car identity))
(define (step n)
- (cond ((> n 2)
- (let* ((j (quotient n 2))
- (a (step j))
- (k (- n j))
- (b (step k)))
- (sort:merge! a b less?)))
- ((= n 2)
- (let ((x (car seq))
- (y (cadr seq))
- (p seq))
- (set! seq (cddr seq))
- (cond ((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
- '())))
- (cond ((array? seq)
- (let ((dims (array-dimensions seq))
- (vec seq))
- (set! seq (rank-1-array->list seq))
- (do ((p (step (car dims)) (cdr p))
- (i 0 (+ i 1)))
- ((null? p) vec)
- (array-set! vec (car p) i))))
- (else ;; otherwise, assume it is a list
+ (cond ((> n 2) (let* ((j (quotient n 2))
+ (a (step j))
+ (k (- n j))
+ (b (step k)))
+ (sort:merge! a b less? keyer)))
+ ((= n 2) (let ((x (car seq))
+ (y (cadr seq))
+ (p seq))
+ (set! seq (cddr seq))
+ (cond ((less? (keyer y) (keyer 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 '())))
+ (define (key-wrap! lst)
+ (cond ((null? lst))
+ (else (set-car! lst (cons (key (car lst)) (car lst)))
+ (key-wrap! (cdr lst)))))
+ (define (key-unwrap! lst)
+ (cond ((null? lst))
+ (else (set-car! lst (cdar lst))
+ (key-unwrap! (cdr lst)))))
+ (cond (key
+ (key-wrap! seq)
+ (set! seq (step (length seq)))
+ (key-unwrap! seq)
+ seq)
+ (else
(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.
+;;; A. Jaffer modified to always return the original list.
;@
(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)
+ (define key (if (null? opt-key) #f (car opt-key)))
+ (cond ((array? seq)
+ (let ((dims (array-dimensions seq)))
+ (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+ (cdr sorted))
+ (i 0 (+ i 1)))
+ ((null? sorted) seq)
+ (array-set! seq (car sorted) i))))
+ (else ; otherwise, assume it is a list
+ (let ((ret (sort:sort-list! seq less? 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
@@ -168,13 +182,13 @@
;;; so (append x '()) ought to be a standard way of copying a list x.
;@
(define (sort seq less? . opt-key)
- (set! less? (sort:make-predicate 'sort less? opt-key))
+ (define key (if (null? opt-key) #f (car 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?)
+ (let ((dims (array-dimensions seq)))
+ (define newra (apply make-array seq dims))
+ (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) newra)
(array-set! newra (car sorted) i))))
- (else (sort:sort! (append seq '()) less?))))
+ (else (sort:sort-list! (append seq '()) less? key))))