Import Upstream version 3a4upstream/3a4

1 files changed, 48 insertions, 28 deletions

diff --git a/sort.scm b/sort.scm
index b2199a9..1b96e4c 100644
--- a/sort.scm
+++ b/sort.scm
@@ -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!)