From 64f037d91e0c9296dcaef9a0ff3eb33b19a2ed34 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:38 -0800
Subject: Import Upstream version 3a5

---
 sort.scm | 236 +++++++++++++++++++++++++++++++++------------------------------
 1 file changed, 125 insertions(+), 111 deletions(-)

(limited to 'sort.scm')

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))))
-- 
cgit v1.2.3